module Credentials.KMS
( encrypt
, decrypt
) where
import Control.Exception.Lens (catching_, handler)
import Control.Lens hiding (Context)
import Control.Monad
import Control.Monad.Catch (Exception, MonadThrow (..), catches)
import Credentials.Types
import Crypto.Cipher.AES (AES256)
import Crypto.Cipher.Types (nullIV)
import Crypto.Error
import Crypto.MAC.HMAC (HMAC (..), hmac)
import Data.ByteArray.Encoding (Base (Base16), convertToBase)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Network.AWS
import Network.AWS.Data
import Network.AWS.Error (hasCode, hasStatus)
import Network.AWS.KMS hiding (decrypt, encrypt)
import Numeric.Natural (Natural)
import qualified Crypto.Cipher.Types as Cipher
import qualified Data.ByteString as BS
import qualified Data.HashMap.Strict as Map
import qualified Data.Text as Text
import qualified Network.AWS.KMS as KMS
encrypt :: (MonadAWS m, Typeable m)
=> KeyId
-> Context
-> Name
-> ByteString
-> m Encrypted
encrypt key ctx name plaintext = do
let rq = generateDataKey (toText key)
& gdkNumberOfBytes ?~ keyLength
& gdkEncryptionContext .~ fromContext ctx
rs <- catches (send rq)
[ handler (_ServiceError . hasStatus 400 . hasCode "NotFound") $
throwM . MasterKeyMissing key . fmap toText . _serviceMessage
, handler _NotFoundException $
throwM . MasterKeyMissing key . fmap toText . _serviceMessage
]
let (dataKey, hmacKey) = splitKey (rs ^. gdkrsPlaintext)
failure = EncryptFailure ctx name
aes :: AES256 <- cryptoError failure (Cipher.cipherInit dataKey)
let !wrappedKey = rs ^. gdkrsCiphertextBlob
!ciphertext = Cipher.ctrCombine aes nullIV plaintext
!digest = hmac hmacKey ciphertext
pure $! Encrypted{..}
decrypt :: MonadAWS m
=> Context
-> Name
-> Encrypted
-> m ByteString
decrypt ctx name Encrypted{..} = do
let rq = KMS.decrypt wrappedKey
& decEncryptionContext .~ fromContext ctx
rs <- catching_ _InvalidCiphertextException (send rq) $
throwM . DecryptFailure ctx name $
if Map.null (fromContext ctx)
then "Could not decrypt stored key using KMS. \
\The credential may require an ecryption context."
else "Could not decrypt stored key using KMS. \
\The provided encryption context may not match the one \
\used when the credential was stored."
plaintextKey <-
case rs ^. drsPlaintext of
Nothing -> throwM $
DecryptFailure ctx name
"Decrypted plaintext data not available from KMS."
Just t -> pure t
let (dataKey, hmacKey) = splitKey plaintextKey
expect = hmac hmacKey (toBS ciphertext)
failure = DecryptFailure ctx name
unless (expect == digest) $
throwM (IntegrityFailure name (encodeHex expect) (encodeHex digest))
aes :: AES256 <- cryptoError failure (Cipher.cipherInit dataKey)
pure $! Cipher.ctrCombine aes nullIV (toBS ciphertext)
splitKey :: ByteString -> (ByteString, ByteString)
splitKey = BS.splitAt 32
keyLength :: Natural
keyLength = 64
cryptoError :: (MonadThrow m, Exception e)
=> (Text -> e)
-> CryptoFailable a
-> m a
cryptoError f = onCryptoFailure (throwM . f . Text.pack . show) pure
encodeHex :: HMAC a -> ByteString
encodeHex = convertToBase Base16