diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# 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) - - diff --git a/doctests.hs b/doctests.hs --- a/doctests.hs +++ b/doctests.hs @@ -1,3 +1,4 @@ import Test.DocTest +main :: IO () main = doctest ["-isrc", "src/Web"] diff --git a/jwt.cabal b/jwt.cabal --- a/jwt.cabal +++ b/jwt.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: jwt -version: 0.7.2 +version: 0.8.0 synopsis: JSON Web Token (JWT) decoding and encoding license: MIT license-file: LICENSE @@ -22,6 +22,7 @@ extra-source-files: CHANGELOG.md README.md + stack.yaml tests/jwt.secret.1 source-repository head @@ -40,12 +41,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 + , RSA + , HsOpenSSL hs-source-dirs: src default-language: Haskell2010 @@ -85,12 +87,13 @@ , scientific >= 0.2 , containers , unordered-containers - , data-default , http-types , time >= 1.1 , vector >= 0.7.1 , semigroups >= 0.15.4 , network-uri + , RSA + , HsOpenSSL cpp-options: -DTEST diff --git a/src/Web/JWT.hs b/src/Web/JWT.hs --- a/src/Web/JWT.hs +++ b/src/Web/JWT.hs @@ -13,11 +13,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 +39,8 @@ -- * Utility functions -- ** Common , tokenIssuer - , secret - , binarySecret + , hmacSecret + , rsaKeySecret -- ** JWT structure , claims , header @@ -61,19 +61,17 @@ , UnverifiedJWT , VerifiedJWT , Signature - , Secret + , Signer(..) , JWT , JSON , Algorithm(..) , JWTClaimsSet(..) - , ClaimsMap + , ClaimsMap(..) , IntDate , NumericDate , StringOrURI , JWTHeader , JOSEHeader - - , module Data.Default ) where import qualified Data.ByteString.Lazy.Char8 as BL (fromStrict, toStrict) @@ -81,6 +79,7 @@ import qualified Data.Text.Extended as T import qualified Data.Text.Encoding as TE +import Codec.Crypto.RSA (PrivateKey(..), PublicKey(..), sign) import Control.Applicative import Control.Monad import Crypto.Hash.Algorithms @@ -88,13 +87,28 @@ 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 Data.Time.Clock (NominalDiffTime) import qualified Network.URI as URI +import OpenSSL.EVP.PKey (toKeyPair) +import OpenSSL.PEM (PemPasswordSupply(..), readPrivateKey) +import OpenSSL.RSA + ( RSAKeyPair + , RSAPubKey + , rsaCopyPublic + , rsaD + , rsaDMP1 + , rsaDMQ1 + , rsaE + , rsaIQMP + , rsaN + , rsaP + , rsaQ + , rsaSize + ) import Prelude hiding (exp) -- $setup @@ -108,14 +122,8 @@ {-# 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 - -instance Show Secret where - show _ = "" +data Signer = HMACSecret BS.ByteString + | RSAPrivateKey PrivateKey newtype Signature = Signature T.Text deriving (Show) @@ -177,6 +185,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,16 +198,19 @@ -- | 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 } deriving (Eq, Show) -instance Default JOSEHeader where - def = JOSEHeader Nothing Nothing Nothing +instance Monoid JOSEHeader where + mempty = + JOSEHeader Nothing Nothing Nothing + mappend (JOSEHeader a b c) (JOSEHeader a' b' c') = + JOSEHeader (a <|> a') (b <|> b') (c <|> c') -- | The JWT Claims Set represents a JSON object whose members are the claims conveyed by the JWT. data JWTClaimsSet = JWTClaimsSet { @@ -230,37 +242,42 @@ } 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 (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') (mappend h h') -- | Encode a claims set using the given secret -- -- @ -- let --- cs = def { -- def returns a default JWTClaimsSet +-- cs = mempty { -- mempty returns a default JWTClaimsSet -- iss = stringOrURI "Foo" -- , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))] -- } --- key = secret "secret-key" --- in encodeSigned HS256 key cs +-- key = hmacSecret "secret-key" +-- in encodeSigned 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 { +encodeSigned :: Signer -> JWTClaimsSet -> JSON +encodeSigned signer claims' = dotted [header', claim, signature'] + where claim = encodeJWT claims' + algo = case signer of + HMACSecret _ -> HS256 + RSAPrivateKey _ -> RS256 + + header' = encodeJWT mempty { 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 +-- cs = mempty { -- mempty returns a default JWTClaimsSet -- iss = stringOrURI "Foo" -- , iat = numericDate 1394700934 -- , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))] @@ -269,9 +286,9 @@ -- @ -- > "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJpYXQiOjEzOTQ3MDA5MzQsImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlLCJpc3MiOiJGb28ifQ." encodeUnsigned :: JWTClaimsSet -> JSON -encodeUnsigned claims = dotted [header, claim, ""] - where claim = encodeJWT claims - header = encodeJWT def { +encodeUnsigned claims' = dotted [header', claim, ""] + where claim = encodeJWT claims' + header' = encodeJWT mempty { typ = Just "JWT" , alg = Just HS256 } @@ -297,7 +314,7 @@ -- 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")]}) +-- Just (JWTClaimsSet {iss = Nothing, sub = Nothing, aud = Nothing, exp = Nothing, nbf = Nothing, iat = Nothing, jti = Nothing, unregisteredClaims = ClaimsMap {unClaimsMap = fromList [("some",String "payload")]}}) decode :: JSON -> Maybe (JWT UnverifiedJWT) decode input = do (h,c,s) <- extractElems $ T.splitOn "." input @@ -324,14 +341,13 @@ -- let -- input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text -- mUnverifiedJwt = decode input --- mVerifiedJwt = verify (secret "secret") =<< mUnverifiedJwt +-- mVerifiedJwt = verify (hmacSecret "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 +verify :: Signer -> JWT UnverifiedJWT -> Maybe (JWT VerifiedJWT) +verify signer (Unverified header' claims' unverifiedSignature originalClaim) = do + let calculatedSignature = Signature $ calculateDigest signer originalClaim guard (unverifiedSignature == calculatedSignature) pure $ Verified header' claims' calculatedSignature @@ -344,12 +360,12 @@ -- >>> :{ -- let -- input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text --- mJwt = decodeAndVerifySignature (secret "secret") input +-- mJwt = decodeAndVerifySignature (hmacSecret "secret") input -- in signature =<< mJwt -- :} -- Just (Signature "Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U") -decodeAndVerifySignature :: Secret -> JSON -> Maybe (JWT VerifiedJWT) -decodeAndVerifySignature secret' input = verify secret' =<< decode input +decodeAndVerifySignature :: Signer -> JSON -> 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 @@ -357,12 +373,68 @@ -- | 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 +hmacSecret :: T.Text -> Signer +hmacSecret = HMACSecret . TE.encodeUtf8 --- | Create a Secret using the given key. -binarySecret :: BS.ByteString -> Secret -binarySecret = Secret +-- | Create an RSAPrivateKey from PEM contents +-- +-- > rsaKeySecret =<< readFile "foo.pem" +-- +-- >>> :{ +-- -- A random example key created with `ssh-keygen -t rsa` +-- fmap (\(Just (RSAPrivateKey pk)) -> pk) $ rsaKeySecret $ 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...} +-- +rsaKeySecret :: String -> IO (Maybe Signer) +rsaKeySecret k = do + mKeyPair <- toKeyPair <$> readPrivateKey k PwNone + mPublicKey <- mapM rsaCopyPublic mKeyPair + return $ RSAPrivateKey <$> + (fromRSAKey <$> mKeyPair <*> mPublicKey) + where + fromRSAKey :: RSAKeyPair -> RSAPubKey -> PrivateKey + fromRSAKey kp pk = PrivateKey + { private_pub = PublicKey + { public_size = rsaSize pk + , public_n = rsaN pk + , public_e = rsaE pk + } + , private_d = rsaD kp + , private_p = rsaP kp + , private_q = rsaQ kp + , private_dP = fromMaybe 0 $ rsaDMP1 kp + , private_dQ = fromMaybe 0 $ rsaDMQ1 kp + , private_qinv = fromMaybe 0 $ rsaIQMP kp + } -- | Convert the `NominalDiffTime` into an IntDate. Returns a Nothing if the -- argument is invalid (e.g. the NominalDiffTime must be convertible into a @@ -416,21 +488,34 @@ -- ================================================================================= -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 :: Signer -> T.Text -> T.Text +calculateDigest (HMACSecret key) msg = + TE.decodeUtf8 $ convertToBase Base64URLUnpadded (hmac key (TE.encodeUtf8 msg) :: HMAC SHA256) +calculateDigest (RSAPrivateKey key) msg = TE.decodeUtf8 + $ convertToBase Base64URLUnpadded + $ BL.toStrict + $ sign key + $ BL.fromStrict + $ TE.encodeUtf8 msg + -- ================================================================================= -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 (ClaimsMap a) (ClaimsMap b) = + ClaimsMap $ mappend a b + fromHashMap :: Object -> ClaimsMap -fromHashMap = Map.fromList . StrictMap.toList +fromHashMap = ClaimsMap . Map.fromList . StrictMap.toList 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,7 +527,7 @@ , fmap ("nbf" .=) nbf , fmap ("iat" .=) iat , fmap ("jti" .=) jti - ] ++ Map.toList (removeRegisteredClaims unregisteredClaims) + ] ++ Map.toList (unClaimsMap $ removeRegisteredClaims unregisteredClaims) instance FromJSON JWTClaimsSet where parseJSON = withObject "JWTClaimsSet" @@ -482,9 +567,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,4 @@ +packages: +- '.' +extra-deps: [] +resolver: lts-9.6 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,12 +1,13 @@ {-# 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 @@ -14,12 +15,11 @@ 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 Data.Aeson.Types import Data.Maybe -import Data.String (fromString, IsString) +import Data.String (fromString) import Data.Time import Web.JWT @@ -52,22 +52,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 (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 (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 +89,13 @@ } -} let input = "eyJhbGciOiJub25lIiwidHlwIjoiSldUIn0.eyJpc3MiOiJodHRwczovL2p3dC1pZHAuZXhhbXBsZS5jb20iLCJzdWIiOiJtYWlsdG86bWlrZUBleGFtcGxlLmNvbSIsIm5iZiI6MTQyNTk4MDc1NSwiZXhwIjoxNDI1OTg0MzU1LCJpYXQiOjE0MjU5ODA3NTUsImp0aSI6ImlkMTIzNDU2IiwidHlwIjoiaHR0cHM6Ly9leGFtcGxlLmNvbS9yZWdpc3RlciJ9." - mJwt = decodeAndVerifySignature (secret "secretkey") input + mJwt = decodeAndVerifySignature (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 (hmacSecret "secret") input False @=? isJust mJwt case_decodeInvalidInput = do @@ -105,13 +105,13 @@ case_decodeAndVerifySignatureInvalidInput = do let inputs = ["", "a.", "a.b"] - result = map (decodeAndVerifySignature (secret "secret")) inputs + result = map (decodeAndVerifySignature (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 -- Verify the shape of the JWT, ensure the shape of the triple of @@ -123,9 +123,9 @@ 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 True @=? isJust mJwt @@ -134,69 +134,69 @@ 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 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 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 secret' $ encodeSigned secret' 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 secret' $ encodeSigned secret' 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 secret' $ encodeSigned secret' 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' = HMACSecret secretKey + jwt = decodeAndVerifySignature secret' $ encodeSigned secret' cs Just cs @=? fmap claims jwt prop_stringOrURIProp = f @@ -213,18 +213,18 @@ 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) 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 (HMACSecret binary) 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 key $ encodeSigned key claims') in claims verified == claims' @@ -239,7 +239,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 cs let (Just claims') = fmap claims mJwt cs @=? claims' Just now @=? fmap secondsSinceEpoch (iat claims')