diff --git a/Jose/Internal/Base64.hs b/Jose/Internal/Base64.hs --- a/Jose/Internal/Base64.hs +++ b/Jose/Internal/Base64.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} {-# OPTIONS_HADDOCK hide #-} -- | JWT-style base64 encoding and decoding module Jose.Internal.Base64 where +import Control.Monad.Error import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC @@ -22,8 +23,8 @@ _ -> bs -- | Base64 decode. -decode :: ByteString -> Either JwtError ByteString -decode bs = either (Left . Base64Error) Right $ B64.decode bsPadded +decode :: MonadError JwtError m => ByteString -> m ByteString +decode bs = either (throwError . Base64Error) return $ B64.decode bsPadded where bsPadded = case B.length bs `mod` 4 of 3 -> bs `BC.snoc` '=' diff --git a/Jose/Internal/Crypto.hs b/Jose/Internal/Crypto.hs --- a/Jose/Internal/Crypto.hs +++ b/Jose/Internal/Crypto.hs @@ -30,8 +30,8 @@ import Data.Byteable (constEqBytes) import Data.ByteString (ByteString) import qualified Data.ByteString as B -import Data.Maybe (fromMaybe) import qualified Data.Serialize as Serialize +import qualified Data.Text as T import Data.Word (Word64, Word8) import Jose.Jwa @@ -41,10 +41,10 @@ hmacSign :: JwsAlg -- ^ HMAC algorithm to use -> ByteString -- ^ Key -> ByteString -- ^ The message/content - -> ByteString -- ^ HMAC output -hmacSign a k m = hmac (hashFunction hash) 64 k m - where - hash = fromMaybe (error $ "Not an HMAC alg: " ++ show a) $ lookup a hmacHashes + -> Either JwtError ByteString -- ^ HMAC output +hmacSign a k m = do + hash <- maybe (Left $ BadAlgorithm $ T.pack $ "Not an HMAC algorithm: " ++ show a) return $ lookup a hmacHashes + return $ hmac (hashFunction hash) 64 k m -- | Verify the HMAC for a given message. -- Returns false if the MAC is incorrect or the 'Alg' is not an HMAC. @@ -53,22 +53,25 @@ -> ByteString -- ^ The message/content -> ByteString -- ^ The signature to check -> Bool -- ^ Whether the signature is correct -hmacVerify a key msg sig = case lookup a hmacHashes of - Just _ -> constEqBytes (hmacSign a key msg) sig - Nothing -> False - --- TODO: Check PKCS15.sign error conditions to see whether they apply +hmacVerify a key msg sig = either (const False) (`constEqBytes` sig) $ hmacSign a key msg -- | Sign a message using an RSA private key. -rsaSign :: JwsAlg -- ^ Algorithm to use. Must be one of @RSA256@, @RSA384@ or @RSA512@. - -> RSA.PrivateKey -- ^ Private key to sign with - -> ByteString -- ^ Message to sign - -> ByteString -- ^ The signature -rsaSign a key = either (error "Signing failed") id . PKCS15.sign Nothing hash key +-- +-- The failure condition should only occur if the algorithm is not an RSA +-- algorithm, or the RSA key is too small, causing the padding of the +-- signature to fail. With real-world RSA keys this shouldn't happen in practice. +rsaSign :: Maybe RSA.Blinder -- ^ RSA blinder + -> JwsAlg -- ^ Algorithm to use. Must be one of @RSA256@, @RSA384@ or @RSA512@ + -> RSA.PrivateKey -- ^ Private key to sign with + -> ByteString -- ^ Message to sign + -> Either JwtError ByteString -- ^ The signature +rsaSign blinder a key msg = do + hash <- maybe (Left $ BadAlgorithm $ T.pack $ "Not an RSA algorithm: " ++ show a) return $ lookupRSAHash a + either (const $ Left BadCrypto) Right $ PKCS15.sign blinder hash key msg where - hash = fromMaybe (error $ "Not an RSA Algorithm " ++ show a) $ lookupRSAHash a -- | Verify the signature for a message using an RSA public key. +-- -- Returns false if the check fails or if the 'Alg' value is not -- an RSA signature algorithm. rsaVerify :: JwsAlg -- ^ The signature algorithm. Used to obtain the hash function. @@ -91,7 +94,8 @@ _ -> Nothing -- | Generates the symmetric key (content management key) and IV --- used to encrypt a message. +-- +-- Used to encrypt a message. generateCmkAndIV :: CPRG g => g -- ^ The random number generator -> Enc -- ^ The encryption algorithm to be used @@ -128,17 +132,16 @@ (Right ct, g') = encrypt pubKey content -- | Decrypts an RSA encrypted message. -rsaDecrypt :: JweAlg -- ^ The RSA algorithm to use - -> RSA.PrivateKey -- ^ The decryption key - -> B.ByteString -- ^ The encrypted content - -> Either JwtError B.ByteString -- ^ The decrypted key -rsaDecrypt a rsaKey jweKey = do - decrypt <- decryptAlg - either (\_ -> Left BadCrypto) Right $ decrypt rsaKey jweKey +rsaDecrypt :: Maybe RSA.Blinder + -> JweAlg -- ^ The RSA algorithm to use + -> RSA.PrivateKey -- ^ The decryption key + -> B.ByteString -- ^ The encrypted content + -> Either JwtError B.ByteString -- ^ The decrypted key +rsaDecrypt blinder a rsaKey jweKey = either (const $ Left BadCrypto) Right $ decrypt rsaKey jweKey where - decryptAlg = case a of - RSA1_5 -> Right $ PKCS15.decrypt Nothing - RSA_OAEP -> Right $ OAEP.decrypt Nothing oaepParams + decrypt = case a of + RSA1_5 -> PKCS15.decrypt blinder + RSA_OAEP -> OAEP.decrypt blinder oaepParams oaepParams :: OAEP.OAEPParams oaepParams = OAEP.defaultOAEPParams (hashFunction hashDescrSHA1) @@ -155,20 +158,21 @@ -> Either JwtError ByteString decryptPayload e cek iv aad sig ct = do (plaintext, tag) <- case e of - A128GCM -> decryptedGCM - A256GCM -> decryptedGCM - _ -> decryptedCBC + A128GCM -> decryptedGCM + A256GCM -> decryptedGCM + A128CBC_HS256 -> decryptedCBC 16 hashDescrSHA256 + A256CBC_HS512 -> decryptedCBC 32 hashDescrSHA512 if tag == AuthTag sig then return plaintext else Left BadSignature where decryptedGCM = Right $ AES.decryptGCM (AES.initAES cek) iv aad ct - decryptedCBC = do + decryptedCBC l h = do let (macKey, encKey) = B.splitAt (B.length cek `div` 2) cek let al = fromIntegral (B.length aad) * 8 :: Word64 plaintext <- unpad $ AES.decryptCBC (AES.initAES encKey) iv ct - let mac = authTag e macKey $ B.concat [aad, iv, ct, Serialize.encode al] + let mac = authTag l h macKey $ B.concat [aad, iv, ct, Serialize.encode al] return (plaintext, mac) -- | Encrypt a message using AES. @@ -179,24 +183,19 @@ -> ByteString -- ^ The message/JWT claims -> (ByteString, AuthTag) -- ^ Ciphertext claims and signature tag encryptPayload e cek iv aad msg = case e of - A128GCM -> aesgcm - A256GCM -> aesgcm - _ -> (aescbc, sig) + A128GCM -> aesgcm + A256GCM -> aesgcm + A128CBC_HS256 -> (aescbc, sig 16 hashDescrSHA256) + A256CBC_HS512 -> (aescbc, sig 32 hashDescrSHA512) where aesgcm = AES.encryptGCM (AES.initAES cek) iv aad msg (macKey, encKey) = B.splitAt (B.length cek `div` 2) cek aescbc = AES.encryptCBC (AES.initAES encKey) iv (pad msg) al = fromIntegral (B.length aad) * 8 :: Word64 - sig = authTag e macKey $ B.concat [aad, iv, aescbc, Serialize.encode al] + sig l h = authTag l h macKey $ B.concat [aad, iv, aescbc, Serialize.encode al] -authTag :: Enc -> ByteString -> ByteString -> AuthTag -authTag e k m = AuthTag $ B.take tLen $ hmacSign a k m - where - (tLen, a) = case e of - A128CBC_HS256 -> (16, HS256) - -- A192_CBC_HS384 -> (24, HS384) - A256CBC_HS512 -> (32, HS512) - _ -> error "TODO" +authTag :: Int -> HashDescr -> ByteString -> ByteString -> AuthTag +authTag l h k m = AuthTag $ B.take l $ hmac (hashFunction h) 64 k m unpad :: ByteString -> Either JwtError ByteString unpad bs @@ -210,7 +209,7 @@ (pt, padding) = B.splitAt (len - padLen) bs pad :: ByteString -> ByteString -pad bs = B.append bs $ padding +pad bs = B.append bs padding where lastBlockSize = B.length bs `mod` 16 padByte = fromIntegral $ 16 - lastBlockSize :: Word8 diff --git a/Jose/Jwa.hs b/Jose/Jwa.hs --- a/Jose/Jwa.hs +++ b/Jose/Jwa.hs @@ -21,11 +21,11 @@ -- | A subset of the signature algorithms from the -- . -data JwsAlg = None | HS256 | HS384 | HS512 | RS256 | RS384 | RS512 deriving (Eq, Show) +data JwsAlg = None | HS256 | HS384 | HS512 | RS256 | RS384 | RS512 deriving (Eq, Show, Read) -- | A subset of the key management algorithms from the -- . -data JweAlg = RSA1_5 | RSA_OAEP deriving (Eq, Show) +data JweAlg = RSA1_5 | RSA_OAEP deriving (Eq, Show, Read) -- TODO: AES_192_CBC_HMAC_SHA_384 ?? -- | Content encryption algorithms from the @@ -60,7 +60,7 @@ instance FromJSON JwsAlg where parseJSON = withText "JwsAlg" $ \t -> case lookup t algs of Just (Signed a) -> pure a - _ -> fail ("Unsupported JWS algorithm") + _ -> fail "Unsupported JWS algorithm" instance ToJSON JwsAlg where toJSON a = String . algName $ Signed a @@ -68,7 +68,7 @@ instance FromJSON JweAlg where parseJSON = withText "JweAlg" $ \t -> case lookup t algs of Just (Encrypted a) -> pure a - _ -> fail ("Unsupported JWE algorithm") + _ -> fail "Unsupported JWE algorithm" instance ToJSON JweAlg where toJSON a = String . algName $ Encrypted a diff --git a/Jose/Jwe.hs b/Jose/Jwe.hs --- a/Jose/Jwe.hs +++ b/Jose/Jwe.hs @@ -11,17 +11,17 @@ -- >>> import Crypto.PubKey.RSA -- >>> let ((kPub, kPr), g') = generate g 512 65537 -- >>> let (jwt, g'') = rsaEncode g' RSA_OAEP A128GCM kPub "secret claims" --- >>> rsaDecode kPr jwt +-- >>> fst $ rsaDecode g'' kPr jwt -- Right (JweHeader {jweAlg = RSA_OAEP, jweEnc = A128GCM, jweTyp = Nothing, jweCty = Nothing, jweZip = Nothing, jweKid = Nothing},"secret claims") module Jose.Jwe where +import Crypto.Cipher.Types (AuthTag(..)) +import Crypto.PubKey.RSA (PrivateKey(..), PublicKey(..), generateBlinder) +import Crypto.Random.API (CPRG) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import Crypto.Cipher.Types (AuthTag(..)) -import Crypto.PubKey.RSA (PrivateKey, PublicKey) -import Crypto.Random.API (CPRG) import Jose.Types import qualified Jose.Internal.Base64 as B64 import Jose.Internal.Crypto @@ -45,22 +45,28 @@ jwe = B.intercalate "." $ map B64.encode [hdr, jweKey, iv, ct, sig] -- | Decrypts a JWE. -rsaDecode :: PrivateKey -- ^ Decryption key - -> ByteString -- ^ The encoded JWE - -> Either JwtError Jwe -- ^ The decoded JWT, unless an error occurs -rsaDecode rsaKey jwt = do - checkDots - let components = BC.split '.' jwt - let aad = head components - [h, ek, iv, payload, sig] <- mapM B64.decode components - hdr <- case parseHeader h of - Right (JweH jweHdr) -> return jweHdr - _ -> Left BadHeader - let alg = jweAlg hdr - cek <- rsaDecrypt alg rsaKey ek - claims <- decryptPayload (jweEnc hdr) cek iv aad sig payload - return (hdr, claims) +rsaDecode :: CPRG g + => g + -> PrivateKey -- ^ Decryption key + -> ByteString -- ^ The encoded JWE + -> (Either JwtError Jwe, g) -- ^ The decoded JWT, unless an error occurs +rsaDecode rng pk jwt = (decode blinder, rng') where + (blinder, rng') = generateBlinder rng (public_n $ private_pub pk) + + decode b = do + checkDots + let components = BC.split '.' jwt + let aad = head components + [h, ek, iv, payload, sig] <- mapM B64.decode components + hdr <- case parseHeader h of + Right (JweH jweHdr) -> return jweHdr + _ -> Left BadHeader + let alg = jweAlg hdr + cek <- rsaDecrypt (Just b) alg pk ek + claims <- decryptPayload (jweEnc hdr) cek iv aad sig payload + return (hdr, claims) + checkDots = case BC.count '.' jwt of 4 -> Right () _ -> Left $ BadDots 4 diff --git a/Jose/Jwk.hs b/Jose/Jwk.hs --- a/Jose/Jwk.hs +++ b/Jose/Jwk.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, BangPatterns, DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} {-# OPTIONS_HADDOCK prune #-} module Jose.Jwk @@ -45,11 +45,11 @@ data Jwk = RsaPublicJwk RSA.PublicKey (Maybe KeyId) (Maybe KeyUse) (Maybe Alg) | RsaPrivateJwk RSA.PrivateKey (Maybe KeyId) (Maybe KeyUse) (Maybe Alg) | SymmetricJwk ByteString (Maybe KeyId) (Maybe KeyUse) (Maybe Alg) - deriving (Show) + deriving (Show, Eq) data JwkSet = JwkSet { keys :: [Jwk] - } deriving (Show, Generic) + } deriving (Show, Eq, Generic) canDecodeJws :: JwsAlg -> Jwk -> Bool canDecodeJws al jwk = case al of @@ -64,13 +64,13 @@ where mustBeRsa = not mustBeSymmetric mustBeSymmetric = case jwk of - SymmetricJwk _ _ _ _ -> True - _ -> False + SymmetricJwk {} -> True + _ -> False canDecodeJwe :: JweAlg -> Jwk -> Bool canDecodeJwe _ jwk = case jwk of -- JWE - RsaPrivateJwk _ _ _ _ -> True - _ -> False + RsaPrivateJwk {} -> True + _ -> False jwkId :: Jwk -> Maybe KeyId jwkId key = case key of @@ -92,7 +92,7 @@ filterById :: Maybe KeyId -> [Jwk] -> [Jwk] filterById keyId jwks = case keyId of - Just i -> maybe jwks (\key -> [key]) $ findKeyById jwks i + Just i -> maybe jwks (:[]) $ findKeyById jwks i Nothing -> jwks findMatchingJweKeys :: [Jwk] -> JweHeader -> [Jwk] @@ -105,7 +105,7 @@ case t of "RSA" -> pure Rsa "EC" -> pure Ec - "oct" -> pure Ec + "oct" -> pure Oct _ -> fail "unsupported key type" instance ToJSON KeyType where @@ -152,7 +152,7 @@ instance FromJSON Jwk where parseJSON o@(Object _) = do jwkData <- parseJSON o :: Parser JwkData - case (createJwk jwkData) of + case createJwk jwkData of Left err -> fail err Right jwk -> return jwk parseJSON _ = fail "Jwk must be a JSON object" @@ -264,5 +264,5 @@ ex = os2ip $ bytes eb in RSA.PublicKey (rsaSize m 1) m ex rsaSize m i = if (2 ^ (i * 8)) > m then i else rsaSize m (i+1) - os2mip mb = maybe 0 (os2ip . bytes) mb + os2mip = maybe 0 (os2ip . bytes) diff --git a/Jose/Jws.hs b/Jose/Jws.hs --- a/Jose/Jws.hs +++ b/Jose/Jws.hs @@ -6,13 +6,13 @@ -- -- >>> import Jose.Jws -- >>> import Jose.Jwa --- >>> let jwt = hmacEncode HS256 "secretmackey" "secret claims" +-- >>> let Right jwt = hmacEncode HS256 "secretmackey" "public claims" -- >>> jwt --- "eyJhbGciOiJIUzI1NiJ9.c2VjcmV0IGNsYWltcw.Hk9VZbfMHEC_IGVHnAi25HgWR91XMneqYCl7F5izQkM" +-- "eyJhbGciOiJIUzI1NiJ9.cHVibGljIGNsYWltcw.GDV7RdBrCYfCtFCZZGPy_sWry4GwfX3ckMywXUyxBsc" -- >>> hmacDecode "wrongkey" jwt -- Left BadSignature -- >>> hmacDecode "secretmackey" jwt --- Right (JwsHeader {jwsAlg = HS256, jwsTyp = Nothing, jwsCty = Nothing, jwsKid = Nothing},"secret claims") +-- Right (JwsHeader {jwsAlg = HS256, jwsTyp = Nothing, jwsCty = Nothing, jwsKid = Nothing},"public claims") module Jose.Jws ( hmacEncode @@ -22,10 +22,13 @@ ) where +import Control.Applicative +import Control.Monad (unless) +import Crypto.PubKey.RSA (PrivateKey(..), PublicKey(..), generateBlinder) +import Crypto.Random (CPRG) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import Crypto.PubKey.RSA (PrivateKey, PublicKey) import Jose.Types import qualified Jose.Internal.Base64 as B64 import Jose.Internal.Crypto @@ -34,39 +37,49 @@ -- | Create a JWS with an HMAC for validation. hmacEncode :: JwsAlg -- ^ The MAC algorithm to use -> ByteString -- ^ The MAC key - -> ByteString -- ^ The JWT claims (token content) - -> ByteString -- ^ The encoded JWS token -hmacEncode a key = encode (hmacSign a key) $ defJwsHdr {jwsAlg = a} + -> ByteString -- ^ The public JWT claims (token content) + -> Either JwtError ByteString -- ^ The encoded JWS token +hmacEncode a key payload = let st = sigTarget a payload + in (\mac -> B.concat [st, ".", B64.encode mac]) <$> hmacSign a key st -- | Decodes and validates an HMAC signed JWS. hmacDecode :: ByteString -- ^ The HMAC key -> ByteString -- ^ The JWS token to decode -> Either JwtError Jws -- ^ The decoded token if successful -hmacDecode key = decode (\alg -> hmacVerify alg key) +hmacDecode key = decode (`hmacVerify` key) -- | Creates a JWS with an RSA signature. -rsaEncode :: JwsAlg -- ^ The RSA algorithm to use - -> PrivateKey -- ^ The key to sign with - -> ByteString -- ^ The JWT claims (token content) - -> ByteString -- ^ The encoded JWS token -rsaEncode a k = encode (rsaSign a k) $ defJwsHdr {jwsAlg = a} +rsaEncode :: CPRG g + => g + -> JwsAlg -- ^ The RSA algorithm to use + -> PrivateKey -- ^ The key to sign with + -> ByteString -- ^ The public JWT claims (token content) + -> (Either JwtError ByteString, g) -- ^ The encoded JWS token +rsaEncode rng a pk payload = (sign blinder, rng') + where + (blinder, rng') = generateBlinder rng (public_n $ private_pub pk) + st = sigTarget a payload + + sign b = case rsaSign (Just b) a pk st of + Right sig -> Right $ B.concat [st, ".", B64.encode sig] + err -> err + + -- | Decode and validate an RSA signed JWS. rsaDecode :: PublicKey -- ^ The key to check the signature with -> ByteString -- ^ The encoded JWS -> Either JwtError Jws -- ^ The decoded token if successful -rsaDecode key = decode (\alg -> rsaVerify alg key) +rsaDecode key = decode (`rsaVerify` key) -encode :: (ByteString -> ByteString) -> JwsHeader -> ByteString -> ByteString -encode sign hdr payload = B.intercalate "." [hdrPayload, B64.encode $ sign hdrPayload] - where - hdrPayload = B.intercalate "." $ map B64.encode [encodeHeader hdr, payload] +sigTarget :: JwsAlg -> ByteString -> ByteString +sigTarget a payload = B.intercalate "." $ map B64.encode [encodeHeader $ defJwsHdr {jwsAlg = a}, payload] type JwsVerifier = JwsAlg -> ByteString -> ByteString -> Bool decode :: JwsVerifier -> ByteString -> Either JwtError Jws decode verify jwt = do - checkDots + unless (BC.count '.' jwt == 2) $ Left $ BadDots 2 let (hdrPayload, sig) = spanEndDot jwt sigBytes <- B64.decode sig [h, payload] <- mapM B64.decode $ BC.split '.' hdrPayload @@ -77,9 +90,6 @@ then Right (hdr, payload) else Left BadSignature where - checkDots = case (BC.count '.' jwt) of - 2 -> Right () - _ -> Left $ BadDots 2 spanEndDot bs = let (toDot, end) = BC.spanEnd (/= '.') bs in (B.init toDot, end) diff --git a/Jose/Jwt.hs b/Jose/Jwt.hs --- a/Jose/Jwt.hs +++ b/Jose/Jwt.hs @@ -1,15 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} {-# OPTIONS_HADDOCK prune #-} module Jose.Jwt ( module Jose.Types , decode + , decodeClaims ) where +import Control.Error +import Control.Monad.State.Strict import Crypto.PubKey.RSA (PrivateKey(..)) +import Crypto.Random (CPRG) +import Data.Aeson (decodeStrict') import Data.ByteString (ByteString) import Data.List (find) +import Data.Maybe (fromJust) import qualified Data.ByteString.Char8 as BC import qualified Jose.Internal.Base64 as B64 @@ -24,39 +30,63 @@ -- Locates a matching key by header @kid@ value where possible -- or by suitable key type. -- The JWK @use@ and @alg@ options are currently ignored. -decode :: JwkSet -- ^ The keys to use for decoding - -> ByteString -- ^ The encoded JWT - -> Either JwtError Jwt -- ^ The decoded JWT, if successful -decode keySet jwt = do +decode :: CPRG g + => g + -> [Jwk] -- ^ The keys to use for decoding + -> ByteString -- ^ The encoded JWT + -> (Either JwtError Jwt, g) -- ^ The decoded JWT, if successful +decode rng keySet jwt = flip runState rng $ runEitherT $ do let components = BC.split '.' jwt - hdr <- (B64.decode $ head components) >>= parseHeader - ks <- findKeys hdr (keys keySet) + when (length components < 3) $ left $ BadDots 2 + hdr <- B64.decode (head components) >>= hoistEither . parseHeader + ks <- findKeys hdr keySet -- Now we have one or more suitable keys. -- Try each in turn until successful let decodeWith = case hdr of JwsH _ -> decodeWithJws _ -> decodeWithJwe - let decodings = map decodeWith ks - maybe (Left $ KeyError "None of the keys was able to decode the JWT") id $ find (isRight) decodings + decodings <- mapM decodeWith ks + maybe (left $ KeyError "None of the keys was able to decode the JWT") (return . fromJust) $ find isJust decodings where - decodeWithJws :: Jwk -> Either JwtError Jwt - decodeWithJws k = fmap Jws $ case k of + decodeWithJws :: CPRG g => Jwk -> EitherT JwtError (State g) (Maybe Jwt) + decodeWithJws k = either (const $ return Nothing) (return . Just . Jws) $ case k of RsaPublicJwk kPub _ _ _ -> Jws.rsaDecode kPub jwt RsaPrivateJwk kPr _ _ _ -> Jws.rsaDecode (private_pub kPr) jwt SymmetricJwk kb _ _ _ -> Jws.hmacDecode kb jwt - decodeWithJwe :: Jwk -> Either JwtError Jwt - decodeWithJwe k = fmap Jwe $ case k of - RsaPrivateJwk kPr _ _ _ -> Jwe.rsaDecode kPr jwt - _ -> Left $ KeyError "Not a JWE key (shoudln't happen)" - isRight (Left _) = False - isRight (Right _) = True + decodeWithJwe :: CPRG g => Jwk -> EitherT JwtError (State g) (Maybe Jwt) + decodeWithJwe k = case k of + RsaPrivateJwk kPr _ _ _ -> do + g <- lift get + let (e, g') = Jwe.rsaDecode g kPr jwt + lift $ put g' + either (const $ return Nothing) (return . Just . Jwe) e + _ -> left $ KeyError "Not a JWE key (shouldn't happen)" -findKeys :: JwtHeader -> [Jwk] -> Either JwtError [Jwk] +-- | Convenience function to return the claims contained in a JWT. +-- This is required in situations such as client assertion authentication, +-- where the contents of the JWT may be required in order to work out +-- which key should be used to verify the token. +-- Obviously this should not be used by itself to decode a token since +-- no integrity checking is done and the contents may be forged. +decodeClaims :: ByteString + -> Either JwtError (JwtHeader, JwtClaims) +decodeClaims jwt = do + let components = BC.split '.' jwt + when (length components /= 3) $ Left $ BadDots 2 + hdr <- B64.decode (head components) >>= parseHeader + claims <- B64.decode ((head . tail) components) >>= parseClaims + return (hdr, claims) + where + parseClaims bs = maybe (Left BadClaims) Right $ decodeStrict' bs + + +findKeys :: Monad m => JwtHeader -> [Jwk] -> EitherT JwtError m [Jwk] findKeys hdr jwks = checkKeys $ case hdr of JweH h -> findMatchingJweKeys jwks h JwsH h -> findMatchingJwsKeys jwks h where -- TODO Move checks to JWK and support better error messages - checkKeys [] = Left $ KeyError "No suitable key was found to decode the JWT" + checkKeys [] = left $ KeyError "No suitable key was found to decode the JWT" checkKeys ks = return ks + diff --git a/Jose/Types.hs b/Jose/Types.hs --- a/Jose/Types.hs +++ b/Jose/Types.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings, DeriveGeneric, FlexibleContexts #-} {-# OPTIONS_HADDOCK prune #-} module Jose.Types ( Jwt (..) , Jwe , Jws + , JwtClaims (..) , JwtHeader (..) , JwsHeader (..) , JweHeader (..) , JwtError (..) + , IntDate (..) , parseHeader , encodeHeader , defJwsHdr @@ -16,14 +18,18 @@ ) where +import Control.Applicative import Data.Aeson import Data.Aeson.Types import Data.Char (toUpper, toLower) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as H -import GHC.Generics +import Data.Int (Int64) +import Data.Time.Clock.POSIX import Data.Text (Text) +import Data.Vector (singleton) +import GHC.Generics import Jose.Jwa (JweAlg(..), JwsAlg (..), Enc(..)) @@ -34,10 +40,11 @@ type Jwe = (JweHeader, ByteString) -- | A decoded JWT which can be either a JWE or a JWS. -data Jwt = Jws !Jws | Jwe !Jwe +data Jwt = Jws !Jws | Jwe !Jwe deriving (Show, Eq) data JwtHeader = JweH JweHeader | JwsH JwsHeader + deriving (Show) -- | Header content for a JWS. @@ -58,6 +65,39 @@ , jweKid :: Maybe Text } deriving (Eq, Show, Generic) +newtype IntDate = IntDate POSIXTime deriving (Show, Eq, Ord) + +instance FromJSON IntDate where + parseJSON = withScientific "IntDate" $ \n -> + pure . IntDate . fromIntegral $ (round n :: Int64) + +instance ToJSON IntDate where + toJSON (IntDate t) = Number $ fromIntegral (round t :: Int64) + +-- | Registered claims defined in section 4 of the JWT spec. +data JwtClaims = JwtClaims + { jwtIss :: !(Maybe Text) + , jwtSub :: !(Maybe Text) + , jwtAud :: !(Maybe [Text]) + , jwtExp :: !(Maybe IntDate) + , jwtNbf :: !(Maybe IntDate) + , jwtIat :: !(Maybe IntDate) + , jwtJti :: !(Maybe Text) + } deriving (Show, Generic) + +-- Deal with the case where "aud" may be a single value rather than an array +instance FromJSON JwtClaims where + parseJSON v@(Object o) = case H.lookup "aud" o of + Just (a@(String _)) -> genericParseJSON claimsOptions $ Object $ H.insert "aud" (Array $ singleton a) o + _ -> genericParseJSON claimsOptions v + parseJSON _ = fail "JwtClaims must be an object" + +instance ToJSON JwtClaims where + toJSON = genericToJSON claimsOptions + +claimsOptions :: Options +claimsOptions = prefixOptions "jwt" + defJwsHdr :: JwsHeader defJwsHdr = JwsHeader None Nothing Nothing Nothing @@ -65,14 +105,15 @@ defJweHdr = JweHeader RSA_OAEP A128GCM Nothing Nothing Nothing Nothing -- | Decoding errors. -data JwtError = --Empty - KeyError Text -- ^ No suitable key or wrong key type +data JwtError = KeyError Text -- ^ No suitable key or wrong key type + | BadAlgorithm Text -- ^ The supplied algorithm is invalid | BadDots Int -- ^ Wrong number of "." characters in the JWT | BadHeader -- ^ Header couldn't be decoded or contains bad data + | BadClaims -- ^ Claims part couldn't be decoded or contains bad data | BadSignature -- ^ Signature is invalid | BadCrypto -- ^ A cryptographic operation failed | Base64Error String -- ^ A base64 decoding error - deriving (Eq, Show) + deriving (Eq, Show) instance ToJSON JwsHeader where toJSON = genericToJSON jwsOptions @@ -88,15 +129,15 @@ instance FromJSON JwtHeader where parseJSON v@(Object o) = case H.lookup "enc" o of - Nothing -> fmap JwsH $ parseJSON v - _ -> fmap JweH $ parseJSON v + Nothing -> JwsH <$> parseJSON v + _ -> JweH <$> parseJSON v parseJSON _ = fail "JwtHeader must be an object" encodeHeader :: ToJSON a => a -> ByteString encodeHeader h = BL.toStrict $ encode h parseHeader :: ByteString -> Either JwtError JwtHeader -parseHeader hdr = maybe (Left BadHeader) Right $ decodeStrict hdr +parseHeader hdr = maybe (Left BadHeader) return $ decodeStrict hdr jwsOptions :: Options jwsOptions = prefixOptions "jws" diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,2 @@ +import Test.DocTest +main = doctest ["-XOverloadedStrings", "Jose.Jws", "Jose.Jwe"] diff --git a/jose-jwt.cabal b/jose-jwt.cabal --- a/jose-jwt.cabal +++ b/jose-jwt.cabal @@ -1,5 +1,5 @@ Name: jose-jwt -Version: 0.1 +Version: 0.2 Synopsis: JSON Object Signing and Encryption Library Homepage: http://github.com/tekul/jose-jwt Bug-Reports: http://github.com/tekul/jose-jwt/issues @@ -50,10 +50,13 @@ , crypto-random >= 0.0.7 , crypto-numbers >= 0.2 , cipher-aes >= 0.2.6 + , errors >= 1.4 , aeson >= 0.7 , text >= 0.11 + , time >= 1.4 , unordered-containers >= 0.2 , base64-bytestring >= 1 + , vector >= 0.10 Ghc-Options: -Wall Test-suite tests @@ -81,6 +84,14 @@ Ghc-options: -Wall -rtsopts -fno-warn-missing-signatures Hs-source-dirs: tests Main-is: tests.hs + +Test-suite doctests + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + Main-is: doctests.hs + Ghc-options: -XOverloadedStrings + Build-depends: base + , doctest >= 0.9.11 Benchmark bench-jwt Default-Language: Haskell2010 diff --git a/tests/Tests/JweSpec.hs b/tests/Tests/JweSpec.hs --- a/tests/Tests/JweSpec.hs +++ b/tests/Tests/JweSpec.hs @@ -4,7 +4,7 @@ module Tests.JweSpec where import Control.Applicative -import Data.Aeson (eitherDecode) +import Data.Aeson (eitherDecode, decodeStrict') import Data.Bits (xor) import Data.Either.Combinators import qualified Data.ByteString as B @@ -52,7 +52,7 @@ Jwe.rsaEncode g RSA_OAEP A256GCM a1PubKey a1Payload @?= (a1, RNG "") it "decodes the JWT to the expected header and payload" $ do - Jwe.rsaDecode a1PrivKey a1 @?= Right (a1Header, a1Payload) + (fst $ Jwe.rsaDecode blinderRNG a1PrivKey a1) @?= Right (a1Header, a1Payload) it "decodes the JWK to the correct RSA key values" $ do let Right (Jwk.RsaPrivateJwk (RSA.PrivateKey pubKey d 0 0 0 0 0) _ _ _) = eitherDecode a1jwk @@ -60,6 +60,11 @@ RSA.public_e pubKey @?= rsaExponent d @?= a1RsaPrivateExponent + it "decodes the JWT using the JWK" $ do + let Right k1 = eitherDecode a1jwk + Just k2 = decodeStrict' a2jwk + (fst $ decode blinderRNG [k2, k1] a1) @?= (Right $ Jwe (a1Header, a1Payload)) + context "when using JWE Appendix 2 data" $ do let a2Header = defJweHdr {jweAlg = RSA1_5, jweEnc = A128CBC_HS256} let aad = B64.encode . encodeHeader $ a2Header @@ -79,7 +84,7 @@ decryptPayload A128CBC_HS256 a2cek a2iv aad a2Tag a2Ciphertext @?= Right a2Payload it "decodes the JWT to the expected header and payload" $ do - Jwe.rsaDecode a2PrivKey a2 @?= Right (a2Header, a2Payload) + (fst $ Jwe.rsaDecode blinderRNG a2PrivKey a2) @?= Right (a2Header, a2Payload) context "when used with quickcheck" $ do it "padded msg is always a multiple of 16" $ property $ @@ -92,7 +97,7 @@ jweRoundTrip :: RNG -> JWEAlgs -> B.ByteString -> Bool jweRoundTrip g (JWEAlgs a e) msg = encodeDecode == Right (defJweHdr {jweAlg = a, jweEnc = e}, msg) where - encodeDecode = Jwe.rsaDecode a2PrivKey $ fst $ Jwe.rsaEncode g a e a2PubKey msg + encodeDecode = fst $ Jwe.rsaDecode blinderRNG a2PrivKey $ fst $ Jwe.rsaEncode g a e a2PubKey msg -- A decidedly non-random, random number generator which allows specific -- sequences of bytes to be supplied which match the JWE test data. @@ -113,6 +118,8 @@ cprgGenerateWithEntropy = undefined cprgFork = undefined +blinderRNG = RNG $ B.replicate 2000 255 + -------------------------------------------------------------------------------- -- JWE Appendix 1 Test Data -------------------------------------------------------------------------------- @@ -166,6 +173,7 @@ Right a2jweKey = B64.decode "UGhIOguC7IuEvf_NPVaXsGMoLOmwvc1GyqlIKOK1nN94nHPoltGRhWhw7Zx0-kFm1NJn8LE9XShH59_i8J0PH5ZZyNfGy2xGdULU7sHNF6Gp2vPLgNZ__deLKxGHZ7PcHALUzoOegEI-8E66jX2E4zyJKx-YxzZIItRzC5hlRirb6Y5Cl_p-ko3YvkkysZIFNPccxRU7qve1WYPxqbb2Yw8kZqa2rMWI5ng8OtvzlV7elprCbuPhcCdZ6XDP0_F8rkXds2vE4X-ncOIM8hAYHHi29NX0mcKiRaD0-D-ljQTP-cFPgwCp6X-nZZd9OHBv-B3oWh2TbqmScqXMR4gp_A" +a2jwk = "{\"kty\":\"RSA\", \"n\":\"sXchDaQebHnPiGvyDOAT4saGEUetSyo9MKLOoWFsueri23bOdgWp4Dy1WlUzewbgBHod5pcM9H95GQRV3JDXboIRROSBigeC5yjU1hGzHHyXss8UDprecbAYxknTcQkhslANGRUZmdTOQ5qTRsLAt6BTYuyvVRdhS8exSZEy_c4gs_7svlJJQ4H9_NxsiIoLwAEk7-Q3UXERGYw_75IDrGA84-lA_-Ct4eTlXHBIY2EaV7t7LjJaynVJCpkv4LKjTTAumiGUIuQhrNhZLuF_RJLqHpM2kgWFLU7-VTdL1VbC2tejvcI2BlMkEpk1BzBZI0KQB0GaDWFLN-aEAw3vRw\", \"e\":\"AQAB\", \"d\":\"VFCWOqXr8nvZNyaaJLXdnNPXZKRaWCjkU5Q2egQQpTBMwhprMzWzpR8Sxq1OPThh_J6MUD8Z35wky9b8eEO0pwNS8xlh1lOFRRBoNqDIKVOku0aZb-rynq8cxjDTLZQ6Fz7jSjR1Klop-YKaUHc9GsEofQqYruPhzSA-QgajZGPbE_0ZaVDJHfyd7UUBUKunFMScbflYAAOYJqVIVwaYR5zWEEceUjNnTNo_CVSj-VvXLO5VZfCUAVLgW4dpf1SrtZjSt34YLsRarSb127reG_DUwg9Ch-KyvjT1SkHgUWRVGcyly7uvVGRSDwsXypdrNinPA4jlhoNdizK2zF2CWQ\" }" a2RsaModulus = 22402924734748322419583087865046136971812964522608965289668050862528140628890468829261358173206844190609885548664216273129288787509446229835492005268681636400878070687042995563617837593077316848511917526886594334868053765054121327206058496913599608196082088434862911200952954663261204130886151917541465131565772711448256433529200865576041706962504490609565420543616528240562874975930318078653328569211055310553145904641192292907110395318778917935975962359665382660933281263049927785938817901532807037136641587608303638483543899849101763615990006657357057710971983052920787558713523025279998057051825799400286243909447 diff --git a/tests/Tests/JwsSpec.hs b/tests/Tests/JwsSpec.hs --- a/tests/Tests/JwsSpec.hs +++ b/tests/Tests/JwsSpec.hs @@ -6,6 +6,7 @@ import Test.Hspec import Test.HUnit hiding (Test) +import Data.Aeson (decodeStrict') import qualified Data.ByteString as B import qualified Data.ByteString.Char8 () import qualified Crypto.Hash.SHA256 as SHA256 @@ -13,24 +14,46 @@ import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSAPKCS15 import Crypto.PubKey.HashDescr +import Crypto.Random (CPRG(..)) import Jose.Jwt import Jose.Jwa import qualified Jose.Internal.Base64 as B64 import qualified Jose.Jws as Jws +-- Test CPRG which just produces a stream of '255' bytes +data RNG = RNG deriving (Show, Eq) + +instance CPRG RNG where + cprgCreate = undefined + cprgSetReseedThreshold = undefined + cprgGenerate n g = (B.replicate n 255, g) + cprgGenerateWithEntropy = undefined + cprgFork = undefined + {-- Examples from the JWS appendix A --} spec :: Spec spec = describe "JWS encoding and decoding" $ do context "when using JWS Appendix A.1 data" $ do + let a11decoded = Right (defJwsHdr {jwsAlg = HS256, jwsTyp = Just "JWT"}, a11Payload) it "decodes the JWT to the expected header and payload" $ - Jws.hmacDecode hmacKey a11 @?= Right (defJwsHdr {jwsAlg = HS256, jwsTyp = Just "JWT"}, a11Payload) + Jws.hmacDecode hmacKey a11 @?= a11decoded it "encodes the payload to the expected JWT" $ encode a11mac a11Header a11Payload @?= a11 + it "decodes the payload using the JWK" $ do + let Just k11 = decodeStrict' a11jwk + fst (decode RNG [k11] a11) @?= fmap Jws a11decoded + + it "encodes/decodes using HS512" $ + hmacRoundTrip HS512 a11Payload + + it "encodes/decodes using HS384" $ + hmacRoundTrip HS384 a11Payload + context "when using JWS Appendix A.2 data" $ do it "decodes the JWT to the expected header and payload" $ Jws.rsaDecode rsaPublicKey a21 @?= Right (defJwsHdr {jwsAlg = RS256}, a21Payload) @@ -52,11 +75,17 @@ where hdrPayload = B.intercalate "." $ map B64.encode [hdr, payload] -rsaRoundTrip a msg = Jws.rsaDecode rsaPublicKey (Jws.rsaEncode a rsaPrivateKey msg) @?= Right (defJwsHdr {jwsAlg = a}, msg) +hmacRoundTrip a msg = let Right encoded = Jws.hmacEncode a "asecretkey" msg + in Jws.hmacDecode "asecretkey" encoded @?= Right (defJwsHdr {jwsAlg = a}, msg) +rsaRoundTrip a msg = let Right encoded = fst $ Jws.rsaEncode RNG a rsaPrivateKey msg + in Jws.rsaDecode rsaPublicKey encoded @?= Right (defJwsHdr {jwsAlg = a}, msg) + a11Header = "{\"typ\":\"JWT\",\r\n \"alg\":\"HS256\"}" :: B.ByteString a11Payload = "{\"iss\":\"joe\",\r\n \"exp\":1300819380,\r\n \"http://example.com/is_root\":true}" a11 = "eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9.eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ.dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk" +a11jwk = "{\"kty\":\"oct\", \"k\":\"AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow\" }" + a21Header = "{\"alg\":\"RS256\"}" :: B.ByteString a21Payload = a11Payload