jose 0.10 → 0.10.0.1

raw patch · 18 files changed

+261/−157 lines, 18 filesdep ~aesondep ~bytestringdep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, bytestring, mtl, tasty-hedgehog, text

API changes (from Hackage documentation)

Files

• example/JWS.hs +25/−6
• jose.cabal +44/−9
• src/Crypto/JOSE/Compact.hs +6/−1
• src/Crypto/JOSE/Error.hs +2/−2
• src/Crypto/JOSE/JWA/JWE.hs +7/−1
• src/Crypto/JOSE/JWA/JWE/Alg.hs +3/−1
• src/Crypto/JOSE/JWA/JWS.hs +3/−1
• src/Crypto/JOSE/JWE.hs +8/−6
• src/Crypto/JOSE/TH.hs +3/−3
• src/Crypto/JWT.hs +107/−89
• test/AESKW.hs +3/−1
• test/Examples.hs +5/−2
• test/JWK.hs +4/−1
• test/JWS.hs +4/−5
• test/JWT.hs +29/−26
• test/Perf.hs +1/−1
• test/Properties.hs +4/−1
• test/Types.hs +3/−1

@@ -1,5 +1,24 @@-module JWS where+-- Copyright (C) 2017-2022  Fraser Tweedale+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License. +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++module JWS+  ( doJwsSign+  , doJwsVerify+  ) where+ import System.Exit (exitFailure)  import Data.Aeson (decode, encode)@@ -16,11 +35,11 @@ -- doJwsSign :: [String] -> IO () doJwsSign [jwkFilename, payloadFilename] = do-  Just jwk <- decode <$> L.readFile jwkFilename+  Just k <- decode <$> L.readFile jwkFilename   payload <- L.readFile payloadFilename   result <- runJOSE $ do-    h <- makeJWSHeader jwk-    signJWS payload [(h :: JWSHeader Protection, jwk)]+    h <- makeJWSHeader k+    signJWS payload [(h :: JWSHeader Protection, k)]   case result of     Left e -> print (e :: Error) >> exitFailure     Right jws -> L.putStr (encode jws)@@ -35,9 +54,9 @@ -- doJwsVerify :: [String] -> IO () doJwsVerify [jwkFilename, jwsFilename] = do-  Just jwk <- decode <$> L.readFile jwkFilename+  Just k <- decode <$> L.readFile jwkFilename   Just jws <- decode <$> L.readFile jwsFilename-  result <- runJOSE $ verifyJWS' (jwk :: JWK) (jws :: GeneralJWS JWSHeader)+  result <- runJOSE $ verifyJWS' (k :: JWK) (jws :: GeneralJWS JWSHeader)   case result of     Left e -> print (e :: Error) >> exitFailure     Right s -> L.putStr s

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                jose-version:             0.10+version:             0.10.0.1 synopsis:   JSON Object Signing and Encryption (JOSE) and JSON Web Token (JWT) library description:@@ -33,7 +33,7 @@ category:            Cryptography build-type:          Simple tested-with:-  GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.4, GHC==9.4.2+  GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.7 || ==9.6.3 || == 9.8.1  flag demos   description: Build demonstration programs@@ -41,15 +41,45 @@  common common   default-language: Haskell2010-  ghc-options:    -Wall -Werror=missing-methods+  ghc-options:+    -Wall+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Werror=missing-methods+  if impl(ghc >= 8.0)+    ghc-options:+      -Wcompat+      -Wnoncanonical-monad-instances+      -Wredundant-constraints+  if impl(ghc >= 8.2)+    ghc-options:+      -fhide-source-paths+  if impl(ghc >= 8.4)+    ghc-options:+      -Wmissing-export-lists+      -Wpartial-fields+  if impl(ghc >= 8.10)+    ghc-options:+      -Wunused-packages+  if impl(ghc >= 9.0)+    ghc-options:+      -Winvalid-haddock+      -Werror=unicode-bidirectional-format-characters+  if impl(ghc >= 9.2)+    ghc-options:+      -Wimplicit-lift+      -Woperator-whitespace+      -Wredundant-bang-patterns+  if impl(ghc >= 9.4)+    ghc-options:+      -Wredundant-strictness-flags    build-depends:     base >= 4.9 && < 5-    , aeson >= 2.0.1.0 && < 3-    , bytestring >= 0.10 && < 0.12+    , bytestring >= 0.10 && < 0.13     , lens >= 4.16-    , mtl >= 2-    , text >= 1.1+    , mtl >= 2.2.1  library   import: common@@ -77,6 +107,7 @@     Crypto.JOSE.Types.URI    build-depends:+    , aeson >= 2.0.1.0 && < 3     , base64-bytestring >= 1.2.1.0 && < 1.3     , concise >= 0.1     , containers >= 0.5@@ -84,6 +115,7 @@     , memory >= 0.7     , monad-time >= 0.3     , template-haskell >= 2.11+    , text >= 1.1     , time >= 1.5     , network-uri >= 2.6     , x509 >= 1.4@@ -109,6 +141,7 @@     Types    build-depends:+    , aeson     , base64-bytestring     , containers     , cryptonite@@ -121,7 +154,7 @@     , jose      , tasty-    , tasty-hedgehog+    , tasty-hedgehog >= 1.2     , tasty-hspec >= 1.0     , hedgehog     , hspec@@ -145,5 +178,7 @@     JWS    build-depends:-    unix+    aeson+    , text+    , unix     , jose

