{-# LANGUAGE CPP #-}

-- |
-- Module      : Amazonka.S3.Encryption.Envelope
-- Copyright   : (c) 2013-2023 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay+amazonka.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Amazonka.S3.Encryption.Envelope where

import qualified Amazonka as AWS
import Amazonka.Data
import qualified Amazonka.KMS as KMS
import qualified Amazonka.KMS.Lens as KMS
import Amazonka.Prelude hiding (length)
import Amazonka.S3.Encryption.Body
import Amazonka.S3.Encryption.Types
import Conduit ((.|))
import qualified Conduit
import qualified Control.Exception as Exception
import Control.Lens ((?~), (^.))
import Crypto.Cipher.AES (AES256)
import qualified Crypto.Cipher.AES as AES
import Crypto.Cipher.Types (BlockCipher, Cipher, IV)
import qualified Crypto.Cipher.Types as Cipher
import qualified Crypto.Data.Padding as Padding
import qualified Crypto.Error
import qualified Crypto.PubKey.RSA.PKCS15 as RSA
import Crypto.PubKey.RSA.Types (KeyPair, toPrivateKey, toPublicKey)
import Crypto.Random (getRandomBytes)
import qualified Data.Aeson as Aeson
import Data.ByteArray (ByteArray)
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as BS
import qualified Data.CaseInsensitive as CI
import Data.Functor ((<&>))
import qualified Data.HashMap.Strict as Map

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Key
#endif

data V1Envelope = V1Envelope
  { -- | @x-amz-key@: Content encrypting key (cek) in encrypted form, base64
    -- encoded. The cek is randomly generated per S3 object, and is always
    -- an AES 256-bit key. The corresponding cipher is always @AES/CBC/PKCS5Padding@.
    V1Envelope -> ByteString
_v1Key :: !ByteString,
    -- | @x-amz-iv@: Randomly generated IV (per S3 object), base64 encoded.
    V1Envelope -> IV AES256
_v1IV :: !(Cipher.IV AES.AES256),
    -- | @x-amz-matdesc@: Customer provided material description in JSON (UTF8)
    -- format.
    V1Envelope -> Description
_v1Description :: !Description
  }

newV1 :: MonadIO m => (ByteString -> IO ByteString) -> Description -> m Envelope
newV1 :: forall (m :: * -> *).
MonadIO m =>
(ByteString -> IO ByteString) -> Description -> m Envelope
newV1 ByteString -> IO ByteString
f Description
d =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    ByteString
k <- forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
aesKeySize
    AES256
c <- forall (m :: * -> *) a b.
(MonadIO m, ByteArray a, Cipher b) =>
a -> m b
createCipher ByteString
k
    ByteString
ek <- ByteString -> IO ByteString
f ByteString
k
    IV AES256
iv <- forall (m :: * -> *) a.
(MonadIO m, BlockCipher a) =>
ByteString -> m (IV a)
createIV forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
aesBlockSize

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. AES256 -> V1Envelope -> Envelope
V1 AES256
c forall a b. (a -> b) -> a -> b
$
      V1Envelope
        { _v1Key :: ByteString
_v1Key = ByteString
ek,
          _v1IV :: IV AES256
_v1IV = IV AES256
iv,
          _v1Description :: Description
_v1Description = Description
d
        }

decodeV1 ::
  MonadResource m =>
  (ByteString -> IO ByteString) ->
  [(CI Text, Text)] ->
  m Envelope
decodeV1 :: forall (m :: * -> *).
MonadResource m =>
(ByteString -> IO ByteString) -> [(CI Text, Text)] -> m Envelope
decodeV1 ByteString -> IO ByteString
decryptKey [(CI Text, Text)]
meta = do
  Base64 ByteString
k <- [(CI Text, Text)]
meta forall (m :: * -> *) a.
(MonadIO m, FromText a) =>
[(CI Text, Text)] -> CI Text -> m a
.& CI Text
"X-Amz-Key"
  Base64 ByteString
i <- [(CI Text, Text)]
meta forall (m :: * -> *) a.
(MonadIO m, FromText a) =>
[(CI Text, Text)] -> CI Text -> m a
.& CI Text
"X-Amz-IV"
  Description
d <- [(CI Text, Text)]
meta forall (m :: * -> *) a.
(MonadIO m, FromText a) =>
[(CI Text, Text)] -> CI Text -> m a
.& CI Text
"X-Amz-Matdesc"

  ByteString
key <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ByteString -> IO ByteString
decryptKey ByteString
k)
  IV AES256
