{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CApiFFI                  #-}
-- |Asymmetric cipher decryption using encrypted symmetric key. This
-- is an opposite of "OpenSSL.EVP.Open".
module OpenSSL.EVP.Seal
    ( seal
    , sealBS
    , sealLBS
    )
    where
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as L8
import           Foreign
import           Foreign.C
import           OpenSSL.EVP.Cipher hiding (cipher)
import           OpenSSL.EVP.PKey
import           OpenSSL.EVP.Internal
import           OpenSSL.Utils


foreign import capi unsafe "openssl/evp.h EVP_SealInit"
        _SealInit :: Ptr EVP_CIPHER_CTX
                  -> Cipher
                  -> Ptr (Ptr CChar)
                  -> Ptr CInt
                  -> Ptr CChar
                  -> Ptr (Ptr EVP_PKEY)
                  -> CInt
                  -> IO CInt


sealInit :: Cipher
         -> [SomePublicKey]
         -> IO (CipherCtx, [B8.ByteString], B8.ByteString)

sealInit :: Cipher
-> [SomePublicKey] -> IO (CipherCtx, [ByteString], ByteString)
sealInit Cipher
_ []
    = String -> IO (CipherCtx, [ByteString], ByteString)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"sealInit: at least one public key is required"

sealInit Cipher
cipher [SomePublicKey]
pubKeys
    = do ctx <- IO CipherCtx
newCipherCtx

         -- Allocate a list of buffers to write encrypted symmetric
         -- keys. Each keys will be at most pkeySize bytes long.
         encKeyBufs <- mapM mallocEncKeyBuf pubKeys

         -- encKeyBufs is [Ptr a] but we want Ptr (Ptr CChar).
         encKeyBufsPtr <- newArray encKeyBufs

         -- Allocate a buffer to write lengths of each encrypted
         -- symmetric keys.
         encKeyBufsLenPtr <- mallocArray nKeys

         -- Allocate a buffer to write IV.
         ivPtr <- mallocArray (cipherIvLength cipher)

         -- Create Ptr (Ptr EVP_PKEY) from [PKey]. Don't forget to
         -- apply touchForeignPtr to each PKey's later.
         pkeys      <- mapM toPKey pubKeys
         pubKeysPtr <- newArray $ map unsafePKeyToPtr pkeys

         -- Prepare an IO action to free buffers we allocated above.
         let cleanup = do (Ptr CChar -> IO ()) -> [Ptr CChar] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ptr CChar -> IO ()
forall a. Ptr a -> IO ()
free [Ptr CChar]
encKeyBufs
                          Ptr (Ptr CChar) -> IO ()
forall a. Ptr a -> IO ()
free Ptr (Ptr CChar)
encKeyBufsPtr
                          Ptr CInt -> IO ()
forall a. Ptr a -> IO ()
free Ptr CInt
encKeyBufsLenPtr
                          Ptr CChar -> IO ()
forall a. Ptr a -> IO ()
free Ptr CChar
ivPtr
                          Ptr (Ptr EVP_PKEY) -> IO ()
forall a. Ptr a -> IO ()
free Ptr (Ptr EVP_PKEY)
pubKeysPtr
                          (VaguePKey -> IO ()) -> [VaguePKey] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VaguePKey -> IO ()
touchPKey [VaguePKey]
pkeys

         -- Call EVP_SealInit finally.
         ret <- withCipherCtxPtr ctx $ \ Ptr EVP_CIPHER_CTX
ctxPtr ->
                Ptr EVP_CIPHER_CTX
-> Cipher
-> Ptr (Ptr CChar)
-> Ptr CInt
-> Ptr CChar
-> Ptr (Ptr EVP_PKEY)
-> CInt
-> IO CInt
_SealInit Ptr EVP_CIPHER_CTX
ctxPtr Cipher
cipher Ptr (Ptr CChar)
encKeyBufsPtr Ptr CInt
encKeyBufsLenPtr Ptr CChar
ivPtr Ptr (Ptr EVP_PKEY)
pubKeysPtr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nKeys)

         if ret == 0 then
             cleanup >> raiseOpenSSLError
           else
             do encKeysLen <- peekArray nKeys encKeyBufsLenPtr
                encKeys    <- mapM B8.packCStringLen $ zip encKeyBufs (fromIntegral `fmap` encKeysLen)
                iv         <- B8.packCStringLen (ivPtr, cipherIvLength cipher)
                cleanup
                return (ctx, encKeys, iv)
    where
      nKeys :: Int
      nKeys :: Int
