diff --git a/jose.cabal b/jose.cabal --- a/jose.cabal +++ b/jose.cabal @@ -1,14 +1,14 @@ name: jose -version: 0.5.0.1 +version: 0.5.0.2 synopsis: Javascript Object Signing and Encryption and JSON Web Token library description: . An implementation of the Javascript Object Signing and Encryption - (JOSE) and JSON Web Token (JWT; RFC 5717) formats. + (JOSE) and JSON Web Token (JWT; RFC 7519) formats. . - The JSON Web Signature (JWS; RFC 5715) implementation is complete. - JSON Web Encryption (JWE; RFC 5716) is not yet implemented. + The JSON Web Signature (JWS; RFC 7515) implementation is complete. + JSON Web Encryption (JWE; RFC 7516) is not yet implemented. . All JWS algorithms (HMAC, ECDSA, RSASSA-PKCS-v1_5 and RSASSA-PSS) are implemented, however, the ECDSA implementation is is diff --git a/src/Crypto/JWT.hs b/src/Crypto/JWT.hs --- a/src/Crypto/JWT.hs +++ b/src/Crypto/JWT.hs @@ -26,7 +26,7 @@ module Crypto.JWT ( JWT(..) - + , JWTCrypto(..) , JWTError(..) , AsJWTError(..) @@ -35,6 +35,8 @@ , HasJWTValidationSettings(..) , HasAllowedSkew(..) , HasAudiencePredicate(..) + , HasIssuerPredicate(..) + , HasCheckIssuedAt(..) , createJWSJWT , validateJWSJWT @@ -92,7 +94,9 @@ = JWSError Error | JWTExpired | JWTNotYetValid + | JWTNotInIssuer | JWTNotInAudience + | JWTIssuedAtFuture deriving (Eq, Show) makeClassyPrisms ''JWTError @@ -266,9 +270,11 @@ data JWTValidationSettings = JWTValidationSettings { _jwtValidationSettingsValidationSettings :: ValidationSettings , _jwtValidationSettingsAllowedSkew :: NominalDiffTime + , _jwtValidationSettingsCheckIssuedAt :: Bool -- ^ The allowed skew is interpreted in absolute terms; -- a nonzero value always expands the validity period. , _jwtValidationSettingsAudiencePredicate :: StringOrURI -> Bool + , _jwtValidationSettingsIssuerPredicate :: StringOrURI -> Bool } makeClassy ''JWTValidationSettings @@ -279,17 +285,27 @@ allowedSkew :: Lens' s NominalDiffTime class HasAudiencePredicate s where audiencePredicate :: Lens' s (StringOrURI -> Bool) +class HasIssuerPredicate s where + issuerPredicate :: Lens' s (StringOrURI -> Bool) +class HasCheckIssuedAt s where + checkIssuedAt :: Lens' s Bool instance HasJWTValidationSettings a => HasAllowedSkew a where allowedSkew = jwtValidationSettingsAllowedSkew instance HasJWTValidationSettings a => HasAudiencePredicate a where audiencePredicate = jwtValidationSettingsAudiencePredicate +instance HasJWTValidationSettings a => HasIssuerPredicate a where + issuerPredicate = jwtValidationSettingsIssuerPredicate +instance HasJWTValidationSettings a => HasCheckIssuedAt a where + checkIssuedAt = jwtValidationSettingsCheckIssuedAt defaultJWTValidationSettings :: JWTValidationSettings defaultJWTValidationSettings = JWTValidationSettings defaultValidationSettings 0 + False (const False) + (const True) -- | Validate the claims made by a ClaimsSet. Currently only inspects -- the /exp/ and /nbf/ claims. N.B. These checks are also performed by @@ -299,6 +315,8 @@ validateClaimsSet :: ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a + , HasIssuerPredicate a + , HasCheckIssuedAt a , AsJWTError e, MonadError e m ) => a @@ -307,7 +325,9 @@ validateClaimsSet conf claims = sequence_ [ validateExpClaim conf claims + , validateIatClaim conf claims , validateNbfClaim conf claims + , validateIssClaim conf claims , validateAudClaim conf claims ] @@ -323,6 +343,18 @@ else throwError (review _JWTExpired ()) validateExpClaim _ _ = pure () +validateIatClaim + :: (MonadTime m, HasCheckIssuedAt a, HasAllowedSkew a, AsJWTError e, MonadError e m) + => a + -> ClaimsSet + -> m () +validateIatClaim conf (ClaimsSet _ _ _ _ _ (Just t) _ _) = do + now <- currentTime + when (view checkIssuedAt conf) $ + when ((view _NumericDate t) > addUTCTime (abs (view allowedSkew conf)) now) $ + throwError (review _JWTIssuedAtFuture ()) +validateIatClaim _ _ = pure () + validateNbfClaim :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m) => a @@ -350,6 +382,20 @@ ) (preview (claimAud . _Just . _Audience) claims) +validateIssClaim + :: (HasIssuerPredicate s, AsJWTError e, MonadError e m) + => s + -> ClaimsSet + -> m () +validateIssClaim conf claims = + maybe + (pure ()) + (\iss -> + if view issuerPredicate conf iss + then pure () + else throwError (review _JWTNotInIssuer ()) + ) + (preview (claimIss . _Just) claims) -- | Data representing the JOSE aspects of a JWT. -- @@ -386,6 +432,8 @@ validateJWSJWT :: ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a + , HasIssuerPredicate a + , HasCheckIssuedAt a , HasValidationSettings a , AsError e, AsJWTError e, MonadError e m ) diff --git a/test/JWT.hs b/test/JWT.hs --- a/test/JWT.hs +++ b/test/JWT.hs @@ -107,6 +107,45 @@ in runReaderT (validateClaimsSet conf' exampleClaimsSet) now `shouldBe` (Right () :: Either JWTError ()) + describe "with an Issued At claim" $ do + let claimsSetWithIat = set claimIat (intDate "2011-02-22 18:43:00") emptyClaimsSet + let conf = set checkIssuedAt True defaultJWTValidationSettings + + describe "when the current time is after to the Issued At" $ do + let now = utcTime "2011-03-01 00:00:00" + it "can be validated" $ + runReaderT (validateClaimsSet conf claimsSetWithIat) now + `shouldBe` (Right () :: Either JWTError ()) + + describe "when the current time is exactly the Issued At" $ do + let now = utcTime "2011-02-22 18:43:00" + it "can be validated" $ + runReaderT (validateClaimsSet conf claimsSetWithIat) now + `shouldBe` (Right () :: Either JWTError ()) + + describe "when the current time is prior to the Issued At" $ do + let now = utcTime "2011-02-22 18:42:59" -- 1s before issued at + it "cannot be validated if nonzero skew tolerance < delta" $ + let conf' = set allowedSkew 0 conf + in runReaderT (validateClaimsSet conf' claimsSetWithIat) now + `shouldBe` Left JWTIssuedAtFuture + it "can be validated if nonzero skew tolerance < delta but validation is off" $ + let conf' = set checkIssuedAt False conf + in runReaderT (validateClaimsSet conf' claimsSetWithIat) now + `shouldBe` (Right () :: Either JWTError ()) + it "can be validated if nonzero skew tolerance = delta" $ + let conf' = set allowedSkew 1 conf + in runReaderT (validateClaimsSet conf' claimsSetWithIat) now + `shouldBe` (Right () :: Either JWTError ()) + it "can be validated if nonzero skew tolerance > delta" $ + let conf' = set allowedSkew 2 conf + in runReaderT (validateClaimsSet conf' claimsSetWithIat) now + `shouldBe` (Right () :: Either JWTError ()) + it "can be validated if negative skew tolerance = -delta" $ + let conf' = set allowedSkew (-1) conf + in runReaderT (validateClaimsSet conf' claimsSetWithIat) now + `shouldBe` (Right () :: Either JWTError ()) + describe "with a Not Before claim" $ do let claimsSet = emptyClaimsSet & claimNbf .~ intDate "2016-07-05 17:37:22" @@ -196,6 +235,25 @@ let claims = emptyClaimsSet & set claimAud (Just (Audience ["foo"])) it "serialises to string" $ encode claims `shouldBe` "{\"aud\":\"foo\"}" it "round trips" $ decode (encode claims) `shouldBe` Just claims + + describe "with an Issuer claim" $ do + let now = utcTime "2001-01-01 00:00:00" + let conf' = set issuerPredicate (== "baz") conf + describe "when issuer is nonempty, and predicate is matched" $ do + let claims = emptyClaimsSet & set claimIss (Just "baz") + it "can be validated" $ + runReaderT (validateClaimsSet conf' claims) now + `shouldBe` (Right () :: Either JWTError ()) + describe "when issuer is nonempty but predicate is not matched" $ do + let claims = emptyClaimsSet & set claimIss (Just "bar") + it "cannot be validated" $ + runReaderT (validateClaimsSet conf' claims) now + `shouldBe` Left JWTNotInIssuer + describe "when claim is empty, and default predicate is unconditionally true" $ do + let claims = emptyClaimsSet & set claimIss (Just "") + it "can be validated" $ + runReaderT (validateClaimsSet conf claims) now + `shouldBe` (Right () :: Either JWTError ()) describe "StringOrURI" $ it "parses from JSON correctly" $ do