iv <- forall (m :: * -> *) a.
(MonadIO m, BlockCipher a) =>
ByteString -> m (IV a)
createIV ByteString
i
  AES256
cipher <- forall (m :: * -> *) a b.
(MonadIO m, ByteArray a, Cipher b) =>
a -> m b
createCipher ByteString
key

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. AES256 -> V1Envelope -> Envelope
V1 AES256
cipher forall a b. (a -> b) -> a -> b
$
    V1Envelope
      { _v1Key :: ByteString
_v1Key = ByteString
key,
        _v1IV :: IV AES256
_v1IV = IV AES256
iv,
        _v1Description :: Description
_v1Description = Description
d
      }

data V2Envelope = V2Envelope
  { -- | @x-amz-key-v2@: CEK in key wrapped form. This is necessary so that
    -- the S3 encryption client that doesn't recognize the v2 format will not
    -- mistakenly decrypt S3 object encrypted in v2 format.
    V2Envelope -> ByteString
_v2Key :: !ByteString,
    -- | @x-amz-iv@: Randomly generated IV (per S3 object), base64 encoded.
    V2Envelope -> IV AES256
_v2IV :: !(Cipher.IV AES.AES256),
    -- | @x-amz-cek-alg@: Content encryption algorithm used.  Supported values:
    -- @AES/GCM/NoPadding@, @AES/CBC/PKCS5Padding@ Default to @AES/CBC/PKCS5Padding@
    -- if this key is absent.
    --
    -- Supported values: @AESWrap@, @RSA/ECB/OAEPWithSHA-256AndMGF1Padding@, @kms@ No
    -- standard key wrapping is used if this meta information is absent Always set to
    -- @kms@ if KMS is used for client-side encryption
    V2Envelope -> ContentAlgorithm
_v2CEKAlgorithm :: !ContentAlgorithm,
    -- | @x-amz-wrap-alg@: Key wrapping algorithm used.
    V2Envelope -> WrappingAlgorithm
_v2WrapAlgorithm :: !WrappingAlgorithm,
    -- | @x-amz-matdesc@: Customer provided material description in JSON format.
    -- Used to identify the client-side master key. For KMS client side
    -- encryption, the KMS Customer Master Key ID is stored as part of the material
    -- description, @x-amz-matdesc, under the key-name @kms_cmk_id@.
    V2Envelope -> Description
_v2Description :: !Description
  }

newV2 ::
  MonadResource m =>
  Text ->
  AWS.Env ->
  Description ->
  m Envelope
newV2 :: forall (m :: * -> *).
MonadResource m =>
Text -> Env -> Description -> m Envelope
newV2 Text
kid Env
env Description
d = do
  let context :: HashMap Text Text
context = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Text
"kms_cmk_id" Text
kid (Description -> HashMap Text Text
fromDescription Description
d)

  GenerateDataKeyResponse
rs <-
    forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (AWSResponse a)
AWS.send Env
env forall a b. (a -> b) -> a -> b
$
      Text -> GenerateDataKey
KMS.newGenerateDataKey Text
kid
        forall a b. a -> (a -> b) -> b
& Lens' GenerateDataKey (Maybe (HashMap Text Text))
KMS.generateDataKey_encryptionContext forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ HashMap Text Text
context
        forall a b. a -> (a -> b) -> b
& Lens' GenerateDataKey (Maybe DataKeySpec)
KMS.generateDataKey_keySpec forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ DataKeySpec
KMS.DataKeySpec_AES_256

  ByteString