nKeys = [SomePublicKey] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SomePublicKey]
pubKeys

      mallocEncKeyBuf :: (PKey k, Storable a) => k -> IO (Ptr a)
      mallocEncKeyBuf :: forall k a. (PKey k, Storable a) => k -> IO (Ptr a)
mallocEncKeyBuf = Int -> IO (Ptr a)
forall a. Storable a => Int -> IO (Ptr a)
mallocArray (Int -> IO (Ptr a)) -> (k -> Int) -> k -> IO (Ptr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> Int
forall k. PKey k => k -> Int
pkeySize

-- |@'seal'@ lazilly encrypts a stream of data. The input string
-- doesn't necessarily have to be finite.
seal :: Cipher          -- ^ symmetric cipher algorithm to use
     -> [SomePublicKey] -- ^ A list of public keys to encrypt a
                        --   symmetric key. At least one public key
                        --   must be supplied. If two or more keys are
                        --   given, the symmetric key are encrypted by
                        --   each public keys so that any of the
                        --   corresponding private keys can decrypt
                        --   the message.
     -> String          -- ^ input string to encrypt
     -> IO ( String
           , [String]
           , String
           ) -- ^ (encrypted string, list of encrypted asymmetric
             -- keys, IV)
{-# DEPRECATED seal "Use sealBS or sealLBS instead." #-}
seal :: Cipher
-> [SomePublicKey] -> String -> IO (String, [String], String)
seal Cipher
cipher [SomePublicKey]
pubKeys String
input
    = do (output, encKeys, iv) <- Cipher
-> [SomePublicKey]
-> ByteString
-> IO (ByteString, [ByteString], ByteString)
sealLBS Cipher
cipher [SomePublicKey]
pubKeys (ByteString -> IO (ByteString, [ByteString], ByteString))
-> ByteString -> IO (ByteString, [ByteString], ByteString)
forall a b. (a -> b) -> a -> b
$ String -> ByteString
L8.pack String
input
         return ( L8.unpack output
                , B8.unpack `fmap` encKeys
                , B8.unpack iv
                )

-- |@'sealBS'@ strictly encrypts a chunk of data.
sealBS :: Cipher          -- ^ symmetric cipher algorithm to use
       -> [SomePublicKey] -- ^ list of public keys to encrypt a
                          --   symmetric key
       -> B8.ByteString   -- ^ input string to encrypt
       -> IO ( B8.ByteString
             , [B8.ByteString]
             , B8.ByteString
             ) -- ^ (encrypted string, list of encrypted asymmetric
               -- keys, IV)
sealBS :: Cipher
-> [SomePublicKey]
-> ByteString
-> IO (ByteString, [ByteString], ByteString)
sealBS Cipher
cipher [SomePublicKey]
pubKeys ByteString
input
    = do (ctx, encKeys, iv) <- Cipher
-> [SomePublicKey] -> IO (CipherCtx, [ByteString], ByteString)
sealInit Cipher
cipher [SomePublicKey]
pubKeys
         output             <- cipherStrictly ctx input
         return (output, encKeys, iv)

-- |@'sealLBS'@ lazilly encrypts a stream of data. The input string
-- doesn't necessarily have to be finite.
sealLBS :: Cipher          -- ^ symmetric cipher algorithm to use
        -> [SomePublicKey] -- ^ list of public keys to encrypt a
                           --   symmetric key
        -> L8.ByteString   -- ^ input string to encrypt
        -> IO ( L8.ByteString
              , [B8.ByteString]
              , B8.ByteString
              ) -- ^ (encrypted string, list of encrypted asymmetric
                -- keys, IV)
sealLBS :: Cipher
-> [SomePublicKey]
-> ByteString
-> IO (ByteString, [ByteString], ByteString)
sealLBS Cipher
cipher [SomePublicKey]
pubKeys ByteString
input
    = do (ctx, encKeys, iv) <- Cipher
-> [SomePublicKey] -> IO (CipherCtx, [ByteString], ByteString)
sealInit Cipher
cipher [SomePublicKey]
pubKeys
         output             <- cipherLazily ctx input
         return (output, encKeys, iv)