jose-jwt 0.1 → 0.2

raw patch · 12 files changed

+276/−139 lines, 12 filesdep +doctestdep +errorsdep +timedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: doctest, errors, time, vector

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Jose/Internal/Base64.hs +4/−3
• Jose/Internal/Crypto.hs +44/−45
• Jose/Jwa.hs +4/−4
• Jose/Jwe.hs +25/−19
• Jose/Jwk.hs +11/−11
• Jose/Jws.hs +32/−22
• Jose/Jwt.hs +49/−19
• Jose/Types.hs +50/−9
• doctests.hs +2/−0
• jose-jwt.cabal +12/−1
• tests/Tests/JweSpec.hs +12/−4
• tests/Tests/JwsSpec.hs +31/−2

@@ -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` '='

@@ -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

@@ -21,11 +21,11 @@  -- | A subset of the signature algorithms from the -- <http://tools.ietf.org/html/draft-ietf-jose-json-web-algorithms-31#section-3 JWA Spec>.-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 -- <http://tools.ietf.org/html/draft-ietf-jose-json-web-algorithms-31#section-5 JWA Spec>.-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

@@ -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

@@ -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) 

@@ -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) 

@@ -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+

@@ -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"

@@ -0,0 +1,2 @@+import Test.DocTest+main = doctest ["-XOverloadedStrings", "Jose.Jws", "Jose.Jwe"]

@@ -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

@@ -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 

@@ -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