ivBytes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
aesBlockSize)
  IV AES256
iv <- forall (m :: * -> *) a.
(MonadIO m, BlockCipher a) =>
ByteString -> m (IV a)
createIV ByteString
ivBytes
  AES256
cipher <- forall (m :: * -> *) a b.
(MonadIO m, ByteArray a, Cipher b) =>
a -> m b
createCipher (GenerateDataKeyResponse
rs forall s a. s -> Getting a s a -> a
^. Lens' GenerateDataKeyResponse ByteString
KMS.generateDataKeyResponse_plaintext)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. AES256 -> V2Envelope -> Envelope
V2 AES256
cipher forall a b. (a -> b) -> a -> b
$
    V2Envelope
      { _v2Key :: ByteString
_v2Key = GenerateDataKeyResponse
rs forall s a. s -> Getting a s a -> a
^. Lens' GenerateDataKeyResponse ByteString
KMS.generateDataKeyResponse_ciphertextBlob,
        _v2IV :: IV AES256
_v2IV = IV AES256
iv,
        _v2CEKAlgorithm :: ContentAlgorithm
_v2CEKAlgorithm = ContentAlgorithm
AES_CBC_PKCS5Padding,
        _v2WrapAlgorithm :: WrappingAlgorithm
_v2WrapAlgorithm = WrappingAlgorithm
KMSWrap,
        _v2Description :: Description
_v2Description = HashMap Text Text -> Description
Description HashMap Text Text
context
      }

decodeV2 ::
  MonadResource m =>
  AWS.Env ->
  [(CI Text, Text)] ->
  Description ->
  m Envelope
decodeV2 :: forall (m :: * -> *).
MonadResource m =>
Env -> [(CI Text, Text)] -> Description -> m Envelope
decodeV2 Env
env [(CI Text, Text)]
xs Description
m = do
  ContentAlgorithm
a <- [(CI Text, Text)]
xs forall (m :: * -> *) a.
(MonadIO m, FromText a) =>
[(CI Text, Text)] -> CI Text -> m a
.& CI Text
"X-Amz-CEK-Alg"
  WrappingAlgorithm
w <- [(CI Text, Text)]
xs forall (m :: * -> *) a.
(MonadIO m, FromText a) =>
[(CI Text, Text)] -> CI Text -> m a
.& CI Text
"X-Amz-Wrap-Alg"
  ByteString
raw <- ([(CI Text, Text)]
xs forall (m :: * -> *) a.
(MonadIO m, FromText a) =>
[(CI Text, Text)] -> CI Text -> m a
.& CI Text
"X-Amz-Key-V2") forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Base64 -> ByteString
unBase64
  IV AES256
iv <- [(CI Text, Text)]
xs forall (m :: * -> *) a.
(MonadIO m, FromText a) =>
[(CI Text, Text)] -> CI Text -> m a
.& CI Text
"X-Amz-IV" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
(MonadIO m, BlockCipher a) =>
ByteString -> m (IV a)
createIV forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base64 -> ByteString
unBase64
  Description
d <- [(CI Text, Text)]
xs forall (m :: * -> *) a.
(MonadIO m, FromText a) =>
[(CI Text, Text)] -> CI Text -> m a
.& CI Text
"X-Amz-Matdesc"

  DecryptResponse
rs <-
    forall (m :: * -> *) a.
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a)) =>
Env -> a -> m (AWSResponse a)
AWS.send Env
env forall a b. (a -> b) -> a -> b
$
      ByteString -> Decrypt
KMS.newDecrypt ByteString
raw
        forall a b. a -> (a -> b) -> b
& Lens' Decrypt (Maybe (HashMap Text Text))
KMS.decrypt_encryptionContext forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Description -> HashMap Text Text
fromDescription (Description
m forall a. Semigroup a => a -> a -> a
<> Description
d)
  -- Left-associative merge for material description,
  -- keys in the supplied description override those
  -- on the envelope.

  ByteString