@@ -21,7 +21,12 @@ functions for working with such data.  -}-module Crypto.JOSE.Compact where+module Crypto.JOSE.Compact+  ( FromCompact(..)+  , decodeCompact+  , ToCompact(..)+  , encodeCompact+  ) where  import Control.Monad.Except (MonadError) import qualified Data.ByteString.Lazy as L

@@ -44,8 +44,8 @@ import Data.Semigroup ((<>)) import Numeric.Natural -import Control.Monad.Except-import Control.Monad.Trans+import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)+import Control.Monad.Trans (MonadIO(liftIO), MonadTrans(lift)) import qualified Crypto.PubKey.RSA as RSA import Crypto.Error (CryptoError) import Crypto.Random (MonadRandom(..))

@@ -20,7 +20,13 @@ JSON Web Encryption data types specified under JSON Web Algorithms.  -}-module Crypto.JOSE.JWA.JWE where+module Crypto.JOSE.JWA.JWE+  ( Enc(..)+  , AlgWithParams(..)+  , AESGCMParameters(AESGCMParameters)+  , ECDHParameters(ECDHParameters)+  , PBES2Parameters(PBES2Parameters)+  ) where  import Data.Maybe (catMaybes) 

@@ -20,7 +20,9 @@ JSON Web Encryption algorithms.  -}-module Crypto.JOSE.JWA.JWE.Alg where+module Crypto.JOSE.JWA.JWE.Alg+  ( Alg(..)+  ) where  import qualified Crypto.JOSE.TH 

@@ -20,7 +20,9 @@ JSON Web Signature algorithms.  -}-module Crypto.JOSE.JWA.JWS where+module Crypto.JOSE.JWA.JWS+  ( Alg(..)+  ) where  import qualified Crypto.JOSE.TH 

@@ -262,12 +262,14 @@     CryptoFailed _ -> return $ Left AlgorithmNotImplemented -- FIXME     CryptoPassed (e :: e) -> do       iv <- getRandomBytes 16-      let Just iv' = makeIV iv-      let m' = pad (PKCS7 $ blockSize e) m-      let c = cbcEncrypt e iv' m'-      let hmacInput = B.concat [aad, iv, c, aadLen]-      let tag = B.take kLen $ BA.pack $ BA.unpack (hmac mKey hmacInput :: HMAC h)-      return $ Right (iv, c, tag)+      case makeIV iv of+        Nothing -> pure $ Left (CryptoError CryptoError_IvSizeInvalid)+        Just iv' -> do+          let m' = pad (PKCS7 $ blockSize e) m+          let c = cbcEncrypt e iv' m'+          let hmacInput = B.concat [aad, iv, c, aadLen]+          let tag = BA.convert $ BA.takeView (hmac mKey hmacInput :: HMAC h) kLen+          pure $ Right (iv, c, tag)  _gcmEnc   :: forall e m. (BlockCipher e, MonadRandom m)

