diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. [![Build -Status](https://travis-ci.org/juretta/haskell-jwt.svg?branch=master)](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) diff --git a/doctests.hs b/doctests.hs --- a/doctests.hs +++ b/doctests.hs @@ -1,3 +1,4 @@ import Test.DocTest -main = doctest ["-isrc", "src/Web"] +main :: IO () +main = doctest ["-isrc", "src"] diff --git a/jwt.cabal b/jwt.cabal --- a/jwt.cabal +++ b/jwt.cabal @@ -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 diff --git a/src/Web/JWT.hs b/src/Web/JWT.hs --- a/src/Web/JWT.hs +++ b/src/Web/JWT.hs @@ -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 -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 _ = "" +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 , 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 + , 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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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 diff --git a/tests/src/Data/ByteString/ExtendedTests.hs b/tests/src/Data/ByteString/ExtendedTests.hs --- a/tests/src/Data/ByteString/ExtendedTests.hs +++ b/tests/src/Data/ByteString/ExtendedTests.hs @@ -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 diff --git a/tests/src/Data/Text/ExtendedTests.hs b/tests/src/Data/Text/ExtendedTests.hs --- a/tests/src/Data/Text/ExtendedTests.hs +++ b/tests/src/Data/Text/ExtendedTests.hs @@ -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 diff --git a/tests/src/Web/JWTInteropTests.hs b/tests/src/Web/JWTInteropTests.hs --- a/tests/src/Web/JWTInteropTests.hs +++ b/tests/src/Web/JWTInteropTests.hs @@ -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) diff --git a/tests/src/Web/JWTTests.hs b/tests/src/Web/JWTTests.hs --- a/tests/src/Web/JWTTests.hs +++ b/tests/src/Web/JWTTests.hs @@ -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 --
.. 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) diff --git a/tests/src/Web/JWTTestsCompat.hs b/tests/src/Web/JWTTestsCompat.hs --- a/tests/src/Web/JWTTestsCompat.hs +++ b/tests/src/Web/JWTTestsCompat.hs @@ -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')