k <- forall (m :: * -> *). MonadIO m => DecryptResponse -> m ByteString
plaintext DecryptResponse
rs
  AES256
c <- forall (m :: * -> *) a b.
(MonadIO m, ByteArray a, Cipher b) =>
a -> m b
createCipher ByteString
k

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. AES256 -> V2Envelope -> Envelope
V2 AES256
c forall a b. (a -> b) -> a -> b
$ ByteString
-> IV AES256
-> ContentAlgorithm
-> WrappingAlgorithm
-> Description
-> V2Envelope
V2Envelope ByteString
k IV AES256
iv ContentAlgorithm
a WrappingAlgorithm
w Description
d

data Envelope
  = V1 AES.AES256 V1Envelope
  | V2 AES.AES256 V2Envelope

instance ToHeaders Envelope where
  toHeaders :: Envelope -> [Header]
toHeaders = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map (ByteString
"X-Amz-Meta-" forall a. Semigroup a => a -> a -> a
<>))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Envelope -> [Header]
toMetadata

#if MIN_VERSION_aeson(2,0,0)
instance ToJSON Envelope where
  toJSON :: Envelope -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap CI ByteString -> Key
k ByteString -> Value
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Envelope -> [Header]
toMetadata
    where
      k :: CI ByteString -> Key
k = Text -> Key
Key.fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToText a => a -> Text
toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. CI s -> s
CI.foldedCase
      v :: ByteString -> Value
v = Text -> Value
Aeson.String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToText a => a -> Text
toText
#else
instance ToJSON Envelope where
  toJSON = object . map (bimap k v) . toMetadata
    where
      k = toText . CI.foldedCase
      v = Aeson.String . toText
#endif

instance ToBody Envelope where
  toBody :: Envelope -> RequestBody
toBody = forall a. ToBody a => a -> RequestBody
toBody forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON

toMetadata :: Envelope -> [(CI ByteString, ByteString)]
toMetadata :: Envelope -> [Header]
toMetadata = \case
  V1 AES256
_ V1Envelope
x -> forall {a}. IsString a => V1Envelope -> [(a, ByteString)]
v1 V1Envelope
x
  V2 AES256
_ V2Envelope
x -> forall {a}. IsString a => V2Envelope -> [(a, ByteString)]
v2 V2Envelope
x
  where
    v1 :: V1Envelope -> [(a, ByteString)]
v1 V1Envelope {ByteString
IV AES256
Description
_v1Description :: Description
_v1IV :: IV AES256
_v1Key :: ByteString
_v1Description :: V1Envelope -> Description
_v1IV :: V1Envelope -> IV AES256
_v1Key :: V1Envelope -> ByteString
..} =
      [ (a
"X-Amz-Key", ByteString -> ByteString
b64 ByteString
_v1Key),
        (a
"X-Amz-IV", ByteString -> ByteString
b64 (forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert IV AES256
_v1IV)),
        (a
"X-Amz-Matdesc", forall a. ToByteString a => a -> ByteString
toBS Description
_v1Description)
      ]

    v2 :: V2Envelope -> [(a, ByteString)]
v2 V2Envelope {ByteString
IV AES256
Description
WrappingAlgorithm
ContentAlgorithm
_v2Description :: Description
_v2WrapAlgorithm :: WrappingAlgorithm
_v2CEKAlgorithm :: ContentAlgorithm
_v2IV :: IV AES256
_v2Key :: ByteString
_v2Description :: V2Envelope -> Description
_v2WrapAlgorithm :: V2Envelope -> WrappingAlgorithm
_v2CEKAlgorithm :: V2Envelope -> ContentAlgorithm
_v2IV :: V2Envelope -> IV AES256
_v2Key :: V2Envelope -> ByteString
..} =
      [ (a
"X-Amz-Key-V2", ByteString -> ByteString
b64 ByteString
_v2Key),
        (a
"X-Amz-IV", ByteString -> ByteString
b64 (forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert IV AES256
_v2IV)),
        (a
"X-Amz-CEK-Alg", forall a. ToByteString a => a -> ByteString
toBS ContentAlgorithm
_v2CEKAlgorithm),
        (a
"X-Amz-Wrap-Alg", forall a. ToByteString a => a -> ByteString
toBS WrappingAlgorithm
_v2WrapAlgorithm),
        (a
"X-Amz-Matdesc", forall a. ToByteString a => a -> ByteString
toBS Description
_v2Description)
      ]

    b64 :: ByteString -> ByteString
    b64 :: ByteString -> ByteString
