jwt 0.7.2 → 0.11.0
raw patch · 11 files changed
Files
- CHANGELOG.md +28/−0
- README.md +2/−5
- doctests.hs +2/−1
- jwt.cabal +18/−12
- src/Web/JWT.hs +244/−99
- stack.yaml +7/−0
- tests/src/Data/ByteString/ExtendedTests.hs +1/−2
- tests/src/Data/Text/ExtendedTests.hs +1/−1
- tests/src/Web/JWTInteropTests.hs +4/−5
- tests/src/Web/JWTTests.hs +70/−45
- tests/src/Web/JWTTestsCompat.hs +6/−12
CHANGELOG.md view
@@ -1,3 +1,31 @@+# 2021-12-11 0.11.0++* Added support for RSA256 Public Key verification. This in turn means that some +methods are available to verify that are not available to encode; causing a +breaking API change. The `toVerify` method and the new `EncodeSigner` and `VerifySigner` +are the major changes.++# 2021-12-02 0.10.1++* Add support for Aeson 2.x++# 2019-03-25 0.10.0++* Add "kid" and allow specifying JOSEHeader+* Clean up docs and remove confusing JSON type alias++# 2018-01-04 0.9.0++* Switch from RSA and HsOpenSSL to x509-store+* Add Semigroup instances for GHC 8.6 compatibility++# 2018-03-21 0.8.0++* Support RS256 algorithm+* Add Monoid for ClaimsMap++Thanks to Patrick Brisbin and Brian McKenna for adding support for RS256.+ # 2016-06-02 0.7.2 * Add missing Data.ByteString.ExtendedTests (Thanks to nomeata for reporting
README.md view
@@ -10,10 +10,7 @@ > of a JSON Web Encryption (JWE) structure, enabling the claims to be digitally signed or MACed > and/or encrypted. -See the [Web.JWT module](http://hackage.haskell.org/package/jwt/docs/Web-JWT.html) documentation to get started.-+See the [Web.JWT module](http://hackage.haskell.org/package/jwt/docs/Web-JWT.html) documentation to get started. [](https://travis-ci.org/juretta/haskell-jwt)--+Status](https://img.shields.io/bitbucket/pipelines/puffnfresh/haskell-jwt/master)](https://bitbucket.org/puffnfresh/haskell-jwt/addon/pipelines/home)
doctests.hs view
@@ -1,3 +1,4 @@ import Test.DocTest -main = doctest ["-isrc", "src/Web"]+main :: IO ()+main = doctest ["-isrc", "src"]
jwt.cabal view
@@ -2,14 +2,14 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: jwt-version: 0.7.2+version: 0.11.0 synopsis: JSON Web Token (JWT) decoding and encoding license: MIT license-file: LICENSE-author: Stefan Saasen-maintainer: stefan@saasen.me-homepage: https://bitbucket.org/ssaasen/haskell-jwt-bug-reports: https://bitbucket.org/ssaasen/haskell-jwt/issues+author: Brian McKenna+maintainer: brian@brianmckenna.org+homepage: https://bitbucket.org/puffnfresh/haskell-jwt+bug-reports: https://bitbucket.org/puffnfresh/haskell-jwt/issues category: Web build-type: Simple cabal-version: >=1.16@@ -22,17 +22,19 @@ extra-source-files: CHANGELOG.md README.md+ stack.yaml tests/jwt.secret.1 source-repository head type: git- location: https://ssaasen@bitbucket.org/ssaasen/haskell-jwt.git+ location: https://bitbucket.org/puffnfresh/haskell-jwt.git library exposed-modules: Web.JWT other-modules: Data.Text.Extended, Data.ByteString.Extended- build-depends: base >= 4.6 && < 5+ build-depends: base >= 4.8 && < 5 , cryptonite >= 0.6+ , cryptostore >= 0.2 , memory >= 0.8 , bytestring >= 0.10 , text >= 0.11@@ -40,12 +42,13 @@ , containers >= 0.5 , unordered-containers >= 0.2 , scientific >= 0.2- , data-default >= 0.5 , http-types >= 0.8 , time >= 1.1 , vector >= 0.7.1 , semigroups >= 0.15.4 , network-uri+ , x509+ , x509-store hs-source-dirs: src default-language: Haskell2010@@ -66,9 +69,10 @@ , Web.JWTTestsCompat , Data.Text.Extended , Data.Text.ExtendedTests+ , Data.ByteString.Extended , Data.ByteString.ExtendedTests hs-source-dirs: tests/src, src- build-depends: base < 5 && >= 4.4+ build-depends: base < 5 && >= 4.8 , tasty >= 0.7 , tasty-th >= 0.1 , tasty-hunit >= 0.4@@ -78,6 +82,7 @@ , HUnit , QuickCheck >= 2.4.0.1 , cryptonite+ , cryptostore , memory , bytestring >= 0.10 , text >= 0.11@@ -85,12 +90,13 @@ , scientific >= 0.2 , containers , unordered-containers- , data-default , http-types , time >= 1.1 , vector >= 0.7.1 , semigroups >= 0.15.4 , network-uri+ , x509+ , x509-store cpp-options: -DTEST @@ -99,6 +105,6 @@ type: exitcode-stdio-1.0 main-is: doctests.hs ghc-options: -threaded- build-depends: base < 5 && >= 4.4+ build-depends: base < 5 && >= 4.8 , jwt- , doctest >= 0.9.11+ , doctest >= 0.20
src/Web/JWT.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -13,11 +14,11 @@ Stability: experimental This implementation of JWT is based on <https://tools.ietf.org/html/rfc7519>-but currently only implements the minimum required to work with the Atlassian Connect framework.+but currently only implements the minimum required to work with the Atlassian Connect framework and GitHub App Known limitations: - * Only HMAC SHA-256 algorithm is currently a supported signature algorithm+ * Only HMAC SHA-256 and RSA SHA-256 algorithms are currently a supported signature algorithm * There is currently no verification of time related information ('exp', 'nbf', 'iat').@@ -39,8 +40,10 @@ -- * Utility functions -- ** Common , tokenIssuer- , secret- , binarySecret+ , hmacSecret+ , readRsaSecret+ , readRsaPublicKey+ , toVerify -- ** JWT structure , claims , header@@ -52,30 +55,29 @@ , stringOrURI , stringOrURIToText , secondsSinceEpoch- -- ** JWT header- , typ- , cty- , alg -- * Types , UnverifiedJWT , VerifiedJWT , Signature- , Secret+ , VerifySigner(..)+ , EncodeSigner(..) , JWT- , JSON , Algorithm(..) , JWTClaimsSet(..)- , ClaimsMap+ , ClaimsMap(..) , IntDate , NumericDate , StringOrURI , JWTHeader- , JOSEHeader+ , JOSEHeader(..) - , module Data.Default+ -- * Deprecated+ , rsaKeySecret ) where +import Data.Bifunctor (first)+import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as BL (fromStrict, toStrict) import qualified Data.ByteString.Extended as BS import qualified Data.Text.Extended as T@@ -85,37 +87,38 @@ import Control.Monad import Crypto.Hash.Algorithms import Crypto.MAC.HMAC+import Crypto.PubKey.RSA (PrivateKey, PublicKey)+import qualified Crypto.PubKey.RSA.PKCS15 as RSA+import Crypto.Store.X509 (readPubKeyFileFromMemory) import Data.ByteArray.Encoding import Data.Aeson hiding (decode, encode) import qualified Data.Aeson as JSON-import Data.Default-import qualified Data.HashMap.Strict as StrictMap import qualified Data.Map as Map import Data.Maybe import Data.Scientific+import qualified Data.Semigroup as Semigroup import Data.Time.Clock (NominalDiffTime)+import Data.X509 (PrivKey (PrivKeyRSA), PubKey (PubKeyRSA))+import Data.X509.Memory (readKeyFileFromMemory) import qualified Network.URI as URI import Prelude hiding (exp) --- $setup--- The code examples in this module require GHC's `OverloadedStrings`--- extension:------ >>> :set -XOverloadedStrings--type JSON = T.Text+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as KeyMap+#endif {-# DEPRECATED JWTHeader "Use JOSEHeader instead. JWTHeader will be removed in 1.0" #-} type JWTHeader = JOSEHeader --- | The secret used for calculating the message signature-newtype Secret = Secret BS.ByteString--instance Eq Secret where- (Secret s1) == (Secret s2) = s1 `BS.constTimeCompare` s2+data VerifySigner = VerifyHMACSecret BS.ByteString+ | VerifyRSAPrivateKey PrivateKey+ | VerifyRSAPublicKey PublicKey -instance Show Secret where- show _ = "<secret>"+data EncodeSigner = EncodeHMACSecret BS.ByteString+ | EncodeRSAPrivateKey PrivateKey newtype Signature = Signature T.Text deriving (Show) @@ -177,6 +180,7 @@ show (U u) = show u data Algorithm = HS256 -- ^ HMAC using SHA-256 hash algorithm+ | RS256 -- ^ RSA using SHA-256 hash algorithm deriving (Eq, Show) -- | JOSE Header, describes the cryptographic operations applied to the JWT@@ -189,17 +193,31 @@ -- | The cty (content type) Header Parameter defined by [JWS] and [JWE] is -- used by this specification to convey structural information about the JWT. , cty :: Maybe T.Text- -- | The alg (algorithm) used for signing the JWT. The HS256 (HMAC using SHA-256)- -- is the only required algorithm and the only one supported in this implementation- -- in addition to "none" which means that no signature will be used.+ -- | The alg (algorithm) used for signing the JWT. The HS256 (HMAC using+ -- SHA-256) is the only required algorithm in addition to "none" which means+ -- that no signature will be used. -- -- See <http://tools.ietf.org/html/draft-ietf-jose-json-web-algorithms-23#page-6> , alg :: Maybe Algorithm+ -- | The "kid" (key ID) Header Parameter is a hint indicating which key+ -- was used to secure the JWS. This parameter allows originators to+ -- explicitly signal a change of key to recipients. The structure of+ -- the "kid" value is unspecified. Its value MUST be a case-sensitive+ -- string. Use of this Header Parameter is OPTIONAL.+ --+ -- See <https://tools.ietf.org/html/rfc7515#section-4.1.4>+ , kid :: Maybe T.Text } deriving (Eq, Show) -instance Default JOSEHeader where- def = JOSEHeader Nothing Nothing Nothing+instance Monoid JOSEHeader where+ mempty =+ JOSEHeader Nothing Nothing Nothing Nothing+ mappend = (Semigroup.<>) +instance Semigroup.Semigroup JOSEHeader where+ JOSEHeader a b c d <> JOSEHeader a' b' c' d' =+ JOSEHeader (a <|> a') (b <|> b') (c <|> c') (d <|> d')+ -- | The JWT Claims Set represents a JSON object whose members are the claims conveyed by the JWT. data JWTClaimsSet = JWTClaimsSet { -- Registered Claim Names@@ -230,48 +248,55 @@ } deriving (Show, Eq) --instance Default JWTClaimsSet where- def = JWTClaimsSet Nothing Nothing Nothing Nothing Nothing Nothing Nothing Map.empty+instance Monoid JWTClaimsSet where+ mempty =+ JWTClaimsSet Nothing Nothing Nothing Nothing Nothing Nothing Nothing $ ClaimsMap Map.empty+ mappend = (Semigroup.<>) +instance Semigroup.Semigroup JWTClaimsSet where+ JWTClaimsSet a b c d e f g h <> JWTClaimsSet a' b' c' d' e' f' g' h' =+ JWTClaimsSet (a <|> a') (b <|> b') (c <|> c') (d <|> d') (e <|> e') (f <|> f') (g <|> g') (h Semigroup.<> h') -- | Encode a claims set using the given secret ----- @+-- >>> :{ -- let--- cs = def { -- def returns a default JWTClaimsSet--- iss = stringOrURI "Foo"--- , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))]+-- cs = mempty { -- mempty returns a default JWTClaimsSet+-- iss = stringOrURI . T.pack $ "Foo"+-- , unregisteredClaims = ClaimsMap $ Map.fromList [(T.pack "http://example.com/is_root", (Bool True))] -- }--- key = secret "secret-key"--- in encodeSigned HS256 key cs--- @--- > "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJodHRwOi8vZXhhbXBsZS5jb20vaXNfcm9vdCI6dHJ1ZSwiaXNzIjoiRm9vIn0.vHQHuG3ujbnBUmEp-fSUtYxk27rLiP2hrNhxpyWhb2E"-encodeSigned :: Algorithm -> Secret -> JWTClaimsSet -> JSON-encodeSigned algo secret claims = dotted [header, claim, signature]- where claim = encodeJWT claims- header = encodeJWT def {+-- key = hmacSecret . T.pack $ "secret-key"+-- in encodeSigned key mempty cs+-- :}+-- "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJodHRwOi8vZXhhbXBsZS5jb20vaXNfcm9vdCI6dHJ1ZSwiaXNzIjoiRm9vIn0.vHQHuG3ujbnBUmEp-fSUtYxk27rLiP2hrNhxpyWhb2E"+encodeSigned :: EncodeSigner -> JOSEHeader -> JWTClaimsSet -> T.Text+encodeSigned signer header' claims' = dotted [header'', claim, signature']+ where claim = encodeJWT claims'+ algo = case signer of+ EncodeHMACSecret _ -> HS256+ EncodeRSAPrivateKey _ -> RS256++ header'' = encodeJWT header' { typ = Just "JWT" , alg = Just algo }- signature = calculateDigest algo secret (dotted [header, claim])+ signature' = calculateDigest signer (dotted [header'', claim]) -- | Encode a claims set without signing it ----- @--- let--- cs = def { -- def returns a default JWTClaimsSet--- iss = stringOrURI "Foo"--- , iat = numericDate 1394700934--- , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))]--- }--- in encodeUnsigned cs--- @--- > "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJpYXQiOjEzOTQ3MDA5MzQsImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlLCJpc3MiOiJGb28ifQ."-encodeUnsigned :: JWTClaimsSet -> JSON-encodeUnsigned claims = dotted [header, claim, ""]- where claim = encodeJWT claims- header = encodeJWT def {+-- >>> :{+-- let cs = mempty+-- { iss = stringOrURI . Data.Text.pack $ "Foo"+-- , iat = numericDate 1394700934+-- , unregisteredClaims = ClaimsMap $ Data.Map.fromList [(Data.Text.pack "http://example.com/is_root", (Bool True))]+-- }+-- in encodeUnsigned cs mempty+-- :}+-- "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJpYXQiOjEzOTQ3MDA5MzQsImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlLCJpc3MiOiJGb28ifQ."+encodeUnsigned :: JWTClaimsSet -> JOSEHeader -> T.Text+encodeUnsigned claims' header' = dotted [header'', claim, ""]+ where claim = encodeJWT claims'+ header'' = encodeJWT header' { typ = Just "JWT" , alg = Just HS256 }@@ -283,22 +308,22 @@ -- -- >>> :{ -- let--- input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text+-- input = Data.Text.pack "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" -- mJwt = decode input -- in fmap header mJwt -- :}--- Just (JOSEHeader {typ = Just "JWT", cty = Nothing, alg = Just HS256})+-- Just (JOSEHeader {typ = Just "JWT", cty = Nothing, alg = Just HS256, kid = Nothing}) -- -- and -- -- >>> :{ -- let--- input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text+-- input = T.pack "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" -- mJwt = decode input -- in fmap claims mJwt -- :}--- Just (JWTClaimsSet {iss = Nothing, sub = Nothing, aud = Nothing, exp = Nothing, nbf = Nothing, iat = Nothing, jti = Nothing, unregisteredClaims = fromList [("some",String "payload")]})-decode :: JSON -> Maybe (JWT UnverifiedJWT)+-- Just (JWTClaimsSet {iss = Nothing, sub = Nothing, aud = Nothing, exp = Nothing, nbf = Nothing, iat = Nothing, jti = Nothing, unregisteredClaims = ClaimsMap {unClaimsMap = fromList [("some",String "payload")]}})+decode :: T.Text -> Maybe (JWT UnverifiedJWT) decode input = do (h,c,s) <- extractElems $ T.splitOn "." input let header' = parseJWT h@@ -322,18 +347,16 @@ -- -- >>> :{ -- let--- input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text+-- input = T.pack "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" -- mUnverifiedJwt = decode input--- mVerifiedJwt = verify (secret "secret") =<< mUnverifiedJwt+-- mVerifiedJwt = verify (toVerify . hmacSecret . T.pack $ "secret") =<< mUnverifiedJwt -- in signature =<< mVerifiedJwt -- :} -- Just (Signature "Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U")-verify :: Secret -> JWT UnverifiedJWT -> Maybe (JWT VerifiedJWT)-verify secret' (Unverified header' claims' unverifiedSignature originalClaim) = do- algo <- alg header'- let calculatedSignature = Signature $ calculateDigest algo secret' originalClaim- guard (unverifiedSignature == calculatedSignature)- pure $ Verified header' claims' calculatedSignature+verify :: VerifySigner -> JWT UnverifiedJWT -> Maybe (JWT VerifiedJWT)+verify signer (Unverified header' claims' unverifiedSignature originalClaim) = do+ guard (verifyDigest signer unverifiedSignature originalClaim)+ pure $ Verified header' claims' unverifiedSignature -- | Decode a claims set and verify that the signature matches by using the supplied secret. -- The algorithm is based on the supplied header value.@@ -343,27 +366,103 @@ -- -- >>> :{ -- let--- input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text--- mJwt = decodeAndVerifySignature (secret "secret") input+-- input = T.pack "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U"+-- mJwt = decodeAndVerifySignature (toVerify . hmacSecret . T.pack $ "secret") input -- in signature =<< mJwt -- :} -- Just (Signature "Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U")-decodeAndVerifySignature :: Secret -> JSON -> Maybe (JWT VerifiedJWT)-decodeAndVerifySignature secret' input = verify secret' =<< decode input+decodeAndVerifySignature :: VerifySigner -> T.Text -> Maybe (JWT VerifiedJWT)+decodeAndVerifySignature signer input = verify signer =<< decode input -- | Try to extract the value for the issue claim field 'iss' from the web token in JSON form-tokenIssuer :: JSON -> Maybe StringOrURI+tokenIssuer :: T.Text -> Maybe StringOrURI tokenIssuer = decode >=> fmap pure claims >=> iss -- | Create a Secret using the given key.--- Consider using `binarySecret` instead if your key is not already a "Data.Text".-secret :: T.Text -> Secret-secret = Secret . TE.encodeUtf8+-- Consider using `HMACSecret` instead if your key is not already a "Data.Text".+hmacSecret :: T.Text -> EncodeSigner+hmacSecret = EncodeHMACSecret . TE.encodeUtf8 --- | Create a Secret using the given key.-binarySecret :: BS.ByteString -> Secret-binarySecret = Secret+-- | Converts an EncodeSigner into a VerifySigner+-- If you can encode then you can always verify; but the reverse is not always true.+toVerify :: EncodeSigner -> VerifySigner+toVerify (EncodeHMACSecret s) = VerifyHMACSecret s+toVerify (EncodeRSAPrivateKey pk) = VerifyRSAPrivateKey pk +-- | Create an RSAPrivateKey from PEM contents+--+-- Please, consider using 'readRsaSecret' instead.+rsaKeySecret :: String -> IO (Maybe EncodeSigner)+rsaKeySecret = pure . fmap EncodeRSAPrivateKey . readRsaSecret . C8.pack++-- | Create an RSA 'PrivateKey' from PEM contents+--+-- > readRsaSecret <$> BS.readFile "foo.pem"+--+-- >>> :{+-- -- A random example key created with `ssh-keygen -t rsa`+-- fromJust . readRsaSecret . C8.pack $ unlines+-- [ "-----BEGIN RSA PRIVATE KEY-----"+-- , "MIIEowIBAAKCAQEAkkmgbLluo5HommstpHr1h53uWfuN3CwYYYR6I6a2MzAHIMIv"+-- , "8Ak2ha+N2UDeYsfVhZ/DOnE+PMm2RpYSaiYT0l2a7ZkmRSbcyvVFt3XLePJbmUgo"+-- , "ieyccS4uYHeqRggdWH9His3JaR2N71N9iU0+mY5nu2+15iYw3naT/PSx01IzBqHN"+-- , "Zie1z3FYX09FgOs31mcR8VWj8DefxbKE08AW+vDMT2AmUC2b+Gqk6SqRz29HuPBs"+-- , "yyV4Xl9CgzcCWjuXTv6mevDygo5RVZg34U6L1iFRgwwHbrLcd2N97wlKz+OiDSgM"+-- , "sbZWA0i2D9ZsDR9rdEdXzUIw6toIRYZfeI9QYQIDAQABAoIBAEXkh5Fqx0G/ZLLi"+-- , "olwDo2u4OTkkxxJ6vutYsEJ4VHUAbWdpYB3/SN12kv9JzvbDI3FEc7JoiKPifAQd"+-- , "j47HwpCvyGXc1jwT5UnTBgwxa5XNtZX2s+ex9Mzek6njgqcTGXI+3Z+j0qc2R6og"+-- , "6cm/7jjPoSAcr3vWo2KmpO4muw+LbYoSGo0Jydoa5cGtkmDfsjjrMw7mDoRttdhw"+-- , "WdhS+q2aJPFI7q7itoYUd7KLe3nOeM0zd35Pc8Qc6jGk+JZxQdXrb/NrSNgAATcN"+-- , "GGS226Q444N0pAfc188IDcAtQPSJpzbs/1+TPzE4ov/lpHTr91hXr3RLyVgYBI01"+-- , "jrggfAECgYEAwaC4iDSZQ+8eUx/zR973Lu9mvQxC2BZn6QcOtBcIRBdGRlXfhwuD"+-- , "UgwVZ2M3atH5ZXFuQ7pRtJtj7KCFy7HUFAJC15RCfLjx+n39bISNp5NOJEdI+UM+"+-- , "G2xMHv5ywkULV7Jxb+tSgsYIvJ0tBjACkif8ahNjgVJmgMSOgdHR2pkCgYEAwWkN"+-- , "uquRqKekx4gx1gJYV7Y6tPWcsZpEcgSS7AGNJ4UuGZGGHdStpUoJICn2cFUngYNz"+-- , "eJXOg+VhQJMqQx9c+u85mg/tJluGaw95tBAafspwvhKewlO9OhQeVInPbXMUwrJ0"+-- , "PS3XV7c74nxm6Nn4QHlM07orn3lOiWxZF8BBSQkCgYATjwSU3ZtNvW22v9d3PxKA"+-- , "7zXVitOFuF2usEPP9TOkjSVQHYSCw6r0MrxGwULry2IB2T9mH//42mlxkZVySfg+"+-- , "PSw7UoKUzqnCv89Fku4sKzkNeRXp99ziMEJQLyuwbAEFTsUepQqkoxRm2QmfQmJA"+-- , "GUHqBSNcANLR1wj+HA+yoQKBgQCBlqj7RQ+AaGsQwiFaGhIlGtU1AEgv+4QWvRfQ"+-- , "B64TJ7neqdGp1SFP2U5J/bPASl4A+hl5Vy6a0ysZQEGV3cLH41e98SPdin+C5kiO"+-- , "LCgEghGOWR2EaOUlr+sui3OvCueDGFynzTo27G+0bdPp+nnKgTvHtTqbTIUhsLX1"+-- , "IvzbOQKBgH4q36jgBb9T3hjXtWyrytlmFtBdw0i+UiMvMlnOqujGhcnOk5UMyxOQ"+-- , "sQI+/31jIGbmlE7YaYykR1FH3LzAjO4J1+m7vv5fIRdG8+sI01xTc8UAdbmWtK+5"+-- , "TK1oLP43BHH5gRAfIlXj2qmap5lEG6If/xYB4MOs8Bui5iKaJlM5"+-- , "-----END RSA PRIVATE KEY-----"+-- ]+-- :}+-- PrivateKey {private_pub = PublicKey {public_size = 256, public_n = 1846..., public_e = 65537}, private_d = 8823..., private_p = 135..., private_q = 1358..., private_dP = 1373..., private_dQ = 9100..., private_qinv = 8859...}+--+readRsaSecret :: BS.ByteString -> Maybe PrivateKey+readRsaSecret bs =+ case readKeyFileFromMemory bs of+ [(PrivKeyRSA k)] -> Just k+ _ -> Nothing+++-- | Create an RSA 'PublicKey' from PEM contents+--+-- > readRsaPublicKey <$> BS.readFile "foo.pub"+-- >>> :{+-- fromJust . readRsaPublicKey . Data.ByteString.Char8.pack $ Data.List.unlines+-- [ "-----BEGIN PUBLIC KEY-----"+-- , "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA12d4M6f3QQ9E52fVjoJ7"+-- , "HorKvi1A83f4YL4e7TU0Lj/73+afrRBtnAdl8dIrnYHLWRdL9T4+yw7+AimQgj1R"+-- , "zZO5FQN/qVxygkPeMKAZ53nObi2NyBbQYmRrBjx7rOz7UddI5qo/ApTWNrSBjDKK"+-- , "1splbuO2BoTrsHlsSoJDWps/5SwpEF4GGkn5c4nZRnpnayUZqolp+HwDK2Dys9MO"+-- , "GEIsUil1+k/76T96pBnPf6mf3X0IacTCNjJcztSaHCPWre1q45miQUGVlTmhfg/6"+-- , "L8xmNRxz4BZdv8Nv6STfRTsn6PqiaabD0vITVsF1AapdHohmPMwe+lG5ebUJEh8p"+-- , "HQIDAQAB"+-- , "-----END PUBLIC KEY-----"+-- ]+-- :}+-- PublicKey {public_size = 256, public_n = 27192258298637073499814714121384917708820189127612408586659742012541332375187297990620494295383503839337630959589643433993051132285579261506578281787130221431792495554016841577295914249477128682873612830754668313951998800261326356221445367133271958375798088350587817966390021082924122322621635687775325677158394714044356852489350530339926527334843762933075425870780010358838296108179073735084189560997222261973170469403371017667139302904425235800700389626242339763391588052694912470921008842459564204534000688115202764921141372629345213727775126077560633656612484128950350759146471467728292335666402631045889956718877, public_e = 65537}+readRsaPublicKey :: BS.ByteString -> Maybe PublicKey+readRsaPublicKey bs =+ case readPubKeyFileFromMemory bs of+ [(PubKeyRSA k)] -> Just k+ _ -> Nothing+ -- | Convert the `NominalDiffTime` into an IntDate. Returns a Nothing if the -- argument is invalid (e.g. the NominalDiffTime must be convertible into a -- positive Integer representing the seconds since epoch).@@ -416,21 +515,57 @@ -- ================================================================================= -calculateDigest :: Algorithm -> Secret -> T.Text -> T.Text-calculateDigest HS256 (Secret key) msg = TE.decodeUtf8 $ convertToBase Base64URLUnpadded (hmac key (bs msg) :: HMAC SHA256)- where - bs = TE.encodeUtf8+calculateDigest :: EncodeSigner -> T.Text -> T.Text+calculateDigest (EncodeHMACSecret key) msg =+ TE.decodeUtf8 $ convertToBase Base64URLUnpadded (hmac key (TE.encodeUtf8 msg) :: HMAC SHA256) +calculateDigest (EncodeRSAPrivateKey key) msg = TE.decodeUtf8+ $ convertToBase Base64URLUnpadded+ $ sign'+ $ TE.encodeUtf8 msg+ where+ sign' :: BS.ByteString -> BS.ByteString+ sign' bs = case RSA.sign Nothing (Just SHA256) key bs of+ Right sig -> sig+ Left _ -> error "impossible" -- This function can only fail with @SignatureTooLong@,+ -- which is impossible because we use a hash.++verifyDigest :: VerifySigner -> Signature -> T.Text -> Bool+verifyDigest (VerifyHMACSecret key) unverifiedSig msg = unverifiedSig == Signature (calculateDigest (EncodeHMACSecret key) msg)+verifyDigest (VerifyRSAPrivateKey pk) unverifiedSig msg = unverifiedSig == Signature (calculateDigest (EncodeRSAPrivateKey pk) msg)+verifyDigest (VerifyRSAPublicKey pk) (Signature base64Sig) msg =+ let+ decodedSig =+ convertFromBase Base64URLUnpadded (TE.encodeUtf8 base64Sig)+ in+ either (pure False) (RSA.verify (Just SHA256) pk (TE.encodeUtf8 msg)) decodedSig+ -- ================================================================================= -type ClaimsMap = Map.Map T.Text Value+newtype ClaimsMap = ClaimsMap { unClaimsMap :: Map.Map T.Text Value }+ deriving (Eq, Show) +instance Monoid ClaimsMap where+ mempty =+ ClaimsMap mempty+ mappend = (Semigroup.<>)++instance Semigroup.Semigroup ClaimsMap where+ ClaimsMap a <> ClaimsMap b =+ ClaimsMap $ a Semigroup.<> b+ fromHashMap :: Object -> ClaimsMap-fromHashMap = Map.fromList . StrictMap.toList+fromHashMap = ClaimsMap . Map.fromList . map (first toText) . KeyMap.toList+ where+#if MIN_VERSION_aeson(2,0,0)+ toText = Key.toText+#else+ toText = id+#endif removeRegisteredClaims :: ClaimsMap -> ClaimsMap-removeRegisteredClaims input = Map.differenceWithKey (\_ _ _ -> Nothing) input registeredClaims- where +removeRegisteredClaims (ClaimsMap input) = ClaimsMap $ Map.differenceWithKey (\_ _ _ -> Nothing) input registeredClaims+ where registeredClaims = Map.fromList $ map (\e -> (e, Null)) ["iss", "sub", "aud", "exp", "nbf", "iat", "jti"] instance ToJSON JWTClaimsSet where@@ -442,14 +577,20 @@ , fmap ("nbf" .=) nbf , fmap ("iat" .=) iat , fmap ("jti" .=) jti- ] ++ Map.toList (removeRegisteredClaims unregisteredClaims)+ ] ++ map (first fromText) (Map.toList $ unClaimsMap $ removeRegisteredClaims unregisteredClaims)+ where+#if MIN_VERSION_aeson(2,0,0)+ fromText = Key.fromText+#else+ fromText = id+#endif instance FromJSON JWTClaimsSet where parseJSON = withObject "JWTClaimsSet" (\o -> JWTClaimsSet <$> o .:? "iss" <*> o .:? "sub"- <*> case StrictMap.lookup "aud" o of+ <*> case KeyMap.lookup "aud" o of (Just as@(JSON.Array _)) -> Just <$> Right <$> parseJSON as (Just (JSON.String t)) -> pure $ Left <$> stringOrURI t _ -> pure Nothing@@ -464,13 +605,15 @@ (\o -> JOSEHeader <$> o .:? "typ" <*> o .:? "cty"- <*> o .:? "alg")+ <*> o .:? "alg"+ <*> o .:? "kid") instance ToJSON JOSEHeader where toJSON JOSEHeader{..} = object $ catMaybes [ fmap ("typ" .=) typ , fmap ("cty" .=) cty , fmap ("alg" .=) alg+ , fmap ("kid" .=) kid ] instance ToJSON NumericDate where@@ -482,9 +625,11 @@ instance ToJSON Algorithm where toJSON HS256 = String ("HS256"::T.Text)+ toJSON RS256 = String ("RS256"::T.Text) instance FromJSON Algorithm where parseJSON (String "HS256") = return HS256+ parseJSON (String "RS256") = return RS256 parseJSON _ = mzero instance ToJSON StringOrURI where
+ stack.yaml view
@@ -0,0 +1,7 @@+resolver: nightly-2021-10-07++extra-deps:+ - aeson-2.0.0.0+ - lens-aeson-1.1.2+ - cryptostore-0.2.1.0+ - doctest-0.20.0
tests/src/Data/ByteString/ExtendedTests.hs view
@@ -1,15 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.ByteString.ExtendedTests ( main , defaultTestGroup ) where -import Control.Applicative import qualified Data.ByteString.Extended as BS-import Data.String (fromString) import qualified Test.QuickCheck as QC import Test.Tasty import Test.Tasty.QuickCheck
tests/src/Data/Text/ExtendedTests.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Text.ExtendedTests ( main , defaultTestGroup ) where -import Control.Applicative import Data.String (fromString) import qualified Data.Text.Extended as T import qualified Test.QuickCheck as QC
tests/src/Web/JWTInteropTests.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} {-| Tests that verify that the shape of the JSON used is matching the spec. @@ -23,20 +23,18 @@ ) where import Prelude hiding (exp)-import Control.Applicative import Control.Lens import Data.Aeson.Lens import Data.Aeson.Types import qualified Data.Map as Map import Data.Maybe-import Data.String (IsString, fromString)+import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time import qualified Data.Vector as Vector import qualified Test.QuickCheck as QC import Test.Tasty-import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.Tasty.TH import Web.JWT@@ -56,6 +54,7 @@ prop_encode_decode_iss :: JWTClaimsSet -> Bool prop_encode_decode_iss = shouldBeMaybeStringOrUri "iss" iss +shouldBeMaybeStringOrUri :: ToJSON a => T.Text -> (a -> Maybe StringOrURI) -> a -> Bool shouldBeMaybeStringOrUri key' f claims' = let json = toJSON claims' ^? key key' in json == (fmap (String . stringOrURIToText) $ f claims')@@ -80,7 +79,7 @@ <*> arbitrary instance Arbitrary ClaimsMap where- arbitrary = return Map.empty+ arbitrary = return $ ClaimsMap Map.empty instance Arbitrary NumericDate where arbitrary = fmap (f . numericDate) (arbitrary :: QC.Gen NominalDiffTime)
tests/src/Web/JWTTests.hs view
@@ -1,27 +1,30 @@ {-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Web.JWTTests ( main , defaultTestGroup ) where -import Control.Applicative import Test.Tasty import Test.Tasty.TH import Test.Tasty.HUnit import Test.Tasty.QuickCheck-import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck as QC import qualified Data.Map as Map import qualified Data.Text as T-import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL-import qualified Data.ByteString as BS+import qualified Data.ByteString as BS import Data.Aeson.Types import Data.Maybe-import Data.String (fromString, IsString)+import Data.String (fromString) import Data.Time import Web.JWT+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.Random.Types as CT+import qualified Data.ByteArray as BA defaultTestGroup :: TestTree defaultTestGroup = $(testGroupGenerator)@@ -52,22 +55,22 @@ True @=? isJust (fmap signature mJwt) let (Just unverified) = mJwt Just HS256 @=? alg (header unverified)- Just "payload" @=? Map.lookup "some" (unregisteredClaims $ claims unverified)+ Just "payload" @=? Map.lookup "some" (unClaimsMap $ unregisteredClaims $ claims unverified) case_verify = do -- Generated with ruby-jwt let input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U"- mVerified = verify (secret "secret") =<< decode input+ mVerified = verify (toVerify . hmacSecret $ "secret") =<< decode input True @=? isJust mVerified case_decodeAndVerifyJWT = do -- Generated with ruby-jwt let input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U"- mJwt = decodeAndVerifySignature (secret "secret") input+ mJwt = decodeAndVerifySignature (toVerify . hmacSecret $ "secret") input True @=? isJust mJwt let (Just verified) = mJwt Just HS256 @=? alg (header verified)- Just "payload" @=? Map.lookup "some" (unregisteredClaims $ claims verified)+ Just "payload" @=? Map.lookup "some" (unClaimsMap $ unregisteredClaims $ claims verified) -- It must be impossible to get a VerifiedJWT if alg is "none" case_decodeAndVerifyJWTAlgoNone = do@@ -89,13 +92,13 @@ } -} let input = "eyJhbGciOiJub25lIiwidHlwIjoiSldUIn0.eyJpc3MiOiJodHRwczovL2p3dC1pZHAuZXhhbXBsZS5jb20iLCJzdWIiOiJtYWlsdG86bWlrZUBleGFtcGxlLmNvbSIsIm5iZiI6MTQyNTk4MDc1NSwiZXhwIjoxNDI1OTg0MzU1LCJpYXQiOjE0MjU5ODA3NTUsImp0aSI6ImlkMTIzNDU2IiwidHlwIjoiaHR0cHM6Ly9leGFtcGxlLmNvbS9yZWdpc3RlciJ9."- mJwt = decodeAndVerifySignature (secret "secretkey") input+ mJwt = decodeAndVerifySignature (toVerify . hmacSecret $ "secretkey") input False @=? isJust mJwt case_decodeAndVerifyJWTFailing = do -- Generated with ruby-jwt, modified to be invalid let input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2u"- mJwt = decodeAndVerifySignature (secret "secret") input+ mJwt = decodeAndVerifySignature (toVerify . hmacSecret $ "secret") input False @=? isJust mJwt case_decodeInvalidInput = do@@ -105,15 +108,15 @@ case_decodeAndVerifySignatureInvalidInput = do let inputs = ["", "a.", "a.b"]- result = map (decodeAndVerifySignature (secret "secret")) inputs+ result = map (decodeAndVerifySignature (toVerify . hmacSecret $ "secret")) inputs True @=? all isNothing result case_encodeJWTNoMac = do- let cs = def {+ let cs = mempty { iss = stringOrURI "Foo"- , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)]+ , unregisteredClaims = ClaimsMap $ Map.fromList [("http://example.com/is_root", Bool True)] }- jwt = encodeUnsigned cs+ jwt = encodeUnsigned cs mempty -- Verify the shape of the JWT, ensure the shape of the triple of -- <header>.<claims>.<signature> let (h:c:s:_) = T.splitOn "." jwt@@ -123,80 +126,80 @@ case_encodeDecodeJWTNoMac = do- let cs = def {+ let cs = mempty { iss = stringOrURI "Foo"- , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)]+ , unregisteredClaims = ClaimsMap $ Map.fromList [("http://example.com/is_root", Bool True)] }- mJwt = decode $ encodeUnsigned cs+ mJwt = decode $ encodeUnsigned cs mempty True @=? isJust mJwt let (Just unverified) = mJwt cs @=? claims unverified case_encodeDecodeJWT = do let now = 1394573404- cs = def {+ cs = mempty { iss = stringOrURI "Foo" , iat = numericDate now- , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)]+ , unregisteredClaims = ClaimsMap $ Map.fromList [("http://example.com/is_root", Bool True)] }- key = secret "secret-key"- mJwt = decode $ encodeSigned HS256 key cs+ key = hmacSecret "secret-key"+ mJwt = decode $ encodeSigned key mempty cs let (Just claims') = fmap claims mJwt cs @=? claims' Just now @=? fmap secondsSinceEpoch (iat claims') case_tokenIssuer = do let iss' = stringOrURI "Foo"- cs = def {+ cs = mempty { iss = iss'- , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)]+ , unregisteredClaims = ClaimsMap $ Map.fromList [("http://example.com/is_root", Bool True)] }- key = secret "secret-key"- t = encodeSigned HS256 key cs+ key = hmacSecret "secret-key"+ t = encodeSigned key mempty cs iss' @=? tokenIssuer t case_encodeDecodeJWTClaimsSetCustomClaims = do let now = 1234- cs = def {+ cs = mempty { iss = stringOrURI "Foo" , iat = numericDate now- , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)]+ , unregisteredClaims = ClaimsMap $ Map.fromList [("http://example.com/is_root", Bool True)] }- let secret' = secret "secret"- jwt = decodeAndVerifySignature secret' $ encodeSigned HS256 secret' cs+ let secret' = hmacSecret "secret"+ jwt = decodeAndVerifySignature (toVerify secret') $ encodeSigned secret' mempty cs Just cs @=? fmap claims jwt case_encodeDecodeJWTClaimsSetWithSingleAud = do let now = 1234- cs = def {+ cs = mempty { iss = stringOrURI "Foo" , aud = Left <$> stringOrURI "single-audience" , iat = numericDate now }- let secret' = secret "secret"- jwt = decodeAndVerifySignature secret' $ encodeSigned HS256 secret' cs+ let secret' = hmacSecret "secret"+ jwt = decodeAndVerifySignature (toVerify secret') $ encodeSigned secret' mempty cs Just cs @=? fmap claims jwt case_encodeDecodeJWTClaimsSetWithMultipleAud = do let now = 1234- cs = def {+ cs = mempty { iss = stringOrURI "Foo" , aud = Right <$> (:[]) <$> stringOrURI "audience" , iat = numericDate now }- let secret' = secret "secret"- jwt = decodeAndVerifySignature secret' $ encodeSigned HS256 secret' cs+ let secret' = hmacSecret "secret"+ jwt = decodeAndVerifySignature (toVerify secret') $ encodeSigned secret' mempty cs Just cs @=? fmap claims jwt case_encodeDecodeJWTClaimsSetBinarySecret = do let now = 1234- cs = def {+ cs = mempty { iss = stringOrURI "Foo" , iat = numericDate now } secretKey <- BS.readFile "tests/jwt.secret.1"- let secret' = binarySecret secretKey- jwt = decodeAndVerifySignature secret' $ encodeSigned HS256 secret' cs+ let secret' = EncodeHMACSecret secretKey+ jwt = decodeAndVerifySignature (toVerify secret') $ encodeSigned secret' mempty cs Just cs @=? fmap claims jwt prop_stringOrURIProp = f@@ -213,21 +216,43 @@ prop_encode_decode = f where f :: T.Text -> JWTClaimsSet -> Bool- f key claims' = let Just unverified = (decode $ encodeSigned HS256 (secret key) claims')+ f key claims' = let Just unverified = (decode $ encodeSigned (hmacSecret key) mempty claims') in claims unverified == claims' prop_encode_decode_binary_secret = f where f :: BS.ByteString -> JWTClaimsSet -> Bool- f binary claims' = let Just unverified = (decode $ encodeSigned HS256 (binarySecret binary) claims')+ f binary claims' = let Just unverified = (decode $ encodeSigned (EncodeHMACSecret binary) mempty claims') in claims unverified == claims' prop_encode_decode_verify_signature = f where f :: T.Text -> JWTClaimsSet -> Bool- f key' claims' = let key = secret key'- Just verified = (decodeAndVerifySignature key $ encodeSigned HS256 key claims')+ f key' claims' = let key = hmacSecret key'+ Just verified = (decodeAndVerifySignature (toVerify key) $ encodeSigned key mempty claims') in claims verified == claims' +-- Generating a keypair takes over a second. Let's only do this a few times.+prop_rsa_verify_with_public_key = withMaxSuccess 20 f+ where f :: Keypair -> JWTClaimsSet -> Bool+ f kp claims' = let encodeSigner = EncodeRSAPrivateKey . kpPrivate $ kp+ verifySigner = VerifyRSAPublicKey . kpPublic $ kp+ signedToken = encodeSigned encodeSigner mempty claims'+ in isJust $ decodeAndVerifySignature verifySigner signedToken +data Keypair = Keypair+ { kpPrivate :: RSA.PrivateKey+ , kpPublic :: RSA.PublicKey+ } deriving (Show)++instance Arbitrary (Keypair) where+ arbitrary = do+ (pubKey, privateKey) <- RSA.generate 256 3+ return $ Keypair { kpPrivate = privateKey, kpPublic = pubKey }++instance CT.MonadRandom Gen where+ getRandomBytes size = do+ bytes <- vector size+ return . BA.pack $ bytes+ instance Arbitrary JWTClaimsSet where arbitrary = JWTClaimsSet <$> arbitrary <*> arbitrary@@ -239,7 +264,7 @@ <*> arbitrary instance Arbitrary ClaimsMap where- arbitrary = return Map.empty+ arbitrary = return $ ClaimsMap Map.empty instance Arbitrary NumericDate where arbitrary = fmap (f . numericDate) (arbitrary :: QC.Gen NominalDiffTime)
tests/src/Web/JWTTestsCompat.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} {- - Turn of deprecation warnings as these tests deliberately use @@ -13,19 +15,11 @@ , defaultTestGroup ) where -import Control.Applicative import Test.Tasty import Test.Tasty.TH import Test.Tasty.HUnit-import Test.Tasty.QuickCheck-import qualified Test.QuickCheck as QC import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL import Data.Aeson.Types-import Data.Maybe-import Data.String (fromString, IsString)-import Data.Time import Web.JWT defaultTestGroup :: TestTree@@ -41,13 +35,13 @@ case_encodeDecodeJWTIntDateIat = do let now = 1394573404- cs = def {+ cs = mempty { iss = stringOrURI "Foo" , iat = intDate now- , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)]+ , unregisteredClaims = ClaimsMap $ Map.fromList [("http://example.com/is_root", Bool True)] }- key = secret "secret-key"- mJwt = decode $ encodeSigned HS256 key cs+ key = hmacSecret "secret-key"+ mJwt = decode $ encodeSigned key mempty cs let (Just claims') = fmap claims mJwt cs @=? claims' Just now @=? fmap secondsSinceEpoch (iat claims')