module Crypto.JOSE.JWE
(
JWEHeader(..)
, JWE(..)
) where
import Prelude hiding (mapM)
import Control.Applicative
import Data.Bifunctor (first, bimap)
import Data.Maybe (catMaybes)
import Data.Traversable (mapM)
import Data.Aeson
import Data.Aeson.Types
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Base64.URL as B64U
import qualified Data.ByteString.Base64.URL.Lazy as B64UL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.List.NonEmpty (NonEmpty(..), toList)
import Crypto.Cipher.AES
import Crypto.Cipher.Types
import Crypto.Data.Padding
import Crypto.Error
import Crypto.Hash
import Crypto.MAC.HMAC
import Crypto.PubKey.MaskGenFunction
import qualified Crypto.PubKey.RSA.OAEP as OAEP
import Crypto.JOSE.AESKW
import Crypto.JOSE.Error
import Crypto.JOSE.JWA.JWE
import Crypto.JOSE.JWK
import qualified Crypto.JOSE.Types as Types
import qualified Crypto.JOSE.Types.Internal as Types
import Crypto.JOSE.Types.Armour
critInvalidNames :: [T.Text]
critInvalidNames =
[ "alg" , "enc" , "zip" , "jku" , "jwk" , "kid"
, "x5u" , "x5c" , "x5t" , "x5t#S256" , "typ" , "cty" , "crit" ]
newtype CritParameters = CritParameters (NonEmpty (T.Text, Value))
deriving (Eq, Show)
critObjectParser :: Object -> T.Text -> Parser (T.Text, Value)
critObjectParser o s
| s `elem` critInvalidNames = fail "crit key is reserved"
| otherwise = (\v -> (s, v)) <$> o .: s
parseCrit :: Object -> NonEmpty T.Text -> Parser CritParameters
parseCrit o = fmap CritParameters . mapM (critObjectParser o)
instance FromJSON CritParameters where
parseJSON = withObject "crit" $ \o -> o .: "crit" >>= parseCrit o
instance ToJSON CritParameters where
toJSON (CritParameters m) = object $ ("crit", toJSON $ fmap fst m) : toList m
data JWEHeader = JWEHeader
{ _jweAlg :: Maybe AlgWithParams
, _jweEnc :: Maybe Enc
, _jweZip :: Maybe String
, _jweJku :: Maybe Types.URI
, _jweJwk :: Maybe JWK
, _jweKid :: Maybe String
, _jweX5u :: Maybe Types.URI
, _jweX5c :: Maybe (NonEmpty Types.Base64X509)
, _jweX5t :: Maybe Types.Base64SHA1
, _jweX5tS256 :: Maybe Types.Base64SHA256
, _jweTyp :: Maybe String
, _jweCty :: Maybe String
, _jweCrit :: Maybe CritParameters
}
deriving (Eq, Show)
newJWEHeader :: AlgWithParams -> JWEHeader
newJWEHeader alg = JWEHeader (Just alg) z z z z z z z z z z z z where z = Nothing
instance FromJSON JWEHeader where
parseJSON = withObject "JWE" $ \o -> JWEHeader
<$> parseJSON (Object o)
<*> o .: "enc"
<*> o .:? "zip"
<*> o .:? "jku"
<*> o .:? "jwk"
<*> o .:? "kid"
<*> o .:? "x5u"
<*> o .:? "x5c"
<*> o .:? "x5t"
<*> o .:? "x5t#S256"
<*> o .:? "typ"
<*> o .:? "cty"
<*> (o .:? "crit" >>= mapM (parseCrit o))
instance ToJSON JWEHeader where
toJSON (JWEHeader alg enc _zip jku jwk kid x5u x5c x5t x5tS256 typ cty crit) =
object $ catMaybes
[ fmap ("enc" .=) enc
, fmap ("zip" .=) _zip
, fmap ("jku" .=) jku
, fmap ("jwk" .=) jwk
, fmap ("kid" .=) kid
, fmap ("x5u" .=) x5u
, fmap ("x5c" .=) x5c
, fmap ("x5t" .=) x5t
, fmap ("x5t#S256" .=) x5tS256
, fmap ("typ" .=) typ
, fmap ("cty" .=) cty
]
++ Types.objectPairs (toJSON crit)
++ maybe [] (Types.objectPairs . toJSON) alg
instance FromArmour T.Text Error JWEHeader where
parseArmour s =
first (compactErr "header")
(B64UL.decode (L.fromStrict $ Types.pad $ T.encodeUtf8 s))
>>= first JSONDecodeError . eitherDecode
where
compactErr s' = CompactDecodeError . ((s' ++ " decode failed: ") ++)
instance ToArmour T.Text JWEHeader where
toArmour = T.decodeUtf8 . Types.unpad . B64U.encode . L.toStrict . encode
data JWERecipient = JWERecipient
{ _jweHeader :: Maybe JWEHeader
, _jweEncryptedKey :: Maybe Types.Base64Octets
}
instance FromJSON JWERecipient where
parseJSON = withObject "JWE Recipient" $ \o -> JWERecipient
<$> o .:? "header"
<*> o .:? "encrypted_key"
data JWE = JWE
{ _jweProtected :: Maybe (Armour T.Text JWEHeader)
, _jweUnprotected :: Maybe JWEHeader
, _jweIv :: Maybe Types.Base64Octets
, _jweAad :: Maybe Types.Base64Octets
, _jweCiphertext :: Types.Base64Octets
, _jweTag :: Maybe Types.Base64Octets
, _jweRecipients :: [JWERecipient]
}
instance FromJSON JWE where
parseJSON =
withObject "JWE JSON Serialization" $ \o -> JWE
<$> o .:? "protected"
<*> o .:? "unprotected"
<*> o .:? "iv"
<*> o .:? "aad"
<*> o .: "ciphertext"
<*> o .:? "tag"
<*> o .: "recipients"
wrap
:: MonadRandom m
=> AlgWithParams
-> KeyMaterial
-> B.ByteString
-> m (Either Error (AlgWithParams, B.ByteString))
wrap alg@RSA_OAEP (RSAKeyMaterial k) m = bimap RSAError (alg,) <$>
OAEP.encrypt (OAEP.OAEPParams SHA1 (mgf1 SHA1) Nothing) (rsaPublicKey k) m
wrap RSA_OAEP _ _ = return $ Left $ AlgorithmMismatch "Cannot use RSA_OAEP with non-RSA key"
wrap alg@RSA_OAEP_256 (RSAKeyMaterial k) m = bimap RSAError (alg,) <$>
OAEP.encrypt (OAEP.OAEPParams SHA256 (mgf1 SHA256) Nothing) (rsaPublicKey k) m
wrap RSA_OAEP_256 _ _ = return $ Left $ AlgorithmMismatch "Cannot use RSA_OAEP_256 with non-RSA key"
wrap A128KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m
= return $ (A128KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES128) m
wrap A192KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m
= return $ (A192KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES192) m
wrap A256KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m
= return $ (A256KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES256) m
wrap (A128GCMKW _) k m = wrapAESGCM A128GCMKW A128GCM k m
wrap (A192GCMKW _) k m = wrapAESGCM A192GCMKW A192GCM k m
wrap (A256GCMKW _) k m = wrapAESGCM A256GCMKW A256GCM k m
wrap _ _ _ = return $ Left AlgorithmNotImplemented
wrapAESKW
:: BlockCipher128 cipher
=> CryptoFailable cipher
-> B.ByteString
-> Either Error B.ByteString
wrapAESKW cipher m = case cipher of
CryptoFailed e -> Left (CryptoError e)
CryptoPassed cipher' -> Right (aesKeyWrap cipher' m)
wrapAESGCM
:: MonadRandom m
=> (AESGCMParameters -> AlgWithParams)
-> Enc
-> KeyMaterial
-> B.ByteString
-> m (Either Error (AlgWithParams, B.ByteString))
wrapAESGCM f enc (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m =
fmap (\(iv, tag, m') -> (f (AESGCMParameters (Types.Base64Octets iv) (Types.Base64Octets tag)), m'))
<$> encrypt enc k m ""
wrapAESGCM _ _ _ _ = return $ Left $ AlgorithmMismatch "Cannot use AESGCMKW with non-Oct key"
encrypt
:: MonadRandom m
=> Enc
-> B.ByteString
-> B.ByteString
-> B.ByteString
-> m (Either Error (B.ByteString, B.ByteString, B.ByteString))
encrypt A128CBC_HS256 k m a = case B.length k of
32 -> _cbcHmacEnc (undefined :: AES128) SHA256 k m a
_ -> return $ Left KeySizeTooSmall
encrypt A192CBC_HS384 k m a = case B.length k of
48 -> _cbcHmacEnc (undefined :: AES192) SHA384 k m a
_ -> return $ Left KeySizeTooSmall
encrypt A256CBC_HS512 k m a = case B.length k of
64 -> _cbcHmacEnc (undefined :: AES256) SHA512 k m a
_ -> return $ Left KeySizeTooSmall
encrypt A128GCM k m a = case B.length k of
16 -> _gcmEnc (undefined :: AES128) k m a
_ -> return $ Left KeySizeTooSmall
encrypt A192GCM k m a = case B.length k of
24 -> _gcmEnc (undefined :: AES192) k m a
_ -> return $ Left KeySizeTooSmall
encrypt A256GCM k m a = case B.length k of
32 -> _gcmEnc (undefined :: AES256) k m a
_ -> return $ Left KeySizeTooSmall
_cbcHmacEnc
:: forall e h m. (BlockCipher e, HashAlgorithm h, MonadRandom m)
=> e
-> h
-> B.ByteString
-> B.ByteString
-> B.ByteString
-> m (Either Error (B.ByteString, B.ByteString, B.ByteString))
_cbcHmacEnc _ _ k m aad = do
let
kLen = B.length k `div` 2
(eKey, mKey) = B.splitAt kLen k
aadLen = B.reverse $ fst $ B.unfoldrN 8 (\x -> Just (fromIntegral x, x `div` 256)) (B.length aad)
case cipherInit eKey of
CryptoFailed _ -> return $ Left AlgorithmNotImplemented
CryptoPassed (e :: e) -> do
iv <- getRandomBytes 16
let Just iv' = makeIV iv
let m' = pad (PKCS7 $ blockSize e) m
let c = cbcEncrypt e iv' m'
let hmacInput = B.concat [aad, iv, c, aadLen]
let tag = B.take kLen $ BA.pack $ BA.unpack (hmac mKey hmacInput :: HMAC h)
return $ Right (iv, c, tag)
_gcmEnc
:: forall e m. (BlockCipher e, MonadRandom m)
=> e
-> B.ByteString
-> B.ByteString
-> B.ByteString
-> m (Either Error (B.ByteString, B.ByteString, B.ByteString))
_gcmEnc _ k m aad = do
iv <- getRandomBytes 12
case cipherInit k of
CryptoFailed _ -> return $ Left AlgorithmNotImplemented
CryptoPassed (e :: e) -> case aeadInit AEAD_GCM e iv of
CryptoFailed _ -> return $ Left AlgorithmNotImplemented
CryptoPassed aead -> do
let m' = pad (PKCS7 $ blockSize e) m
let (c, aeadFinal) = aeadEncrypt (aeadAppendHeader aead aad) m'
let tag = BA.pack $ BA.unpack $ aeadFinalize aeadFinal 16
return $ Right (iv, tag, c)