b64 = forall a. ToByteString a => a -> ByteString
toBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base64
Base64

newEnvelope ::
  MonadResource m =>
  Key ->
  AWS.Env ->
  m Envelope
newEnvelope :: forall (m :: * -> *). MonadResource m => Key -> Env -> m Envelope
newEnvelope Key
key Env
env =
  case Key
key of
    Symmetric AES256
c Description
d -> forall (m :: * -> *).
MonadIO m =>
(ByteString -> IO ByteString) -> Description -> m Envelope
newV1 (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> ba -> ba
Cipher.ecbEncrypt AES256
c) Description
d
    Asymmetric KeyPair
p Description
d -> forall (m :: * -> *).
MonadIO m =>
(ByteString -> IO ByteString) -> Description -> m Envelope
newV1 (KeyPair -> ByteString -> IO ByteString
rsaEncrypt KeyPair
p) Description
d
    KMS Text
kid Description
d -> forall (m :: * -> *).
MonadResource m =>
Text -> Env -> Description -> m Envelope
newV2 Text
kid Env
env Description
d

decodeEnvelope ::
  MonadResource m =>
  Key ->
  AWS.Env ->
  [(CI Text, Text)] ->
  m Envelope
decodeEnvelope :: forall (m :: * -> *).
MonadResource m =>
Key -> Env -> [(CI Text, Text)] -> m Envelope
decodeEnvelope Key
key Env
env [(CI Text, Text)]
xs =
  case Key
key of
    Symmetric AES256
c Description
_ -> forall (m :: * -> *).
MonadResource m =>
(ByteString -> IO ByteString) -> [(CI Text, Text)] -> m Envelope
decodeV1 (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> ba -> ba
Cipher.ecbDecrypt AES256
c) [(CI Text, Text)]
xs
    Asymmetric KeyPair
p Description
_ -> forall (m :: * -> *).
MonadResource m =>
(ByteString -> IO ByteString) -> [(CI Text, Text)] -> m Envelope
decodeV1 (KeyPair -> ByteString -> IO ByteString
rsaDecrypt KeyPair
p) [(CI Text, Text)]
xs
    KMS Text
_ Description
d -> forall (m :: * -> *).
MonadResource m =>
Env -> [(CI Text, Text)] -> Description -> m Envelope
decodeV2 Env
env [(CI Text, Text)]
xs Description
d

fromMetadata ::
  MonadResource m =>
  Key ->
  AWS.Env ->
  HashMap Text Text ->
  m Envelope
fromMetadata :: forall (m :: * -> *).
MonadResource m =>
Key -> Env -> HashMap Text Text -> m Envelope
fromMetadata Key
key Env
env =
  forall (m :: * -> *).
MonadResource m =>
Key -> Env -> [(CI Text, Text)] -> m Envelope
decodeEnvelope Key
key Env
env
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall s. FoldCase s => s -> CI s
CI.mk)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [(k, v)]
Map.toList

aesKeySize, aesBlockSize :: Int
aesKeySize :: Int
aesKeySize = Int
32
aesBlockSize :: Int
aesBlockSize = Int
16

bodyEncrypt :: Envelope -> RequestBody -> RequestBody
bodyEncrypt :: Envelope -> RequestBody -> RequestBody
bodyEncrypt (Envelope -> (AES256, IV AES256)
getCipher -> (AES256
aes, IV AES256
iv0)) RequestBody
rqBody =
  ChunkedBody -> RequestBody
