{-# LINE 1 "OpenSSL/EVP/Internal.hsc" #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CApiFFI                  #-}
module OpenSSL.EVP.Internal (
    Cipher(..),
    EVP_CIPHER,
    withCipherPtr,

    cipherIvLength,

    CipherCtx(..),
    EVP_CIPHER_CTX,
    newCipherCtx,
    withCipherCtxPtr,
    withNewCipherCtxPtr,

    CryptoMode(..),
    cipherSetPadding,
    cipherInitBS,
    cipherUpdateBS,
    cipherFinalBS,
    cipherStrictly,
    cipherLazily,

    Digest(..),
    EVP_MD,
    withMDPtr,

    DigestCtx(..),
    EVP_MD_CTX,
    withDigestCtxPtr,

    digestUpdateBS,
    digestFinalBS,
    digestFinal,
    digestStrictly,
    digestLazily,

    HmacCtx(..),
    HMAC_CTX,
    withHmacCtxPtr,

    hmacUpdateBS,
    hmacFinalBS,
    hmacLazily,

    VaguePKey(..),
    EVP_PKEY,
    PKey(..),
    createPKey,
    wrapPKeyPtr,
    withPKeyPtr,
    withPKeyPtr',
    unsafePKeyToPtr,
    touchPKey
  ) where



import qualified Data.ByteString.Internal as B8
import qualified Data.ByteString.Unsafe as B8
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Lazy.Internal as L8

{-# LINE 68 "OpenSSL/EVP/Internal.hsc" #-}
import Control.Exception (mask, mask_, bracket, onException)
import Foreign.C.Types (CChar, CUChar)

{-# LINE 71 "OpenSSL/EVP/Internal.hsc" #-}
import Foreign.C.Types (CInt(..), CUInt(..), CSize(..))

{-# LINE 75 "OpenSSL/EVP/Internal.hsc" #-}
import Foreign.Ptr (Ptr, castPtr, FunPtr)
import Foreign.C.String (CString, peekCStringLen)
import Foreign.ForeignPtr

{-# LINE 79 "OpenSSL/EVP/Internal.hsc" #-}
import Foreign.ForeignPtr.Unsafe as Unsafe

{-# LINE 83 "OpenSSL/EVP/Internal.hsc" #-}
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (allocaArray)
import System.IO.Unsafe (unsafeInterleaveIO)
import OpenSSL.Utils


{- EVP_CIPHER ---------------------------------------------------------------- -}

-- |@Cipher@ is an opaque object that represents an algorithm of
-- symmetric cipher.
newtype Cipher     = Cipher (Ptr EVP_CIPHER)
data {-# CTYPE "openssl/evp.h" "EVP_CIPHER" #-} EVP_CIPHER

withCipherPtr :: Cipher -> (Ptr EVP_CIPHER -> IO a) -> IO a
withCipherPtr :: forall a. Cipher -> (Ptr EVP_CIPHER -> IO a) -> IO a
withCipherPtr (Cipher Ptr EVP_CIPHER
cipherPtr) Ptr EVP_CIPHER -> IO a
f = Ptr EVP_CIPHER -> IO a
f Ptr EVP_CIPHER
cipherPtr

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_EVP_CIPHER_iv_length"
        _iv_length :: Ptr EVP_CIPHER -> CInt

cipherIvLength :: Cipher -> Int
cipherIvLength :: Cipher -> Int
cipherIvLength (Cipher Ptr EVP_CIPHER
cipherPtr) = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ Ptr EVP_CIPHER -> CInt
_iv_length Ptr EVP_CIPHER
cipherPtr

{- EVP_CIPHER_CTX ------------------------------------------------------------ -}

newtype CipherCtx      = CipherCtx (ForeignPtr EVP_CIPHER_CTX)
data {-# CTYPE "openssl/evp.h" "EVP_CIPHER_CTX" #-} EVP_CIPHER_CTX

foreign import capi unsafe "openssl/evp.h EVP_CIPHER_CTX_new"
  _cipher_ctx_new :: IO (Ptr EVP_CIPHER_CTX)


{-# LINE 115 "OpenSSL/EVP/Internal.hsc" #-}
foreign import capi unsafe "openssl/evp.h EVP_CIPHER_CTX_reset"
  _cipher_ctx_reset :: Ptr EVP_CIPHER_CTX -> IO ()

{-# LINE 121 "OpenSSL/EVP/Internal.hsc" #-}

foreign import capi unsafe "openssl/evp.h &EVP_CIPHER_CTX_free"
  _cipher_ctx_free :: FunPtr (Ptr EVP_CIPHER_CTX -> IO ())

foreign import capi unsafe "openssl/evp.h EVP_CIPHER_CTX_free"
  _cipher_ctx_free' :: Ptr EVP_CIPHER_CTX -> IO ()

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_EVP_CIPHER_CTX_block_size"
  _cipher_ctx_block_size :: Ptr EVP_CIPHER_CTX -> CInt

newCipherCtx :: IO CipherCtx
newCipherCtx :: IO CipherCtx
newCipherCtx = IO CipherCtx -> IO CipherCtx
forall a. IO a -> IO a
mask_ (IO CipherCtx -> IO CipherCtx) -> IO CipherCtx -> IO CipherCtx
forall a b. (a -> b) -> a -> b
$ do
  ctx <- FinalizerPtr EVP_CIPHER_CTX
-> Ptr EVP_CIPHER_CTX -> IO (ForeignPtr EVP_CIPHER_CTX)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr EVP_CIPHER_CTX
_cipher_ctx_free (Ptr EVP_CIPHER_CTX -> IO (ForeignPtr EVP_CIPHER_CTX))
-> IO (Ptr EVP_CIPHER_CTX) -> IO (ForeignPtr EVP_CIPHER_CTX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr EVP_CIPHER_CTX -> IO (Ptr EVP_CIPHER_CTX)
forall a. Ptr a -> IO (Ptr a)
failIfNull (Ptr EVP_CIPHER_CTX -> IO (Ptr EVP_CIPHER_CTX))
-> IO (Ptr EVP_CIPHER_CTX) -> IO (Ptr EVP_CIPHER_CTX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr EVP_CIPHER_CTX)
_cipher_ctx_new
  withForeignPtr ctx _cipher_ctx_reset
  return $ CipherCtx ctx

withCipherCtxPtr :: CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
withCipherCtxPtr :: forall a. CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
withCipherCtxPtr (CipherCtx ForeignPtr EVP_CIPHER_CTX
ctx) = ForeignPtr EVP_CIPHER_CTX -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr EVP_CIPHER_CTX
ctx

withNewCipherCtxPtr :: (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
withNewCipherCtxPtr :: forall a. (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
withNewCipherCtxPtr Ptr EVP_CIPHER_CTX -> IO a
f =
  IO (Ptr EVP_CIPHER_CTX)
-> (Ptr EVP_CIPHER_CTX -> IO ())
-> (Ptr EVP_CIPHER_CTX -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Ptr EVP_CIPHER_CTX -> IO (Ptr EVP_CIPHER_CTX)
forall a. Ptr a -> IO (Ptr a)
failIfNull (Ptr EVP_CIPHER_CTX -> IO (Ptr EVP_CIPHER_CTX))
-> IO (Ptr EVP_CIPHER_CTX) -> IO (Ptr EVP_CIPHER_CTX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr EVP_CIPHER_CTX)
_cipher_ctx_new) Ptr EVP_CIPHER_CTX -> IO ()
_cipher_ctx_free' ((Ptr EVP_CIPHER_CTX -> IO a) -> IO a)
-> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ Ptr EVP_CIPHER_CTX
p -> do
    Ptr EVP_CIPHER_CTX -> IO ()
_cipher_ctx_reset Ptr EVP_CIPHER_CTX
p
    Ptr EVP_CIPHER_CTX -> IO a
f Ptr EVP_CIPHER_CTX
p

{- encrypt/decrypt ----------------------------------------------------------- -}

-- |@CryptoMode@ represents instruction to 'cipher' and such like.
data CryptoMode = Encrypt | Decrypt

fromCryptoMode :: Num a => CryptoMode -> a
fromCryptoMode :: forall a. Num a => CryptoMode -> a
fromCryptoMode CryptoMode
Encrypt = a
1
fromCryptoMode CryptoMode
Decrypt = a
0

foreign import capi unsafe "openssl/evp.h EVP_CIPHER_CTX_set_padding"
  _SetPadding :: Ptr EVP_CIPHER_CTX -> CInt -> IO CInt

cipherSetPadding :: CipherCtx -> Int -> IO CipherCtx
cipherSetPadding :: CipherCtx -> Int -> IO CipherCtx
cipherSetPadding CipherCtx
ctx Int
pad
  = do CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO ()) -> IO ()
forall a. CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
withCipherCtxPtr CipherCtx
ctx ((Ptr EVP_CIPHER_CTX -> IO ()) -> IO ())
-> (Ptr EVP_CIPHER_CTX -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr EVP_CIPHER_CTX
ctxPtr ->
           Ptr EVP_CIPHER_CTX -> CInt -> IO CInt
_SetPadding Ptr EVP_CIPHER_CTX
ctxPtr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pad)
               IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
       CipherCtx -> IO CipherCtx
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CipherCtx
ctx

foreign import capi unsafe "openssl/evp.h EVP_CipherInit"
        _CipherInit :: Ptr EVP_CIPHER_CTX
                    -> Ptr EVP_CIPHER
                    -> CString
                    -> CString
                    -> CInt
                    -> IO CInt

cipherInitBS :: Cipher
             -> B8.ByteString -- ^ key
             -> B8.ByteString -- ^ IV
             -> CryptoMode
             -> IO CipherCtx
cipherInitBS :: Cipher -> ByteString -> ByteString -> CryptoMode -> IO CipherCtx
cipherInitBS (Cipher Ptr EVP_CIPHER
c) ByteString
key ByteString
iv CryptoMode
mode
    = do ctx <- IO CipherCtx
newCipherCtx
         withCipherCtxPtr ctx $ \ Ptr EVP_CIPHER_CTX
ctxPtr ->
             ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
B8.unsafeUseAsCString ByteString
key ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ CString
keyPtr ->
                 ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
B8.unsafeUseAsCString ByteString
iv ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ CString
ivPtr ->
                     Ptr EVP_CIPHER_CTX
-> Ptr EVP_CIPHER -> CString -> CString -> CInt -> IO CInt
_CipherInit Ptr EVP_CIPHER_CTX
ctxPtr Ptr EVP_CIPHER
c CString
keyPtr CString
ivPtr (CryptoMode -> CInt
forall a. Num a => CryptoMode -> a
fromCryptoMode CryptoMode
mode)
                          IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
         return ctx

foreign import capi unsafe "openssl/evp.h EVP_CipherUpdate"
  _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt
                -> Ptr CChar -> CInt -> IO CInt

cipherUpdateBS :: CipherCtx -> B8.ByteString -> IO B8.ByteString
cipherUpdateBS :: CipherCtx -> ByteString -> IO ByteString
cipherUpdateBS CipherCtx
ctx ByteString
inBS =
  CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO ByteString) -> IO ByteString
forall a. CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
withCipherCtxPtr CipherCtx
ctx ((Ptr EVP_CIPHER_CTX -> IO ByteString) -> IO ByteString)
-> (Ptr EVP_CIPHER_CTX -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr EVP_CIPHER_CTX
ctxPtr ->
    ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B8.unsafeUseAsCStringLen ByteString
inBS ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(CString
inBuf, Int
inLen) ->
      let len :: Int
len = Int
inLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ptr EVP_CIPHER_CTX -> CInt
_cipher_ctx_block_size Ptr EVP_CIPHER_CTX
ctxPtr) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 in
        Int -> (Ptr Word8 -> IO Int) -> IO ByteString
B8.createAndTrim Int
len ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
outBuf ->
          (Ptr CInt -> IO Int) -> IO Int
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO Int) -> IO Int) -> (Ptr CInt -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
outLenPtr ->
            Ptr EVP_CIPHER_CTX
-> CString -> Ptr CInt -> CString -> CInt -> IO CInt
_CipherUpdate Ptr EVP_CIPHER_CTX
ctxPtr (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
outBuf) Ptr CInt
outLenPtr CString
inBuf
                          (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
inLen)
              IO CInt -> (CInt -> IO CInt) -> IO CInt
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO CInt
forall a. (a -> Bool) -> a -> IO a
failIf (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
              IO CInt -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
outLenPtr

foreign import capi unsafe "openssl/evp.h EVP_CipherFinal"
  _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> IO CInt

cipherFinalBS :: CipherCtx -> IO B8.ByteString
cipherFinalBS :: CipherCtx -> IO ByteString
cipherFinalBS CipherCtx
ctx =
  CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO ByteString) -> IO ByteString
forall a. CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
withCipherCtxPtr CipherCtx
ctx ((Ptr EVP_CIPHER_CTX -> IO ByteString) -> IO ByteString)
-> (Ptr EVP_CIPHER_CTX -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr EVP_CIPHER_CTX
ctxPtr ->
    let len :: Int
len = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ Ptr EVP_CIPHER_CTX -> CInt
_cipher_ctx_block_size Ptr EVP_CIPHER_CTX
ctxPtr in
      Int -> (Ptr Word8 -> IO Int) -> IO ByteString
B8.createAndTrim Int
len ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
outBuf ->
        (Ptr CInt -> IO Int) -> IO Int
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO Int) -> IO Int) -> (Ptr CInt -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
outLenPtr ->
          Ptr EVP_CIPHER_CTX -> CString -> Ptr CInt -> IO CInt
_CipherFinal Ptr EVP_CIPHER_CTX
ctxPtr (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
outBuf) Ptr CInt
outLenPtr
            IO CInt -> (CInt -> IO CInt) -> IO CInt
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO CInt
forall a. (a -> Bool) -> a -> IO a
failIf (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
            IO CInt -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
outLenPtr

cipherStrictly :: CipherCtx -> B8.ByteString -> IO B8.ByteString
cipherStrictly :: CipherCtx -> ByteString -> IO ByteString
cipherStrictly CipherCtx
ctx ByteString
input = do
  output'  <- CipherCtx -> ByteString -> IO ByteString
cipherUpdateBS CipherCtx
ctx ByteString
input
  output'' <- cipherFinalBS ctx
  return $ B8.append output' output''

cipherLazily :: CipherCtx -> L8.ByteString -> IO L8.ByteString
cipherLazily :: CipherCtx -> ByteString -> IO ByteString
cipherLazily CipherCtx
ctx (ByteString
L8.Empty) =
  CipherCtx -> IO ByteString
cipherFinalBS CipherCtx
ctx IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
L8.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return
cipherLazily CipherCtx
ctx (L8.Chunk ByteString
x ByteString
xs) = do
  y  <- CipherCtx -> ByteString -> IO ByteString
cipherUpdateBS CipherCtx
ctx ByteString
x
  ys <- unsafeInterleaveIO $ cipherLazily ctx xs
  return $ L8.Chunk y ys

{- EVP_MD -------------------------------------------------------------------- -}

-- |@Digest@ is an opaque object that represents an algorithm of
-- message digest.
newtype Digest = Digest (Ptr EVP_MD)
data {-# CTYPE "openssl/evp.h" "EVP_MD" #-} EVP_MD

withMDPtr :: Digest -> (Ptr EVP_MD -> IO a) -> IO a
withMDPtr :: forall a. Digest -> (Ptr EVP_MD -> IO a) -> IO a
withMDPtr (Digest Ptr EVP_MD
mdPtr) Ptr EVP_MD -> IO a
f = Ptr EVP_MD -> IO a
f Ptr EVP_MD
mdPtr

{- EVP_MD_CTX ---------------------------------------------------------------- -}

newtype DigestCtx  = DigestCtx (ForeignPtr EVP_MD_CTX)
data {-# CTYPE "openssl/evp.h" "EVP_MD_CTX" #-}  EVP_MD_CTX



{-# LINE 247 "OpenSSL/EVP/Internal.hsc" #-}
foreign import capi unsafe "openssl/evp.h EVP_MD_CTX_new"
  _md_ctx_new :: IO (Ptr EVP_MD_CTX)
foreign import capi unsafe "openssl/evp.h EVP_MD_CTX_reset"
  _md_ctx_reset :: Ptr EVP_MD_CTX -> IO ()
foreign import capi unsafe "openssl/evp.h &EVP_MD_CTX_free"
  _md_ctx_free :: FunPtr (Ptr EVP_MD_CTX -> IO ())

{-# LINE 261 "OpenSSL/EVP/Internal.hsc" #-}

newDigestCtx :: IO DigestCtx
newDigestCtx :: IO DigestCtx
newDigestCtx = IO DigestCtx -> IO DigestCtx
forall a. IO a -> IO a
mask_ (IO DigestCtx -> IO DigestCtx) -> IO DigestCtx -> IO DigestCtx
forall a b. (a -> b) -> a -> b
$ do
  ctx <- FinalizerPtr EVP_MD_CTX
-> Ptr EVP_MD_CTX -> IO (ForeignPtr EVP_MD_CTX)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr EVP_MD_CTX
_md_ctx_free (Ptr EVP_MD_CTX -> IO (ForeignPtr EVP_MD_CTX))
-> IO (Ptr EVP_MD_CTX) -> IO (ForeignPtr EVP_MD_CTX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr EVP_MD_CTX -> IO (Ptr EVP_MD_CTX)
forall a. Ptr a -> IO (Ptr a)
failIfNull (Ptr EVP_MD_CTX -> IO (Ptr EVP_MD_CTX))
-> IO (Ptr EVP_MD_CTX) -> IO (Ptr EVP_MD_CTX)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr EVP_MD_CTX)
_md_ctx_new
  withForeignPtr ctx _md_ctx_reset
  return $ DigestCtx ctx

withDigestCtxPtr :: DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a
withDigestCtxPtr :: forall a. DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a
withDigestCtxPtr (DigestCtx ForeignPtr EVP_MD_CTX
ctx) = ForeignPtr EVP_MD_CTX -> (Ptr EVP_MD_CTX -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr EVP_MD_CTX
ctx

{- digest -------------------------------------------------------------------- -}

foreign import capi unsafe "openssl/evp.h EVP_DigestInit"
  _DigestInit :: Ptr EVP_MD_CTX -> Ptr EVP_MD -> IO CInt

digestInit :: Digest -> IO DigestCtx
digestInit :: Digest -> IO DigestCtx
digestInit (Digest Ptr EVP_MD
md) = do
  ctx <- IO DigestCtx
newDigestCtx
  withDigestCtxPtr ctx $ \Ptr EVP_MD_CTX
ctxPtr ->
    Ptr EVP_MD_CTX -> Ptr EVP_MD -> IO CInt
_DigestInit Ptr EVP_MD_CTX
ctxPtr Ptr EVP_MD
md
      IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
      IO () -> IO DigestCtx -> IO DigestCtx
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  DigestCtx -> IO DigestCtx
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DigestCtx
ctx

foreign import capi unsafe "openssl/evp.h EVP_DigestUpdate"
  _DigestUpdate :: Ptr EVP_MD_CTX -> Ptr CChar -> CSize -> IO CInt

digestUpdateBS :: DigestCtx -> B8.ByteString -> IO ()
digestUpdateBS :: DigestCtx -> ByteString -> IO ()
digestUpdateBS DigestCtx
ctx ByteString
bs =
  DigestCtx -> (Ptr EVP_MD_CTX -> IO ()) -> IO ()
forall a. DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a
withDigestCtxPtr DigestCtx
ctx ((Ptr EVP_MD_CTX -> IO ()) -> IO ())
-> (Ptr EVP_MD_CTX -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr EVP_MD_CTX
ctxPtr ->
    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B8.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(CString
buf, Int
len) ->
      Ptr EVP_MD_CTX -> CString -> CSize -> IO CInt
_DigestUpdate Ptr EVP_MD_CTX
ctxPtr CString
buf (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        IO CInt -> (CInt -> IO CInt) -> IO CInt
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO CInt
forall a. (a -> Bool) -> a -> IO a
failIf (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
        IO CInt -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

foreign import capi unsafe "openssl/evp.h EVP_DigestFinal"
  _DigestFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> Ptr CUInt -> IO CInt

digestFinalBS :: DigestCtx -> IO B8.ByteString
digestFinalBS :: DigestCtx -> IO ByteString
digestFinalBS DigestCtx
ctx =
  DigestCtx -> (Ptr EVP_MD_CTX -> IO ByteString) -> IO ByteString
forall a. DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a
withDigestCtxPtr DigestCtx
ctx ((Ptr EVP_MD_CTX -> IO ByteString) -> IO ByteString)
-> (Ptr EVP_MD_CTX -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr EVP_MD_CTX
ctxPtr ->
    Int -> (Ptr Word8 -> IO Int) -> IO ByteString
B8.createAndTrim (Int
64) ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
bufPtr ->
{-# LINE 302 "OpenSSL/EVP/Internal.hsc" #-}
      alloca $ \bufLenPtr -> do
        _DigestFinal ctxPtr (castPtr bufPtr) bufLenPtr >>= failIf_ (/= 1)
        fromIntegral <$> peek bufLenPtr

digestFinal :: DigestCtx -> IO String
digestFinal :: DigestCtx -> IO String
digestFinal DigestCtx
ctx =
  DigestCtx -> (Ptr EVP_MD_CTX -> IO String) -> IO String
forall a. DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a
withDigestCtxPtr DigestCtx
ctx ((Ptr EVP_MD_CTX -> IO String) -> IO String)
-> (Ptr EVP_MD_CTX -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Ptr EVP_MD_CTX
ctxPtr ->
    Int -> (CString -> IO String) -> IO String
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (Int
64) ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \CString
bufPtr ->
{-# LINE 310 "OpenSSL/EVP/Internal.hsc" #-}
      alloca $ \bufLenPtr -> do
        _DigestFinal ctxPtr bufPtr bufLenPtr >>= failIf_ (/= 1)
        bufLen <- fromIntegral <$> peek bufLenPtr
        peekCStringLen (bufPtr, bufLen)

digestStrictly :: Digest -> B8.ByteString -> IO DigestCtx
digestStrictly :: Digest -> ByteString -> IO DigestCtx
digestStrictly Digest
md ByteString
input = do
  ctx <- Digest -> IO DigestCtx
digestInit Digest
md
  digestUpdateBS ctx input
  return ctx

digestLazily :: Digest -> L8.ByteString -> IO DigestCtx
digestLazily :: Digest -> ByteString -> IO DigestCtx
digestLazily Digest
md ByteString
lbs = do
  ctx <- Digest -> IO DigestCtx
digestInit Digest
md
  mapM_ (digestUpdateBS ctx) $ L8.toChunks lbs
  return ctx

{- HMAC ---------------------------------------------------------------------- -}
newtype HmacCtx = HmacCtx (ForeignPtr HMAC_CTX)
data {-# CTYPE "openssl/hmac.h" "HMAC_CTX" #-} HMAC_CTX

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_HMAC_CTX_new"
  _hmac_ctx_new :: IO (Ptr HMAC_CTX)

foreign import capi unsafe "openssl/hmac.h HMAC_Init"
  _hmac_init :: Ptr HMAC_CTX -> Ptr () -> CInt -> Ptr EVP_MD -> IO CInt

foreign import capi unsafe "openssl/hmac.h HMAC_Update"
  _hmac_update :: Ptr HMAC_CTX -> Ptr CUChar -> CSize -> IO CInt

foreign import capi unsafe "openssl/hmac.h HMAC_Final"
  _hmac_final :: Ptr HMAC_CTX -> Ptr CUChar -> Ptr CUInt -> IO CUInt

foreign import capi unsafe "HsOpenSSL &HsOpenSSL_HMAC_CTX_free"
  _hmac_ctx_free :: FunPtr (Ptr HMAC_CTX -> IO ())

newHmacCtx :: IO HmacCtx
newHmacCtx :: IO HmacCtx
newHmacCtx = do
    ctxPtr <- IO (Ptr HMAC_CTX)
_hmac_ctx_new
    HmacCtx <$> newForeignPtr _hmac_ctx_free ctxPtr

withHmacCtxPtr :: HmacCtx -> (Ptr HMAC_CTX -> IO a) -> IO a
withHmacCtxPtr :: forall a. HmacCtx -> (Ptr HMAC_CTX -> IO a) -> IO a
withHmacCtxPtr (HmacCtx ForeignPtr HMAC_CTX
ctx) = ForeignPtr HMAC_CTX -> (Ptr HMAC_CTX -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr HMAC_CTX
ctx

hmacInit :: Digest -> B8.ByteString -> IO HmacCtx
hmacInit :: Digest -> ByteString -> IO HmacCtx
hmacInit (Digest Ptr EVP_MD
md) ByteString
key = do
  ctx <- IO HmacCtx
newHmacCtx
  withHmacCtxPtr ctx $ \Ptr HMAC_CTX
ctxPtr ->
    ByteString -> (CStringLen -> IO HmacCtx) -> IO HmacCtx
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B8.unsafeUseAsCStringLen ByteString
key ((CStringLen -> IO HmacCtx) -> IO HmacCtx)
-> (CStringLen -> IO HmacCtx) -> IO HmacCtx
forall a b. (a -> b) -> a -> b
$ \(CString
keyPtr, Int
keyLen) ->
      Ptr HMAC_CTX -> Ptr () -> CInt -> Ptr EVP_MD -> IO CInt
_hmac_init Ptr HMAC_CTX
ctxPtr (CString -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr CString
keyPtr) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
keyLen) Ptr EVP_MD
md
        IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)
        IO () -> IO HmacCtx -> IO HmacCtx
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HmacCtx -> IO HmacCtx
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HmacCtx
ctx

hmacUpdateBS :: HmacCtx -> B8.ByteString -> IO ()
hmacUpdateBS :: HmacCtx -> ByteString -> IO ()
hmacUpdateBS HmacCtx
ctx ByteString
bs = HmacCtx -> (Ptr HMAC_CTX -> IO ()) -> IO ()
forall a. HmacCtx -> (Ptr HMAC_CTX -> IO a) -> IO a
withHmacCtxPtr HmacCtx
ctx ((Ptr HMAC_CTX -> IO ()) -> IO ())
-> (Ptr HMAC_CTX -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr HMAC_CTX
ctxPtr -> do
  ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B8.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(CString
buf, Int
len) ->
    Ptr HMAC_CTX -> Ptr CUChar -> CSize -> IO CInt
_hmac_update Ptr HMAC_CTX
ctxPtr (CString -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr CString
buf) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
      IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)

hmacFinalBS :: HmacCtx -> IO B8.ByteString
hmacFinalBS :: HmacCtx -> IO ByteString
hmacFinalBS HmacCtx
ctx =
  HmacCtx -> (Ptr HMAC_CTX -> IO ByteString) -> IO ByteString
forall a. HmacCtx -> (Ptr HMAC_CTX -> IO a) -> IO a
withHmacCtxPtr HmacCtx
ctx ((Ptr HMAC_CTX -> IO ByteString) -> IO ByteString)
-> (Ptr HMAC_CTX -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr HMAC_CTX
ctxPtr ->
    Int -> (Ptr Word8 -> IO Int) -> IO ByteString
B8.createAndTrim (Int
64) ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
bufPtr ->
{-# LINE 373 "OpenSSL/EVP/Internal.hsc" #-}
      alloca $ \bufLenPtr -> do
        _hmac_final ctxPtr (castPtr bufPtr) bufLenPtr >>= failIf_ (/= 1)
        fromIntegral <$> peek bufLenPtr

hmacLazily :: Digest -> B8.ByteString -> L8.ByteString -> IO HmacCtx
hmacLazily :: Digest -> ByteString -> ByteString -> IO HmacCtx
hmacLazily Digest
md ByteString
key ByteString
lbs = do
  ctx <- Digest -> ByteString -> IO HmacCtx
hmacInit Digest
md ByteString
key
  mapM_ (hmacUpdateBS ctx) $ L8.toChunks lbs
  return ctx

{- EVP_PKEY ------------------------------------------------------------------ -}

-- | VaguePKey is a 'ForeignPtr' to 'EVP_PKEY', that is either public
-- key or a ker pair. We can't tell which at compile time.
newtype VaguePKey = VaguePKey (ForeignPtr EVP_PKEY)
data {-# CTYPE "openssl/evp.h" "EVP_PKEY" #-} EVP_PKEY

-- | Instances of class 'PKey' can be converted back and forth to
-- 'VaguePKey'.
class PKey k where
    -- | Wrap the key (i.g. RSA) into 'EVP_PKEY'.
    toPKey        :: k -> IO VaguePKey

    -- | Extract the concrete key from the 'EVP_PKEY'. Returns
    -- 'Nothing' if the type mismatches.
    fromPKey      :: VaguePKey -> IO (Maybe k)

    -- | Do the same as EVP_PKEY_size().
    pkeySize      :: k -> Int

    -- | Return the default digesting algorithm for the key.
    pkeyDefaultMD :: k -> IO Digest

foreign import capi unsafe "openssl/evp.h EVP_PKEY_new"
  _pkey_new :: IO (Ptr EVP_PKEY)

foreign import capi unsafe "openssl/evp.h &EVP_PKEY_free"
  _pkey_free :: FunPtr (Ptr EVP_PKEY -> IO ())

foreign import capi unsafe "openssl/evp.h EVP_PKEY_free"
  _pkey_free' :: Ptr EVP_PKEY -> IO ()

wrapPKeyPtr :: Ptr EVP_PKEY -> IO VaguePKey
wrapPKeyPtr :: Ptr EVP_PKEY -> IO VaguePKey
wrapPKeyPtr = (ForeignPtr EVP_PKEY -> VaguePKey)
-> IO (ForeignPtr EVP_PKEY) -> IO VaguePKey
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr EVP_PKEY -> VaguePKey
VaguePKey (IO (ForeignPtr EVP_PKEY) -> IO VaguePKey)
-> (Ptr EVP_PKEY -> IO (ForeignPtr EVP_PKEY))
-> Ptr EVP_PKEY
-> IO VaguePKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FinalizerPtr EVP_PKEY -> Ptr EVP_PKEY -> IO (ForeignPtr EVP_PKEY)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr EVP_PKEY
_pkey_free

createPKey :: (Ptr EVP_PKEY -> IO a) -> IO VaguePKey
createPKey :: forall a. (Ptr EVP_PKEY -> IO a) -> IO VaguePKey
createPKey Ptr EVP_PKEY -> IO a
f = ((forall a. IO a -> IO a) -> IO VaguePKey) -> IO VaguePKey
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO VaguePKey) -> IO VaguePKey)
-> ((forall a. IO a -> IO a) -> IO VaguePKey) -> IO VaguePKey
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  ptr <- IO (Ptr EVP_PKEY)
_pkey_new IO (Ptr EVP_PKEY)
-> (Ptr EVP_PKEY -> IO (Ptr EVP_PKEY)) -> IO (Ptr EVP_PKEY)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr EVP_PKEY -> IO (Ptr EVP_PKEY)
forall a. Ptr a -> IO (Ptr a)
failIfNull
  (restore $ f ptr >> return ()) `onException` _pkey_free' ptr
  wrapPKeyPtr ptr

withPKeyPtr :: VaguePKey -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr :: forall a. VaguePKey -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr (VaguePKey ForeignPtr EVP_PKEY
pkey) = ForeignPtr EVP_PKEY -> (Ptr EVP_PKEY -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr EVP_PKEY
pkey

withPKeyPtr' :: PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr' :: forall k a. PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr' k
k Ptr EVP_PKEY -> IO a
f = do
  pk <- k -> IO VaguePKey
forall k. PKey k => k -> IO VaguePKey
toPKey k
k
  withPKeyPtr pk f

unsafePKeyToPtr :: VaguePKey -> Ptr EVP_PKEY
unsafePKeyToPtr :: VaguePKey -> Ptr EVP_PKEY
unsafePKeyToPtr (VaguePKey ForeignPtr EVP_PKEY
pkey) = ForeignPtr EVP_PKEY -> Ptr EVP_PKEY
forall a. ForeignPtr a -> Ptr a
Unsafe.unsafeForeignPtrToPtr ForeignPtr EVP_PKEY
pkey

touchPKey :: VaguePKey -> IO ()
touchPKey :: VaguePKey -> IO ()
touchPKey (VaguePKey ForeignPtr EVP_PKEY
pkey) = ForeignPtr EVP_PKEY -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr EVP_PKEY
pkey