jose 0.8.5.1 → 0.9
raw patch · 17 files changed
+226/−161 lines, 17 filesdep −attoparsecdep −faildep −safedep ~aesondep ~basedep ~bytestring
Dependencies removed: attoparsec, fail, safe, semigroups, unordered-containers, vector
Dependency ranges changed: aeson, base, bytestring, memory, monad-time, template-haskell
Files
- jose.cabal +9/−27
- src/Crypto/JOSE.hs +19/−2
- src/Crypto/JOSE/Header.hs +24/−14
- src/Crypto/JOSE/JWA/JWE.hs +3/−4
- src/Crypto/JOSE/JWA/JWK.hs +15/−12
- src/Crypto/JOSE/JWK.hs +12/−11
- src/Crypto/JOSE/JWK/Store.hs +30/−7
- src/Crypto/JOSE/JWS.hs +3/−4
- src/Crypto/JOSE/TH.hs +1/−3
- src/Crypto/JOSE/Types/Internal.hs +17/−8
- src/Crypto/JWT.hs +45/−19
- test/AESKW.hs +2/−2
- test/JWK.hs +3/−3
- test/JWS.hs +13/−15
- test/JWT.hs +5/−15
- test/Properties.hs +7/−8
- test/Test.hs +18/−7
jose.cabal view
@@ -1,9 +1,8 @@ cabal-version: 2.2 name: jose-version: 0.8.5.1+version: 0.9 synopsis:- Javascript Object Signing and Encryption (JOSE)- and JSON Web Token (JWT) library+ JSON Object Signing and Encryption (JOSE) and JSON Web Token (JWT) library description: . An implementation of the Javascript Object Signing and Encryption@@ -29,11 +28,11 @@ test/data/fido.jwt author: Fraser Tweedale maintainer: frase@frase.id.au-copyright: Copyright (C) 2013-2018 Fraser Tweedale+copyright: Copyright (C) 2013-2021 Fraser Tweedale category: Cryptography build-type: Simple tested-with:- GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.0.1+ GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.0.1 flag demos description: Build demonstration programs@@ -44,15 +43,12 @@ ghc-options: -Wall build-depends:- base >= 4.8 && < 5- , aeson >= 0.11.1.0 && < 2.0- , bytestring == 0.10.*+ base >= 4.9 && < 5+ , aeson >= 2.0.1.0 && < 3+ , bytestring >= 0.10 && < 0.12 , lens >= 4.16 , mtl >= 2 , text >= 1.1- if impl(ghc < 8.0)- build-depends:- semigroups >= 0.15 library import: common@@ -80,26 +76,19 @@ Crypto.JOSE.Types.Orphans build-depends:- attoparsec , base64-bytestring >= 1.2.1.0 && < 1.3 , concise >= 0.1 , containers >= 0.5 , cryptonite >= 0.7 , memory >= 0.7- , monad-time >= 0.1- , template-haskell >= 2.4- , safe >= 0.3- , unordered-containers == 0.2.*+ , monad-time >= 0.3+ , template-haskell >= 2.11 , time >= 1.5 , network-uri >= 2.6 , QuickCheck >= 2.9 , quickcheck-instances , x509 >= 1.4- , vector - if impl(ghc<8)- build-depends: fail- hs-source-dirs: src source-repository head@@ -121,18 +110,11 @@ Types build-depends:- attoparsec , base64-bytestring , containers , cryptonite- , memory- , monad-time- , template-haskell- , safe- , unordered-containers , time , network-uri- , vector , x509 , pem
src/Crypto/JOSE.hs view
@@ -19,7 +19,8 @@ -} module Crypto.JOSE (- module Crypto.JOSE.Compact+ vulnerableToHashFlood+ , module Crypto.JOSE.Compact , module Crypto.JOSE.Error , module Crypto.JOSE.JWK , module Crypto.JOSE.JWK.Store@@ -31,6 +32,22 @@ import Crypto.JOSE.JWK import Crypto.JOSE.JWK.Store import Crypto.JOSE.JWS-import Crypto.JOSE.Types (base64url) +import qualified Data.Aeson.KeyMap as KeyMap+ {-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}++-- | /aeson/ supports multiple map implementations. The+-- implementation using @Data.HashMap@ from *unordered-containers*+-- is vulnerable to hash-flooding DoS attacks. If your program+-- processes JOSE objects from untrusted sources, you can check this+-- value to find out if the *aeson* build uses a secure map+-- implementation, or not.+--+vulnerableToHashFlood :: Bool+vulnerableToHashFlood = case KeyMap.coercionToMap of+ -- Don't check that the map implementation is NOT Data.HashMap, in+ -- case some other insecure implementation emerges. Instead,+ -- check that the implementation IS known to be secure.+ Just _ -> False+ Nothing -> True
src/Crypto/JOSE/Header.hs view
@@ -63,6 +63,7 @@ import qualified Control.Monad.Fail as Fail+import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty) import Data.Monoid ((<>)) import Data.Proxy (Proxy(..))@@ -70,8 +71,9 @@ import Control.Lens (Lens', Getter, review, to) import Data.Aeson (FromJSON(..), Object, Value, encode, object) import Data.Aeson.Types (Pair, Parser)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as M import qualified Data.ByteString.Lazy as L-import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Crypto.JOSE.JWA.JWS as JWA.JWS@@ -83,7 +85,7 @@ -- | A thing with parameters. ---class HasParams (a :: * -> *) where+class HasParams (a :: Type -> Type) where -- | Return a list of parameters, -- each paired with whether it is protected or not. params :: ProtectionIndicator p => a p -> [(Bool, Pair)]@@ -228,14 +230,16 @@ -> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))-headerOptional k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of- (Just _, Just _) -> fail $ "duplicate header " ++ show k+headerOptional kText hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of+ (Just _, Just _) -> fail $ "duplicate header " ++ show kText (Just v, Nothing) -> Just . HeaderParam getProtected <$> parseJSON v (Nothing, Just v) -> maybe (fail "unprotected header not supported") (\p -> Just . HeaderParam p <$> parseJSON v) getUnprotected (Nothing, Nothing) -> pure Nothing+ where+ k = Key.fromText kText -- | Parse an optional parameter that, if present, MUST be carried -- in the protected header.@@ -246,11 +250,13 @@ -> Maybe Object -> Maybe Object -> Parser (Maybe a)-headerOptionalProtected k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of- (Just _, Just _) -> fail $ "duplicate header " ++ show k- (_, Just _) -> fail $ "header must be protected: " ++ show k+headerOptionalProtected kText hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of+ (Just _, Just _) -> fail $ "duplicate header " ++ show kText+ (_, Just _) -> fail $ "header must be protected: " ++ show kText (Just v, _) -> Just <$> parseJSON v _ -> pure Nothing+ where+ k = Key.fromText kText -- | Parse a required parameter that may be carried in either -- the protected or the unprotected header.@@ -261,14 +267,16 @@ -> Maybe Object -> Maybe Object -> Parser (HeaderParam p a)-headerRequired k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of- (Just _, Just _) -> fail $ "duplicate header " ++ show k+headerRequired kText hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of+ (Just _, Just _) -> fail $ "duplicate header " ++ show kText (Just v, Nothing) -> HeaderParam getProtected <$> parseJSON v (Nothing, Just v) -> maybe (fail "unprotected header not supported") (\p -> HeaderParam p <$> parseJSON v) getUnprotected (Nothing, Nothing) -> fail $ "missing required header " ++ show k+ where+ k = Key.fromText kText -- | Parse a required parameter that MUST be carried -- in the protected header.@@ -279,11 +287,13 @@ -> Maybe Object -> Maybe Object -> Parser a-headerRequiredProtected k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of- (Just _, Just _) -> fail $ "duplicate header " ++ show k- (_, Just _) -> fail $ "header must be protected: " <> show k+headerRequiredProtected kText hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of+ (Just _, Just _) -> fail $ "duplicate header " ++ show kText+ (_, Just _) -> fail $ "header must be protected: " <> show kText (Just v, _) -> parseJSON v- _ -> fail $ "missing required protected header: " <> show k+ _ -> fail $ "missing required protected header: " <> show kText+ where+ k = Key.fromText kText critObjectParser@@ -292,7 +302,7 @@ critObjectParser reserved exts o s | s `elem` reserved = Fail.fail "crit key is reserved" | s `notElem` exts = Fail.fail "crit key is not understood"- | not (s `M.member` o) = Fail.fail "crit key is not present in headers"+ | not (Key.fromText s `M.member` o) = Fail.fail "crit key is not present in headers" | otherwise = pure s -- | Parse a "crit" header param
src/Crypto/JOSE/JWA/JWE.hs view
@@ -24,14 +24,13 @@ import Data.Maybe (catMaybes) -import qualified Data.HashMap.Strict as M- import Crypto.JOSE.JWK import Crypto.JOSE.TH import Crypto.JOSE.Types-import Crypto.JOSE.Types.Internal (objectPairs)+import Crypto.JOSE.Types.Internal (insertToObject) import Data.Aeson+import qualified Data.Aeson.KeyMap as M -- | RFC 7518 §4. Cryptographic Algorithms for Key Management@@ -84,7 +83,7 @@ algObject s = object [("alg", s)] algWithParamsObject :: ToJSON a => a -> Value -> Value-algWithParamsObject a s = object $ ("alg", s) : objectPairs (toJSON a)+algWithParamsObject a s = insertToObject "alg" s (toJSON a) instance ToJSON AlgWithParams where toJSON RSA1_5 = algObject "RSA1_5"
src/Crypto/JOSE/JWA/JWK.hs view
@@ -96,9 +96,9 @@ import qualified Crypto.PubKey.Curve25519 as Curve25519 import Crypto.Random import Data.Aeson+import qualified Data.Aeson.KeyMap as M import qualified Data.ByteArray as BA import qualified Data.ByteString as B-import qualified Data.HashMap.Strict as M import Data.List.NonEmpty (NonEmpty) import qualified Data.Text as T import Data.X509 as X509@@ -200,8 +200,9 @@ else pure Nothing) instance ToJSON RSAPrivateKeyParameters where- toJSON RSAPrivateKeyParameters {..} = object $- ("d" .= rsaD) : maybe [] (Types.objectPairs . toJSON) rsaOptionalParameters+ toJSON RSAPrivateKeyParameters {..} =+ Types.insertToObject "d" rsaD+ $ maybe (Object mempty) toJSON rsaOptionalParameters instance Arbitrary RSAPrivateKeyParameters where arbitrary = RSAPrivateKeyParameters <$> arbitrary <*> arbitrary@@ -361,11 +362,13 @@ else pure Nothing instance ToJSON RSAKeyParameters where- toJSON RSAKeyParameters {..} = object $- ("kty" .= ("RSA" :: T.Text))- : ("n" .= _rsaN)- : ("e" .= _rsaE)- : maybe [] (Types.objectPairs . toJSON) _rsaPrivateKeyParameters+ toJSON RSAKeyParameters {..} =+ Types.insertManyToObject+ [ "kty" .= ("RSA" :: T.Text)+ , "n" .= _rsaN+ , "e" .= _rsaE+ ]+ $ maybe (Object mempty) toJSON _rsaPrivateKeyParameters instance Arbitrary RSAKeyParameters where arbitrary = RSAKeyParameters@@ -602,10 +605,10 @@ Just s -> fail $ "unsupported \"kty\": " <> show s instance ToJSON KeyMaterial where- toJSON (ECKeyMaterial p) = object $ Types.objectPairs (toJSON p)- toJSON (RSAKeyMaterial p) = object $ Types.objectPairs (toJSON p)- toJSON (OctKeyMaterial p) = object $ Types.objectPairs (toJSON p)- toJSON (OKPKeyMaterial p) = object $ Types.objectPairs (toJSON p)+ toJSON (ECKeyMaterial p) = toJSON p+ toJSON (RSAKeyMaterial p) = toJSON p+ toJSON (OctKeyMaterial p) = toJSON p+ toJSON (OKPKeyMaterial p) = toJSON p -- | Keygen parameters. --
src/Crypto/JOSE/JWK.hs view
@@ -209,17 +209,18 @@ | otherwise = pure k instance ToJSON JWK where- toJSON JWK{..} = object $ catMaybes- [ fmap ("alg" .=) _jwkAlg- , fmap ("use" .=) _jwkUse- , fmap ("key_ops" .=) _jwkKeyOps- , fmap ("kid" .=) _jwkKid- , fmap ("x5u" .=) _jwkX5u- , fmap (("x5c" .=) . fmap Types.Base64X509) _jwkX5cRaw- , fmap ("x5t" .=) _jwkX5t- , fmap ("x5t#S256" .=) _jwkX5tS256- ]- ++ Types.objectPairs (toJSON _jwkMaterial)+ toJSON JWK{..} = Types.insertManyToObject kvs (toJSON _jwkMaterial)+ where+ kvs = catMaybes+ [ fmap ("alg" .=) _jwkAlg+ , fmap ("use" .=) _jwkUse+ , fmap ("key_ops" .=) _jwkKeyOps+ , fmap ("kid" .=) _jwkKid+ , fmap ("x5u" .=) _jwkX5u+ , fmap (("x5c" .=) . fmap Types.Base64X509) _jwkX5cRaw+ , fmap ("x5t" .=) _jwkX5t+ , fmap ("x5t#S256" .=) _jwkX5tS256+ ] -- | Generate a JWK. Apart from key parameters, no other parameters are set. --
src/Crypto/JOSE/JWK/Store.hs view
@@ -31,21 +31,44 @@ -- | A KeyDB is just a filesystem directory newtype KeyDB = KeyDB FilePath -instance (MonadIO m, HasKid h)- => VerificationKeyStore m (h p) ClaimsSet KeyDB where- getVerificationKeys h claims (KeyDB dir) = liftIO $+instance (MonadIO m, t'Crypto.JOSE.Header.HasKid' h)+ => VerificationKeyStore m (h p) t'Crypto.JWT.ClaimsSet' KeyDB where+ 'getVerificationKeys' h claims (KeyDB dir) = liftIO $ fmap catMaybes . traverse findKey $ catMaybes- [ preview (kid . _Just . param) h- , preview (claimIss . _Just . string) claims]+ [ preview ('Crypto.JOSE.Header.kid' . _Just . 'Crypto.JOSE.Header.param') h+ , preview ('Crypto.JWT.claimIss' . _Just . 'Crypto.JWT.string') claims] where findKey :: T.Text -> IO (Maybe JWK) findKey s = let path = dir <> "/" <> T.unpack s <> ".jwk" in handle- (\(_ :: IOException) -> pure Nothing)- (decode <$> L.readFile path)+ (\\(_ :: IOException) -> pure Nothing)+ (decode \<$> L.readFile path) @ +The next example shows how to retrieve public keys from a JWK Set+(@\/.well-known\/jwks.json@) resource. For production use, it would+be a good idea to cache the HTTP response. Thanks to Steve Mao for+this example.++@+-- | URI of JWK Set+newtype JWKsURI = JWKsURI String++instance (MonadIO m, t'Crypto.JOSE.Header.HasKid' h)+ => 'VerificationKeyStore' m (h p) t'Crypto.JWT.ClaimsSet' JWKsURI where+ 'getVerificationKeys' h claims (JWKsURI url) = liftIO $+ maybe [] (:[]) . join+ \<$> traverse findKey (preview ('Crypto.JOSE.Header.kid' . _Just . 'Crypto.JOSE.Header.param') h)+ where+ findKey :: T.Text -> IO (Maybe JWK)+ findKey kid' =+ handle (\\(_ :: SomeException) -> pure Nothing) $ do+ request \<- setRequestCheckStatus \<$> parseRequest url+ response \<- getResponseBody \<$> httpJSON request+ keys \<- getVerificationKeys h claims response+ pure $ find (\\j -> view 'Crypto.JOSE.JWK.jwkKid' j == Just kid') keys+@ -} module Crypto.JOSE.JWK.Store (
src/Crypto/JOSE/JWS.hs view
@@ -90,7 +90,6 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.List.NonEmpty (NonEmpty)-import Data.Traversable (traverse) import Data.Word (Word8) import Control.Lens hiding ((.=))@@ -98,8 +97,8 @@ import Control.Monad.Error.Lens (throwing, throwing_) import Control.Monad.Except (MonadError, unless) import Data.Aeson+import qualified Data.Aeson.KeyMap as M import qualified Data.ByteString as B-import qualified Data.HashMap.Strict as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -423,11 +422,11 @@ else (\p s -> JWS p (pure s)) <$> o .: "payload" <*> parseJSON (Object o) instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS [] p a) where- toJSON (JWS p [s]) = object $ "payload" .= p : Types.objectPairs (toJSON s)+ toJSON (JWS p [s]) = Types.insertToObject "payload" p (toJSON s) toJSON (JWS p ss) = object ["payload" .= p, "signatures" .= ss] instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS Identity p a) where- toJSON (JWS p (Identity s)) = object $ "payload" .= p : Types.objectPairs (toJSON s)+ toJSON (JWS p (Identity s)) = Types.insertToObject "payload" p (toJSON s) signingInput
src/Crypto/JOSE/TH.hs view
@@ -100,9 +100,7 @@ let derive = map mkName ["Eq", "Ord", "Show"] in-#if ! MIN_VERSION_template_haskell(2,11,0)- dataD (cxt []) (mkName s) [] (map conQ vs) derive-#elif ! MIN_VERSION_template_haskell(2,12,0)+#if ! MIN_VERSION_template_haskell(2,12,0) dataD (cxt []) (mkName s) [] Nothing (map conQ vs) (mapM conT derive) #else dataD (cxt []) (mkName s) [] Nothing (map conQ vs) [return (DerivClause Nothing (map ConT derive))]
src/Crypto/JOSE/Types/Internal.hs view
@@ -23,7 +23,8 @@ -} module Crypto.JOSE.Types.Internal (- objectPairs+ insertToObject+ , insertManyToObject , encodeB64 , parseB64 , encodeB64Url@@ -36,7 +37,6 @@ ) where import Data.Bifunctor (first)-import Data.Monoid ((<>)) import Data.Tuple (swap) import Data.Word (Word8) @@ -44,19 +44,28 @@ import Control.Lens.Cons.Extras import Crypto.Number.Basic (log2) import Data.Aeson.Types+import qualified Data.Aeson.KeyMap as M import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64.URL as B64U-import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Data.Text.Encoding as E --- | Convert a JSON object into a list of pairs or the empty list--- if the JSON value is not an object.+-- | Insert the given key and value into the given @Value@, which+-- is expected to be an @Object@. If the value is not an @Object@,+-- this is a no-op. ---objectPairs :: Value -> [Pair]-objectPairs (Object o) = M.toList o-objectPairs _ = []+insertToObject :: ToJSON v => Key -> v -> Value -> Value+insertToObject k v (Object o) = Object $ M.insert k (toJSON v) o+insertToObject _ _ v = v++-- | Insert several key/value pairs to the given @Value@, which+-- is expected to be an @Object@. If the value is not an @Object@,+-- this is a no-op.+--+insertManyToObject :: [Pair] -> Value -> Value+insertManyToObject kvs (Object o) = Object $ foldr (uncurry M.insert) o kvs+insertManyToObject _ v = v -- | Produce a parser of base64 encoded text from a bytestring parser. --
src/Crypto/JWT.hs view
@@ -115,13 +115,11 @@ import Control.Applicative import Control.Monad import Control.Monad.Time (MonadTime(..))-#if ! MIN_VERSION_monad_time(0,2,0)-import Control.Monad.Time.Instances ()-#endif import Data.Foldable (traverse_) import Data.Functor.Identity import Data.Maybe import qualified Data.String+import Data.Semigroup ((<>)) import Control.Lens ( makeClassy, makeClassyPrisms, makePrisms,@@ -132,7 +130,10 @@ import Control.Monad.Except (MonadError) import Control.Monad.Reader (ReaderT, asks, runReaderT) import Data.Aeson-import qualified Data.HashMap.Strict as M+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Map as M+import qualified Data.Set as S import qualified Data.Text as T import Data.Time (NominalDiffTime, UTCTime, addUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)@@ -251,7 +252,7 @@ , _claimNbf :: Maybe NumericDate , _claimIat :: Maybe NumericDate , _claimJti :: Maybe T.Text- , _unregisteredClaims :: M.HashMap T.Text Value+ , _unregisteredClaims :: M.Map T.Text Value } deriving (Eq, Show) @@ -320,7 +321,7 @@ fmap (\a' -> h { _claimJti = a' }) (f a) -- | Claim Names can be defined at will by those using JWTs.-unregisteredClaims :: Lens' ClaimsSet (M.HashMap T.Text Value)+unregisteredClaims :: Lens' ClaimsSet (M.Map T.Text Value) unregisteredClaims f h@ClaimsSet{ _unregisteredClaims = a} = fmap (\a' -> h { _unregisteredClaims = a' }) (f a) @@ -333,10 +334,31 @@ addClaim :: T.Text -> Value -> ClaimsSet -> ClaimsSet addClaim k v = over unregisteredClaims (M.insert k v) -filterUnregistered :: M.HashMap T.Text Value -> M.HashMap T.Text Value-filterUnregistered = M.filterWithKey (\k _ -> k `notElem` registered) where- registered = ["iss", "sub", "aud", "exp", "nbf", "iat", "jti"]+registeredClaims :: S.Set T.Text+registeredClaims = S.fromDistinctAscList+ [ "aud"+ , "exp"+ , "iat"+ , "iss"+ , "jti"+ , "nbf"+ , "sub"+ ] +filterUnregistered :: M.Map T.Text Value -> M.Map T.Text Value+filterUnregistered m =+#if MIN_VERSION_containers(0,5,8)+ m `M.withoutKeys` registeredClaims+#else+ m `M.difference` M.fromSet (const ()) registeredClaims+#endif++toKeyMap :: M.Map T.Text Value -> KeyMap.KeyMap Value+toKeyMap = KeyMap.fromMap . M.mapKeysMonotonic Key.fromText++fromKeyMap :: KeyMap.KeyMap Value -> M.Map T.Text Value+fromKeyMap = M.mapKeysMonotonic Key.toText . KeyMap.toMap+ instance FromJSON ClaimsSet where parseJSON = withObject "JWT Claims Set" (\o -> ClaimsSet <$> o .:? "iss"@@ -346,18 +368,22 @@ <*> o .:? "nbf" <*> o .:? "iat" <*> o .:? "jti"- <*> pure (filterUnregistered o))+ <*> pure (filterUnregistered . fromKeyMap $ o)+ ) instance ToJSON ClaimsSet where- toJSON (ClaimsSet iss sub aud exp' nbf iat jti o) = object $ catMaybes [- fmap ("iss" .=) iss- , fmap ("sub" .=) sub- , fmap ("aud" .=) aud- , fmap ("exp" .=) exp'- , fmap ("nbf" .=) nbf- , fmap ("iat" .=) iat- , fmap ("jti" .=) jti- ] ++ M.toList (filterUnregistered o)+ toJSON (ClaimsSet iss sub aud exp' nbf iat jti o) = Object $+ ( KeyMap.fromMap . M.fromDistinctAscList $ catMaybes+ [ fmap ("aud" .=) aud+ , fmap ("exp" .=) exp'+ , fmap ("iat" .=) iat+ , fmap ("iss" .=) iss+ , fmap ("jti" .=) jti+ , fmap ("nbf" .=) nbf+ , fmap ("sub" .=) sub+ ]+ )+ <> toKeyMap (filterUnregistered o) data JWTValidationSettings = JWTValidationSettings
test/AESKW.hs view
@@ -14,8 +14,6 @@ module AESKW where -import Control.Applicative ((<$>), pure)- import qualified Data.ByteString as B import Crypto.Cipher.AES import Crypto.Cipher.Types@@ -28,6 +26,7 @@ import Crypto.JOSE.AESKW +aeskwProperties :: TestTree aeskwProperties = testGroup "AESKW" [ testProperty "AESKW round-trip" prop_roundTrip ]@@ -52,3 +51,4 @@ 16 -> assert $ check (cipherInit kek :: CryptoFailable AES128) 24 -> assert $ check (cipherInit kek :: CryptoFailable AES192) 32 -> assert $ check (cipherInit kek :: CryptoFailable AES256)+ _ -> assert False -- can't happen
test/JWK.hs view
@@ -21,7 +21,6 @@ import Control.Lens (_Left, _Right, review, view) import Control.Lens.Extras (is) import Data.Aeson-import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Test.Hspec@@ -298,8 +297,9 @@ pk <- _A2_result pure $ view asPublicKey sk == Just pk -rfc8037_A1_jwkJson = ""- <> "{\"kty\":\"OKP\",\"crv\":\"Ed25519\","+rfc8037_A1_jwkJson :: L.ByteString+rfc8037_A1_jwkJson =+ "{\"kty\":\"OKP\",\"crv\":\"Ed25519\"," <> "\"d\":\"nWGxne_9WmC6hEr0kuwsxERJxWl7MmkZcDusAxyuf2A\"," <> "\"x\":\"11qYAYKxCrfVS_7TyWQHOg7hcvPapiMlrwIaaPcHURo\"}"
test/JWS.hs view
@@ -25,12 +25,10 @@ import Control.Monad.Except (runExceptT) import Data.Aeson import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Base64.URL as B64U import Test.Hspec import Crypto.JOSE.Compact-import Crypto.JOSE.Error (Error) import Crypto.JOSE.JWA.JWK import Crypto.JOSE.JWK import Crypto.JOSE.JWS@@ -224,11 +222,11 @@ it "computes the HMAC correctly" $ fst (withDRG drg $- runExceptT (sign alg (jwk ^. jwkMaterial) (signingInput' ^. recons)))+ runExceptT (sign alg_ (k ^. jwkMaterial) (signingInput' ^. recons))) `shouldBe` (Right mac :: Either Error BS.ByteString) it "validates the JWS correctly" $- (jws >>= verifyJWS defaultValidationSettings jwk)+ (jws >>= verifyJWS defaultValidationSettings k) `shouldBe` Right examplePayloadBytes where@@ -239,14 +237,14 @@ \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ" compactJWS = signingInput' <> ".dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk" jws = decodeCompact compactJWS :: Either Error (CompactJWS JWSHeader)- alg = JWA.JWS.HS256- h = newJWSHeader ((), alg)+ alg_ = JWA.JWS.HS256+ h = newJWSHeader ((), alg_) & typ .~ Just (HeaderParam () "JWT") mac = view recons [116, 24, 223, 180, 151, 153, 224, 37, 79, 250, 96, 125, 216, 173, 187, 186, 22, 212, 37, 77, 105, 214, 191, 240, 91, 88, 5, 88, 83, 132, 141, 121]- jwk = fromOctets+ k = fromOctets [3,35,53,75,43,15,165,188,131,126,6,101,119,123,166,143,90,179,40, 230,240,84,201,40,169,15,132,178,210,80,46,191,211,251,90,146, 210,6,71,239,150,138,180,195,119,98,61,34,61,46,33,114,5,46,79,8,@@ -277,11 +275,11 @@ appendixA2Spec :: Spec appendixA2Spec = describe "RFC 7515 A.2. Example JWS using RSASSA-PKCS-v1_5 SHA-256" $ do it "computes the signature correctly" $- fst (withDRG drg $ runExceptT (sign JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput'))+ fst (withDRG drg $ runExceptT (sign JWA.JWS.RS256 (k ^. jwkMaterial) signingInput')) `shouldBe` (Right sig :: Either Error BS.ByteString) it "validates the signature correctly" $- verify JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput' sig+ verify JWA.JWS.RS256 (k ^. jwkMaterial) signingInput' sig `shouldBe` (Right True :: Either Error Bool) it "prohibits signing with 1024-bit key" $@@ -295,7 +293,7 @@ \.\ \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\ \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ"- jwk = fromJust $ decode "\+ k = fromJust $ decode "\ \{\"kty\":\"RSA\",\ \ \"n\":\"ofgWCuLjybRlzo0tZWJjNiuSfb4p4fAkd_wWJcyQoTbji9k0l8W26mPddx\ \HmfHQp-Vaw-4qPCJrcS2mJPMEzP1Pt0Bm4d4QlL-yRT-SFd2lZS-pCgNMs\@@ -336,7 +334,7 @@ appendixA3Spec :: Spec appendixA3Spec = describe "RFC 7515 A.3. Example JWS using ECDSA P-256 SHA-256" $ it "validates the signature correctly" $- verify JWA.JWS.ES256 (jwk ^. jwkMaterial) signingInput' sig+ verify JWA.JWS.ES256 (k ^. jwkMaterial) signingInput' sig `shouldBe` (Right True :: Either Error Bool) where signingInput' = "\@@ -344,7 +342,7 @@ \.\ \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\ \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ"- jwk = fromJust $ decode "\+ k = fromJust $ decode "\ \{\"kty\":\"EC\",\ \ \"crv\":\"P-256\",\ \ \"x\":\"f83OJ3D2xF1Bg8vub9tLe1gHMzV76e8Tus9uPHvRVEU\",\@@ -504,7 +502,7 @@ cfrgSpec :: Spec cfrgSpec = describe "RFC 8037 signature/validation test vectors" $ do let- jwk = fromJust $ decode "\+ k = fromJust $ decode "\ \{\"kty\":\"OKP\",\"crv\":\"Ed25519\",\ \\"d\":\"nWGxne_9WmC6hEr0kuwsxERJxWl7MmkZcDusAxyuf2A\",\ \\"x\":\"11qYAYKxCrfVS_7TyWQHOg7hcvPapiMlrwIaaPcHURo\"}"@@ -516,10 +514,10 @@ sig = BS.pack sigOctets signingInput = "eyJhbGciOiJFZERTQSJ9.RXhhbXBsZSBvZiBFZDI1NTE5IHNpZ25pbmc" it "computes the correct signature" $- fst (withDRG drg $ runExceptT (sign JWA.JWS.EdDSA (view jwkMaterial jwk) signingInput))+ fst (withDRG drg $ runExceptT (sign JWA.JWS.EdDSA (view jwkMaterial k) signingInput)) `shouldBe` (Right sig :: Either Error BS.ByteString) it "validates signatures correctly" $- verify JWA.JWS.EdDSA (view jwkMaterial jwk) signingInput sig+ verify JWA.JWS.EdDSA (view jwkMaterial k) signingInput sig `shouldBe` (Right True :: Either Error Bool) base64urlSpec :: Spec
test/JWT.hs view
@@ -12,7 +12,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -25,16 +24,11 @@ import Control.Lens.Extras (is) import Control.Monad.Except (runExceptT) import Control.Monad.Trans (liftIO)-import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)-import Control.Monad.State (execState)-import Control.Monad.Time (MonadTime(..))+import Control.Monad.Reader (runReaderT) import Data.Aeson hiding ((.=))-import Data.Functor.Identity (runIdentity)-import Data.HashMap.Strict (insert) import qualified Data.Set as S import Data.Time import Network.URI (parseURI)-import Safe (headMay) import Test.Hspec import Crypto.JWT@@ -50,18 +44,14 @@ exampleClaimsSet = emptyClaimsSet & claimIss .~ preview stringOrUri ("joe" :: String) & claimExp .~ intDate "2011-03-22 18:43:00"- & over unregisteredClaims (insert "http://example.com/is_root" (Bool True)) & addClaim "http://example.com/is_root" (Bool True) -#if ! MIN_VERSION_monad_time(0,3,0)-instance Monad m => MonadTime (ReaderT UTCTime m) where- currentTime = ask-#endif- spec :: Spec spec = do let conf = set algorithms (S.singleton None) (defaultJWTValidationSettings (const False))+ headMay [] = Nothing+ headMay (h:_) = Just h describe "JWT Claims Set" $ do it "parses from JSON correctly" $@@ -74,9 +64,9 @@ decode claimsJSON `shouldBe` Just exampleClaimsSet it "JWT compact round-trip" $ do- jwk <- genJWK $ RSAGenParam 256+ k <- genJWK $ RSAGenParam 256 res <- runExceptT $ do- token <- signClaims jwk (newJWSHeader ((), RS512)) emptyClaimsSet+ token <- signClaims k (newJWSHeader ((), RS512)) emptyClaimsSet token' <- decodeCompact . encodeCompact $ token liftIO $ token' `shouldBe` token either (error . show) return (res :: Either JWTError ()) :: IO ()
test/Properties.hs view
@@ -16,7 +16,6 @@ module Properties where -import Control.Applicative import Control.Monad.Except (runExceptT) import Data.Aeson@@ -27,11 +26,11 @@ import Test.QuickCheck.Monadic import Test.QuickCheck.Instances () -import Crypto.JOSE.Error (Error(..)) import Crypto.JOSE.Types import Crypto.JOSE.JWK import Crypto.JOSE.JWS +properties :: TestTree properties = testGroup "Properties" [ testProperty "SizedBase64Integer round-trip" (prop_roundTrip :: SizedBase64Integer -> Property)@@ -58,9 +57,9 @@ prop_rsaSignAndVerify msg = monadicIO $ do keylen <- pick $ elements ((`div` 8) <$> [2048, 3072, 4096]) k :: JWK <- run $ genJWK (RSAGenParam keylen)- alg <- pick $ elements [RS256, RS384, RS512, PS256, PS384, PS512]- monitor (collect alg)- wp (runExceptT (signJWS msg [(newJWSHeader (Protected, alg), k)]+ alg_ <- pick $ elements [RS256, RS384, RS512, PS256, PS384, PS512]+ monitor (collect alg_)+ wp (runExceptT (signJWS msg [(newJWSHeader (Protected, alg_), k)] >>= verifyJWS defaultValidationSettings k)) (checkSignVerifyResult msg) prop_bestJWSAlg :: B.ByteString -> Property@@ -70,11 +69,11 @@ case bestJWSAlg k of Left (KeyMismatch _) -> pre False -- skip non-signing keys Left _ -> assert False- Right alg -> do- monitor (collect alg)+ Right alg_ -> do+ monitor (collect alg_) let go = do- jws <- signJWS msg [(newJWSHeader (Protected, alg), k)]+ jws <- signJWS msg [(newJWSHeader (Protected, alg_), k)] verifyJWS defaultValidationSettings k jws wp (runExceptT go) (checkSignVerifyResult msg)
test/Test.hs view
@@ -12,10 +12,12 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +import Test.Hspec import Test.Tasty import Test.Tasty.Hspec-import Test.Tasty.QuickCheck +import Crypto.JOSE (vulnerableToHashFlood)+ import AESKW import Examples import JWK@@ -32,9 +34,18 @@ unitTestsIO :: IO TestTree unitTestsIO = do- types <- testSpec "Types" Types.spec- jwk <- testSpec "JWK" JWK.spec- jws <- testSpec "JWS" JWS.spec- jwt <- testSpec "JWT" JWT.spec- examples <- testSpec "Examples" Examples.spec- return $ testGroup "Unit tests" [types, jwk, jws, jwt, examples]+ testGroup "Unit tests" <$> sequenceA specs+ where+ specs =+ [ testSpec "Types" Types.spec+ , testSpec "JWK" JWK.spec+ , testSpec "JWS" JWS.spec+ , testSpec "JWT" JWT.spec+ , testSpec "Examples" Examples.spec+ , testSpec "Security" securitySpec+ ]++securitySpec :: Spec+securitySpec = describe "security characteristics" $+ it "not vulnerable to hash-flood" $+ vulnerableToHashFlood `shouldBe` False