Chunked forall a b. (a -> b) -> a -> b
$
    forall a. ToChunkedBody a => a -> ChunkedBody
toChunked RequestBody
rqBody
      -- Realign body chunks for upload (AWS enforces chunk limits on all but last)
      forall a b. a -> (a -> b) -> b
& (ChunkedBody
-> ConduitM ByteString ByteString (ResourceT IO) () -> ChunkedBody
`fuseChunks` (ConduitM ByteString ByteString (ResourceT IO) ()
encryptChunks forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
Conduit.chunksOfCE (forall a b. (Integral a, Num b) => a -> b
fromIntegral ChunkSize
defaultChunkSize)))
      forall a b. a -> (a -> b) -> b
& ChunkedBody -> ChunkedBody
addPadding -- extend length for any required AES padding
  where
    encryptChunks :: ConduitM ByteString ByteString (ResourceT IO) ()
encryptChunks = forall (m :: * -> *).
Monad m =>
IV AES256
-> (IV AES256 -> ByteString -> (IV AES256, ByteString))
-> (IV AES256 -> ByteString -> ByteString)
-> ConduitT ByteString ByteString m ()
aesCbc IV AES256
iv0 IV AES256 -> ByteString -> (IV AES256, ByteString)
nextChunk IV AES256 -> ByteString -> ByteString
lastChunk

    nextChunk :: IV AES256 -> ByteString -> (IV AES256, ByteString)
nextChunk IV AES256
iv ByteString
b =
      let iv' :: IV AES256
iv' = forall a. a -> Maybe a -> a
fromMaybe IV AES256
iv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b c. (ByteArrayAccess b, BlockCipher c) => b -> Maybe (IV c)
Cipher.makeIV forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
b forall a. Num a => a -> a -> a
- Int
aesBlockSize) ByteString
r
          r :: ByteString
r = forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> IV cipher -> ba -> ba
Cipher.cbcEncrypt AES256
aes IV AES256
iv ByteString
b
       in (IV AES256
iv', ByteString
r)

    lastChunk :: IV AES256 -> ByteString -> ByteString
lastChunk IV AES256
iv = forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> IV cipher -> ba -> ba
Cipher.cbcEncrypt AES256
aes IV AES256
iv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall byteArray.
ByteArray byteArray =>
Format -> byteArray -> byteArray
Padding.pad (Int -> Format
Padding.PKCS7 Int
aesBlockSize)

    addPadding :: ChunkedBody -> ChunkedBody
addPadding c :: ChunkedBody
c@ChunkedBody {Integer
$sel:length:ChunkedBody :: ChunkedBody -> Integer
length :: Integer
length} = ChunkedBody
c {$sel:length:ChunkedBody :: Integer
length = Integer
length forall a. Num a => a -> a -> a
+ Integer
padding}
    padding :: Integer
padding = Integer
n forall a. Num a => a -> a -> a
- (RequestBody -> Integer
contentLength RequestBody
rqBody forall a. Integral a => a -> a -> a
`mod` Integer
n)
    n :: Integer
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
aesBlockSize

bodyDecrypt :: Envelope -> ResponseBody -> ResponseBody
bodyDecrypt :: Envelope -> ResponseBody -> ResponseBody
bodyDecrypt (Envelope -> (AES256, IV AES256)
getCipher -> (AES256
aes, IV AES256
iv0)) ResponseBody
rsBody =
  ResponseBody
rsBody ResponseBody
-> ConduitM ByteString ByteString (ResourceT IO) () -> ResponseBody
`fuseStream` ConduitM ByteString ByteString (ResourceT IO) ()
decryptChunks
  where
    decryptChunks :: ConduitM ByteString ByteString (ResourceT IO) ()
decryptChunks = forall (m :: * -> *).
Monad m =>
IV AES256
-> (IV AES256 -> ByteString -> (IV AES256, ByteString))
-> (IV AES256 -> ByteString -> ByteString)
-> ConduitT ByteString ByteString m ()
aesCbc IV AES256
iv0 IV AES256 -> ByteString -> (IV AES256, ByteString)
nextChunk IV AES256 -> ByteString -> ByteString
lastChunk

    nextChunk :: IV AES256 -> ByteString -> (IV AES256, ByteString)