@@ -44,7 +44,7 @@ conize = mkName . capitalize . sanitize  guardPred :: String -> ExpQ-guardPred s = [e| $(varE $ mkName "s") == s |]+guardPred s = [e| $(varE $ mkName "s") == $(lift s) |]  guardExp :: String -> ExpQ guardExp s = [e| pure $(conE $ conize s) |]@@ -58,7 +58,7 @@ -- | Expression for an end guard.  Arg describes type it was expecting. -- endGuardExp :: String -> ExpQ-endGuardExp s = [e| fail ("unrecognised value; expected: " ++ s) |]+endGuardExp s = [e| fail ("unrecognised value; expected: " ++ $(lift s)) |]  -- | Build a catch-all guard that fails.  String describes what is expected. --@@ -76,7 +76,7 @@   toJSONClause :: String -> ClauseQ-toJSONClause s = clause [conP (conize s) []] (normalB [| s |]) []+toJSONClause s = clause [conP (conize s) []] (normalB [| $(lift s) |]) []  toJSONFun :: [String] -> DecQ toJSONFun vs = funD 'toJSON (map toJSONClause vs)

@@ -30,81 +30,23 @@ JWTs use the JWS /compact serialisation/. See "Crypto.JOSE.Compact" for details. -@-import Crypto.JWT--mkClaims :: IO 'ClaimsSet'-mkClaims = do-  t <- 'currentTime'-  pure $ 'emptyClaimsSet'-    & 'claimIss' ?~ "alice"-    & 'claimAud' ?~ 'Audience' ["bob"]-    & 'claimIat' ?~ 'NumericDate' t--doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT')-doJwtSign jwk claims = 'runJOSE' $ do-  alg \<- 'bestJWSAlg' jwk-  'signClaims' jwk ('newJWSHeader' ((), alg)) claims--doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet')-doJwtVerify jwk jwt = 'runJOSE' $ do-  let config = 'defaultJWTValidationSettings' (== "bob")-  'verifyClaims' config jwk jwt-@--Some JWT libraries have a function that takes two strings: the-"secret" (a symmetric key) and the raw JWT.  The following function-achieves the same:--@-verify :: L.ByteString -> L.ByteString -> IO (Either 'JWTError' 'ClaimsSet')-verify k s = 'runJOSE' $ do-  let-    k' = 'fromOctets' k      -- turn raw secret into symmetric JWK-    audCheck = const True  -- should be a proper audience check-  jwt <- 'decodeCompact' s    -- decode JWT-  'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' jwt-@--For applications that use __additional claims__, define a data type that wraps-'ClaimsSet' and includes fields for the additional claims.  You will also need-to define 'FromJSON' if verifying JWTs, and 'ToJSON' if producing JWTs.  The-following example is taken from-<https://datatracker.ietf.org/doc/html/rfc7519#section-3.1 RFC 7519 §3.1>.--@-import qualified Data.Aeson.KeyMap as M--data Super = Super { jwtClaims :: 'ClaimsSet', isRoot :: Bool }--instance 'HasClaimsSet' Super where-  'claimsSet' f s = fmap (\\a' -> s { jwtClaims = a' }) (f (jwtClaims s))--instance FromJSON Super where-  parseJSON = withObject "Super" $ \\o -> Super-    \<$\> parseJSON (Object o)-    \<*\> o .: "http://example.com/is_root"--instance ToJSON Super where-  toJSON s =-    ins "http://example.com/is_root" (isRoot s) (toJSON (jwtClaims s))-    where-      ins k v (Object o) = Object $ M.insert k (toJSON v) o-      ins _ _ a = a-@--__Use 'signJWT' and 'verifyJWT' when using custom payload types__ (instead of-'signClaims' and 'verifyClaims' which are specialised to 'ClaimsSet').- -} module Crypto.JWT   (-  -- * Creating a JWT+  -- * Overview / HOWTO+  -- ** Basic usage+  -- $basic++  -- ** Supporting additional claims via subtypes #subtypes#+  -- $subtypes++  -- * API+  -- ** Creating a JWT     SignedJWT   , signClaims   , signJWT -  -- * Validating a JWT and extracting claims+  -- ** Validating a JWT and extracting claims   , defaultJWTValidationSettings   , verifyClaims   , verifyJWT@@ -115,24 +57,25 @@   , JWTValidationSettings   , HasJWTValidationSettings(..) -  -- ** Specifying the verification time+  -- *** Specifying the verification time   , WrappedUTCTime(..)   , verifyClaimsAt   , verifyJWTAt -  -- * Claims Set-  , HasClaimsSet(..)+  -- ** Claims Set   , ClaimsSet   , emptyClaimsSet+  , HasClaimsSet(..)+  , validateClaimsSet+  -- *** Unregistered claims (__deprecated__)   , addClaim   , unregisteredClaims-  , validateClaimsSet -  -- * JWT errors+  -- ** JWT errors   , JWTError(..)   , AsJWTError(..) -  -- * Miscellaneous+  -- ** Miscellaneous types   , Audience(..)   , StringOrURI   , stringOrUri@@ -140,6 +83,7 @@   , uri   , NumericDate(..) +  -- ** Re-exports   , module Crypto.JOSE    ) where@@ -174,7 +118,81 @@ import Crypto.JOSE import Crypto.JOSE.Types +{- $basic +@+import Crypto.JWT++mkClaims :: IO 'ClaimsSet'+mkClaims = do+  t <- 'currentTime'+  pure $ 'emptyClaimsSet'+    & 'claimIss' ?~ "alice"+    & 'claimAud' ?~ 'Audience' ["bob"]+    & 'claimIat' ?~ 'NumericDate' t++doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT')+doJwtSign jwk claims = 'runJOSE' $ do+  alg \<- 'bestJWSAlg' jwk+  'signClaims' jwk ('newJWSHeader' ((), alg)) claims++doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet')+doJwtVerify jwk jwt = 'runJOSE' $ do+  let config = 'defaultJWTValidationSettings' (== "bob")+  'verifyClaims' config jwk jwt+@++Some JWT libraries have a function that takes two strings: the+"secret" (a symmetric key) and the raw JWT.  The following function+achieves the same:++@+verify :: L.ByteString -> L.ByteString -> IO (Either 'JWTError' 'ClaimsSet')+verify k s = 'runJOSE' $ do+  let+    k' = 'fromOctets' k      -- turn raw secret into symmetric JWK+    audCheck = const True  -- should be a proper audience check+  jwt <- 'decodeCompact' s    -- decode JWT+  'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' jwt+@++-}++{- $subtypes++For applications that use __additional claims__, define a data type that wraps+'ClaimsSet' and includes fields for the additional claims.  You will also need+to define 'FromJSON' if verifying JWTs, and 'ToJSON' if producing JWTs.  The+following example is taken from+<https://datatracker.ietf.org/doc/html/rfc7519#section-3.1 RFC 7519 §3.1>.++@+import qualified Data.Aeson.KeyMap as M++data Super = Super { jwtClaims :: 'ClaimsSet', isRoot :: Bool }++instance 'HasClaimsSet' Super where+  'claimsSet' f s = fmap (\\a' -> s { jwtClaims = a' }) (f (jwtClaims s))++instance FromJSON Super where+  parseJSON = withObject \"Super\" $ \\o -> Super+    \<$\> parseJSON (Object o)+    \<*\> o .: "http://example.com/is_root"++instance ToJSON Super where+  toJSON s =+    ins "http://example.com/is_root" (isRoot s) (toJSON (jwtClaims s))+    where+      ins k v (Object o) = Object $ M.insert k (toJSON v) o+      ins _ _ a = a+@++__Use 'signJWT' and 'verifyJWT' when using custom payload types__ (instead of+'signClaims' and 'verifyClaims' which are specialised to 'ClaimsSet').++-}++ data JWTError   = JWSError Error   -- ^ A JOSE error occurred while processing the JWT@@ -274,12 +292,11 @@  -- | The JWT Claims Set represents a JSON object whose members are -- the registered claims defined by RFC 7519.  To construct a--- @ClaimsSet@ use 'emptyClaimsSet' then use the lenses from this--- class to set relevant claims.+-- @ClaimsSet@ use 'emptyClaimsSet' then use the lenses defined in+-- 'HasClaimsSet' to set relevant claims. -- -- For applications that use additional claims beyond those defined--- by RFC 7519, define a new data type and instance 'HasClaimsSet'.--- See the module synopsis for more details and an example.+-- by RFC 7519, define a [subtype](#g:subtypes) and instance 'HasClaimsSet'. -- data ClaimsSet = ClaimsSet   { _claimIss :: Maybe StringOrURI@@ -353,13 +370,13 @@   claimJti :: Lens' a (Maybe T.Text)   {-# INLINE claimJti #-} -  claimAud = ((.) claimsSet) claimAud-  claimExp = ((.) claimsSet) claimExp-  claimIat = ((.) claimsSet) claimIat-  claimIss = ((.) claimsSet) claimIss-  claimJti = ((.) claimsSet) claimJti-  claimNbf = ((.) claimsSet) claimNbf-  claimSub = ((.) claimsSet) claimSub+  claimAud = claimsSet . claimAud+  claimExp = claimsSet . claimExp+  claimIat = claimsSet . claimIat+  claimIss = claimsSet . claimIss+  claimJti = claimsSet . claimJti+  claimNbf = claimsSet . claimNbf+  claimSub = claimsSet . claimSub  instance HasClaimsSet ClaimsSet where   claimsSet = id@@ -392,7 +409,7 @@ unregisteredClaims f h@ClaimsSet{ _unregisteredClaims = a} =   fmap (\a' -> h { _unregisteredClaims = a' }) (f a) {-# INLINE unregisteredClaims #-}-{-# DEPRECATED unregisteredClaims "use a sub-type" #-}+{-# DEPRECATED unregisteredClaims "use a [subtype](#g:subtypes) to define additional claims" #-}  -- | Return an empty claims set. --@@ -404,7 +421,7 @@ -- addClaim :: T.Text -> Value -> ClaimsSet -> ClaimsSet addClaim k v = over unregisteredClaims (M.insert k v)-{-# DEPRECATED addClaim "'unregisteredClaims' is deprecated; use a sub-type" #-}+{-# DEPRECATED addClaim "use a [subtype](#g:subtypes) to define additional claims" #-}  registeredClaims :: S.Set T.Text registeredClaims = S.fromDistinctAscList@@ -608,11 +625,12 @@  newtype WrappedUTCTime = WrappedUTCTime { getUTCTime :: UTCTime } +#if MIN_VERSION_monad_time(0,4,0)+-- | @'monotonicTime' = pure 0@.  /jose/ doesn't use this so we fake it+#endif instance Monad m => MonadTime (ReaderT WrappedUTCTime m) where   currentTime = asks getUTCTime #if MIN_VERSION_monad_time(0,4,0)-  -- | /jose/ doesn't use this, so we fake it.-  -- @monotonicTime = pure 0@   monotonicTime = pure 0 #endif 

@@ -15,7 +15,9 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -module AESKW where+module AESKW+  ( aeskwProperties+  ) where  import qualified Data.ByteString as B import Crypto.Cipher.AES

@@ -1,7 +1,10 @@--- | Miscellaneous end-to-end examples. {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}-module Examples where++-- | Miscellaneous end-to-end examples.+module Examples+  ( spec+  ) where  import Control.Lens (_Right, (&), (?~), (.~)) import Control.Lens.Extras (is)

@@ -12,9 +12,12 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# LANGUAGE OverloadedStrings #-} -module JWK where+module JWK+  ( spec+  ) where  import Data.Monoid ((<>)) 

@@ -14,7 +14,9 @@  {-# LANGUAGE OverloadedStrings #-} -module JWS where+module JWS+  ( spec+  ) where  import Data.Maybe import Data.Monoid ((<>))@@ -169,7 +171,7 @@     let       -- protected header: {"crit":["nonce"],"nonce":"bm9uY2U"}       s = "{\"protected\":\"eyJjcml0IjpbIm5vbmNlIl0sIm5vbmNlIjoiYm05dVkyVSJ9\""-          <>",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"+          <> ",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"     in       (eitherDecode s :: Either String (Signature Protection ACMEHeader))         `shouldSatisfy` is _Right@@ -201,9 +203,6 @@   \{\"iss\":\"joe\",\r\n\   \ \"exp\":1300819380,\r\n\   \ \"http://example.com/is_root\":true}"--examplePayload :: Types.Base64Octets-examplePayload = Types.Base64Octets examplePayloadBytes   appendixA1Spec :: Spec

@@ -15,7 +15,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -module JWT where+module JWT+  ( spec+  ) where  import Data.Maybe import Data.Monoid ((<>))@@ -108,7 +110,6 @@      it "JWT round-trip (sign, serialise, decode, verify) [extended payload type]" $ do       let-        claims = emptyClaimsSet         valConf = defaultJWTValidationSettings (const True)         now = utcTime "2010-01-01 00:00:00"       k <- genJWK $ RSAGenParam 256@@ -116,8 +117,8 @@         token <- signJWT k (newJWSHeader ((), RS512)) super         token' <- decodeCompact . encodeCompact $ token         liftIO $ token' `shouldBe` token-        claims' <- runReaderT (verifyJWT valConf k token') now-        liftIO $ claims' `shouldBe` super+        claims <- runReaderT (verifyJWT valConf k token') now+        liftIO $ claims `shouldBe` super       either (error . show) return (res :: Either JWTError ()) :: IO ()      it "formats to a parsable and equal value" $ do@@ -199,62 +200,64 @@      describe "with a Not Before claim" $ do       let-        claimsSet = emptyClaimsSet & claimNbf .~ intDate "2016-07-05 17:37:22"+        claims = emptyClaimsSet & claimNbf .~ intDate "2016-07-05 17:37:22"       describe "when the current time is prior to the Not Before claim" $ do         let now = utcTime "2016-07-05 17:37:20" -- 2s before nbf         it "cannot be validated" $-          runReaderT (validateClaimsSet conf claimsSet) now+          runReaderT (validateClaimsSet conf claims) now             `shouldBe` Left JWTNotYetValid         it "cannot be validated if nonzero skew tolerance < delta" $           let conf' = set allowedSkew 1 conf-          in runReaderT (validateClaimsSet conf' claimsSet) now+          in runReaderT (validateClaimsSet conf' claims) now             `shouldBe` Left JWTNotYetValid         it "can be validated if nonzero skew tolerance = delta" $           let conf' = set allowedSkew 2 conf-          in runReaderT (validateClaimsSet conf' claimsSet) now-            `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+          in runReaderT (validateClaimsSet conf' claims) now+            `shouldBe` (Right claims :: Either JWTError ClaimsSet)         it "can be validated if nonzero skew tolerance > delta" $           let conf' = set allowedSkew 3 conf-          in runReaderT (validateClaimsSet conf' claimsSet) now-            `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+          in runReaderT (validateClaimsSet conf' claims) now+            `shouldBe` (Right claims :: Either JWTError ClaimsSet)         it "can be validated if negative skew tolerance = -delta" $           let conf' = set allowedSkew (-2) conf-          in runReaderT (validateClaimsSet conf' claimsSet) now-            `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+          in runReaderT (validateClaimsSet conf' claims) now+            `shouldBe` (Right claims :: Either JWTError ClaimsSet)        describe "when the current time is exactly equal to the Not Before claim" $         it "can be validated" $-          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2016-07-05 17:37:22")-            `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+          runReaderT (validateClaimsSet conf claims) (utcTime "2016-07-05 17:37:22")+            `shouldBe` (Right claims :: Either JWTError ClaimsSet)        describe "when the current time is after the Not Before claim" $         it "can be validated" $-          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2017-01-01 00:00:00")-            `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+          runReaderT (validateClaimsSet conf claims) (utcTime "2017-01-01 00:00:00")+            `shouldBe` (Right claims :: Either JWTError ClaimsSet)      describe "with Expiration Time and Not Before claims" $ do       let-        claimsSet = emptyClaimsSet & claimExp .~ intDate "2011-03-22 18:43:00"-                                   & claimNbf .~ intDate "2011-03-20 17:37:22"+        claims =+          emptyClaimsSet+            & claimExp .~ intDate "2011-03-22 18:43:00"+            & claimNbf .~ intDate "2011-03-20 17:37:22"       describe "when the current time is prior to the Not Before claim" $         it "cannot be validated" $-          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-18 00:00:00")+          runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-18 00:00:00")             `shouldBe` Left JWTNotYetValid       describe "when the current time is exactly equal to the Not Before claim" $         it "can be validated" $-          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-20 17:37:22")-            `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+          runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-20 17:37:22")+            `shouldBe` (Right claims :: Either JWTError ClaimsSet)       describe "when the current time is between the Not Before and Expiration Time claims" $         it "can be validated" $-          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-21 18:00:00")-            `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+          runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-21 18:00:00")+            `shouldBe` (Right claims :: Either JWTError ClaimsSet)       describe "when the current time is exactly the Expiration Time" $         it "cannot be validated" $-          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-22 18:43:00")+          runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-22 18:43:00")             `shouldBe` Left JWTExpired       describe "when the current time is after the Expiration Time claim" $         it "cannot be validated" $-          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-24 00:00:00")+          runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-24 00:00:00")             `shouldBe` Left JWTExpired      describe "with an Audience claim" $ do

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -12,7 +13,6 @@ Related: https://github.com/frasertweedale/hs-jose/pull/103  -}-module Main where  import Control.Lens ((^?), _Just) import Control.Monad.Except (ExceptT, runExceptT)

@@ -14,9 +14,12 @@  {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Properties where+module Properties+  ( properties+  ) where  import Control.Applicative (liftA2) import Control.Monad.IO.Class

@@ -14,7 +14,9 @@  {-# LANGUAGE OverloadedStrings #-} -module Types where+module Types+  ( spec+  ) where  import Data.Aeson import qualified Data.ByteString as BS