nextChunk IV AES256
iv ByteString
b =
      let iv' :: IV AES256
iv' = forall a. a -> Maybe a -> a
fromMaybe IV AES256
iv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b c. (ByteArrayAccess b, BlockCipher c) => b -> Maybe (IV c)
Cipher.makeIV forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
b forall a. Num a => a -> a -> a
- Int
aesBlockSize) ByteString
b
          r :: ByteString
r = forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> IV cipher -> ba -> ba
Cipher.cbcDecrypt AES256
aes IV AES256
iv ByteString
b
       in (IV AES256
iv', ByteString
r)

    lastChunk :: IV AES256 -> ByteString -> ByteString
lastChunk IV AES256
iv ByteString
b =
      let r :: ByteString
r = forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> IV cipher -> ba -> ba
Cipher.cbcDecrypt AES256
aes IV AES256
iv ByteString
b
       in forall a. a -> Maybe a -> a
fromMaybe ByteString
r (forall byteArray.
ByteArray byteArray =>
Format -> byteArray -> Maybe byteArray
Padding.unpad (Int -> Format
Padding.PKCS7 Int
aesBlockSize) ByteString
r)

aesCbc ::
  Monad m =>
  IV AES256 ->
  (IV AES256 -> ByteString -> (IV AES256, ByteString)) ->
  (IV AES256 -> ByteString -> ByteString) ->
  Conduit.ConduitT ByteString ByteString m ()
aesCbc :: forall (m :: * -> *).
Monad m =>
IV AES256
-> (IV AES256 -> ByteString -> (IV AES256, ByteString))
-> (IV AES256 -> ByteString -> ByteString)
-> ConduitT ByteString ByteString m ()
aesCbc IV AES256
iv0 IV AES256 -> ByteString -> (IV AES256, ByteString)
onNextChunk IV AES256 -> ByteString -> ByteString
onLastChunk =
  forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
Conduit.chunksOfCE Int
aesBlockSize forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| IV AES256
-> Maybe ByteString -> ConduitT ByteString ByteString m ()
goChunk IV AES256
iv0 forall a. Maybe a
Nothing
  where
    goChunk :: IV AES256
-> Maybe ByteString -> ConduitT ByteString ByteString m ()
goChunk IV AES256
iv Maybe ByteString
carry =
      do
        Maybe ByteString
carry' <- forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
Conduit.await
        case Maybe ByteString
carry' of
          Maybe ByteString
Nothing -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
Conduit.yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. IV AES256 -> ByteString -> ByteString
onLastChunk IV AES256
iv) Maybe ByteString
carry
          Just ByteString
_ -> case Maybe ByteString
carry of
            Maybe ByteString
Nothing -> IV AES256
-> Maybe ByteString -> ConduitT ByteString ByteString m ()
goChunk IV AES256
iv Maybe ByteString
carry'
            Just ByteString
chunk -> do
              let (IV AES256
iv', ByteString
encrypted) = IV AES256 -> ByteString -> (IV AES256, ByteString)
onNextChunk IV AES256
iv ByteString
chunk
              forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
Conduit.yield ByteString
encrypted
              IV AES256
-> Maybe ByteString -> ConduitT ByteString ByteString m ()
goChunk IV AES256
iv' Maybe ByteString
carry'

rsaEncrypt :: KeyPair -> ByteString -> IO ByteString
rsaEncrypt :: KeyPair -> ByteString -> IO ByteString
rsaEncrypt KeyPair
k =
  forall (m :: * -> *).
MonadRandom m =>
PublicKey -> ByteString -> m (Either Error ByteString)
RSA.encrypt (KeyPair -> PublicKey
toPublicKey KeyPair
k)
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a.
MonadIO m =>
Either EncryptionError a -> m a
hoistEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Error -> EncryptionError
PubKeyFailure

rsaDecrypt :: KeyPair -> ByteString -> IO ByteString
rsaDecrypt :: KeyPair -> ByteString -> IO ByteString
rsaDecrypt KeyPair
k =
  forall (m :: * -> *).
MonadRandom m =>
PrivateKey -> ByteString -> m (Either Error ByteString)
RSA.decryptSafer (KeyPair -> PrivateKey
toPrivateKey KeyPair
k)
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a.
MonadIO m =>
Either EncryptionError a -> m a
hoistEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Error -> EncryptionError
PubKeyFailure

getCipher :: Envelope -> (AES.AES256, Cipher.IV AES.AES256)
getCipher :: Envelope -> (AES256, IV AES256)
getCipher = \case
  V1 AES256
c V1Envelope
v1 -> (AES256
c, V1Envelope -> IV AES256
_v1IV V1Envelope
v1)
  V2 AES256
c V2Envelope
v2 -> (AES256
c, V2Envelope -> IV AES256
_v2IV V2Envelope
v2)

createCipher :: (MonadIO m, ByteArray a, Cipher b) => a -> m b
createCipher :: forall (m :: * -> *) a b.
(MonadIO m, ByteArray a, Cipher b) =>
a -> m b
createCipher =
  forall r a. (CryptoError -> r) -> (a -> r) -> CryptoFailable a -> r
Crypto.Error.onCryptoFailure (forall (m :: * -> *) a. MonadIO m => EncryptionError -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoError -> EncryptionError
CipherFailure) forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
Cipher.cipherInit

createIV :: (MonadIO m, BlockCipher a) => ByteString -> m (Cipher.IV a)
createIV :: forall (m :: * -> *) a.
(MonadIO m, BlockCipher a) =>
ByteString -> m (IV a)
createIV ByteString
b = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => EncryptionError -> m a
throwIO forall a b. (a -> b) -> a -> b
$ ByteString -> EncryptionError
IVInvalid (forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert ByteString
b)) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall b c. (ByteArrayAccess b, BlockCipher c) => b -> Maybe (IV c)
Cipher.makeIV ByteString
b)

plaintext :: MonadIO m => KMS.DecryptResponse -> m ByteString
plaintext :: forall (m :: * -> *). MonadIO m => DecryptResponse -> m ByteString
plaintext DecryptResponse
rs =
  case DecryptResponse
rs forall s a. s -> Getting a s a -> a
^. Lens' DecryptResponse (Maybe ByteString)
KMS.decryptResponse_plaintext of
    Maybe ByteString
Nothing -> forall (m :: * -> *) a. MonadIO m => EncryptionError -> m a
throwIO EncryptionError
PlaintextUnavailable
    Just ByteString
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
x

(.&) :: (MonadIO m, FromText a) => [(CI Text, Text)] -> CI Text -> m a
[(CI Text, Text)]
xs .& :: forall (m :: * -> *) a.
(MonadIO m, FromText a) =>
[(CI Text, Text)] -> CI Text -> m a
.& CI Text
k =
  case CI Text
k forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(CI Text, Text)]
xs of
    Maybe Text
Nothing -> forall (m :: * -> *) a. MonadIO m => EncryptionError -> m a
throwIO (CI Text -> EncryptionError
EnvelopeMissing CI Text
k)
    Just Text
x -> forall (m :: * -> *) a.
MonadIO m =>
Either EncryptionError a -> m a
hoistEither (CI Text -> String -> EncryptionError
EnvelopeInvalid CI Text
k forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
`first` forall a. FromText a => Text -> Either String a
fromText Text
x)

hoistEither :: MonadIO m => Either EncryptionError a -> m a
hoistEither :: forall (m :: * -> *) a.
MonadIO m =>
Either EncryptionError a -> m a
hoistEither = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadIO m => EncryptionError -> m a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure

throwIO :: MonadIO m => EncryptionError -> m a
throwIO :: forall (m :: * -> *) a. MonadIO m => EncryptionError -> m a
throwIO = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
Exception.throwIO