diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# 2026-09-26 0.12.0 + +* Fix bug where fractional NumericDate's were being parsed incorrectly. + [#4](https://github.com/puffnfresh/haskell-jwt/issues/4). +* Pull updates in cryptostore, fixing build with crypton. +* Stabilize ordering of keys, both in the header and in claims, resolving + [#2](https://github.com/puffnfresh/haskell-jwt/issues/2). +* Fix and reenable doctests. +* Drop support for aeson < 2. + # 2021-12-11 0.11.0 * Added support for RSA256 Public Key verification. This in turn means that some diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,6 +11,3 @@ > and/or encrypted. See the [Web.JWT module](http://hackage.haskell.org/package/jwt/docs/Web-JWT.html) documentation to get started. - -[![Build -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,4 +1,7 @@ -import Test.DocTest +import System.Exit (exitWith) +import System.Process (system) main :: IO () -main = doctest ["-isrc", "src"] +main = do + exitWith =<< system "cabal repl --with-ghc=doctest" + -- See README of doctest https://hackage.haskell.org/package/doctest diff --git a/jwt.cabal b/jwt.cabal --- a/jwt.cabal +++ b/jwt.cabal @@ -2,17 +2,17 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: jwt -version: 0.11.0 +version: 0.12.0 synopsis: JSON Web Token (JWT) decoding and encoding license: MIT license-file: LICENSE author: Brian McKenna maintainer: brian@brianmckenna.org -homepage: https://bitbucket.org/puffnfresh/haskell-jwt -bug-reports: https://bitbucket.org/puffnfresh/haskell-jwt/issues +homepage: https://github.com/puffnfresh/haskell-jwt +bug-reports: https://github.com/puffnfresh/haskell-jwt/issues category: Web build-type: Simple -cabal-version: >=1.16 +cabal-version: 1.16 description: JSON Web Token (JWT) is a compact URL-safe means of representing claims to be transferred between two parties. @@ -27,28 +27,39 @@ source-repository head type: git - location: https://bitbucket.org/puffnfresh/haskell-jwt.git + location: https://github.com/puffnfresh/haskell-jwt.git +-- Drop this when cryptostore does +flag use_crypton + description: Use crypton instead of cryptonite + manual: True + default: False + library exposed-modules: Web.JWT other-modules: Data.Text.Extended, Data.ByteString.Extended build-depends: base >= 4.8 && < 5 - , cryptonite >= 0.6 - , cryptostore >= 0.2 - , memory >= 0.8 - , bytestring >= 0.10 - , text >= 0.11 - , aeson >= 0.7 - , containers >= 0.5 - , unordered-containers >= 0.2 - , scientific >= 0.2 - , http-types >= 0.8 - , time >= 1.1 - , vector >= 0.7.1 - , semigroups >= 0.15.4 - , network-uri - , x509 - , x509-store + , cryptostore >= 0.5.0.0 && < 0.6 + , memory >= 0.8 && < 0.19 + , bytestring >= 0.10 && < 0.13 + , text >= 0.11 && < 2.2 + , aeson >= 2 && < 2.4 + , containers >= 0.5 && < 0.9 + , unordered-containers >= 0.2 && < 0.3 + , scientific >= 0.2 && < 0.4 + , http-types >= 0.8 && < 0.13 + , time >= 1.1 && < 1.17 + , vector >= 0.7.1 && < 0.14 + , semigroups >= 0.15.4 && < 0.21 + , network-uri >= 2.6 && < 2.7 + if flag(use_crypton) + build-depends: crypton >= 0.31 && < 2.2 + , crypton-x509 < 1.10 + , crypton-x509-store < 1.10 + else + build-depends: cryptonite >= 0.6 && < 0.31 + , x509 < 1.8 + , x509-store < 1.7 hs-source-dirs: src default-language: Haskell2010 @@ -81,12 +92,11 @@ , lens , HUnit , QuickCheck >= 2.4.0.1 - , cryptonite , cryptostore , memory , bytestring >= 0.10 , text >= 0.11 - , aeson + , aeson >= 2 , scientific >= 0.2 , containers , unordered-containers @@ -95,6 +105,12 @@ , vector >= 0.7.1 , semigroups >= 0.15.4 , network-uri + if flag(use_crypton) + build-depends: crypton + , crypton-x509 + , crypton-x509-store + else + build-depends: cryptonite , x509 , x509-store @@ -108,3 +124,4 @@ build-depends: base < 5 && >= 4.8 , jwt , doctest >= 0.20 + , process diff --git a/src/Web/JWT.hs b/src/Web/JWT.hs --- a/src/Web/JWT.hs +++ b/src/Web/JWT.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -93,6 +92,8 @@ import Data.ByteArray.Encoding import Data.Aeson hiding (decode, encode) import qualified Data.Aeson as JSON +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Map as Map import Data.Maybe import Data.Scientific @@ -103,13 +104,6 @@ import qualified Network.URI as URI import Prelude hiding (exp) -#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 @@ -161,12 +155,16 @@ -- | A JSON numeric value representing the number of seconds from -- 1970-01-01T0:0:0Z UTC until the specified UTC date/time. -newtype NumericDate = NumericDate Integer deriving (Show, Eq, Ord) - +-- +-- Per RFC 7519 section 2, may be fractional. +newtype NumericDate = NumericDate Scientific deriving (Show, Eq, Ord) --- | Return the seconds since 1970-01-01T0:0:0Z UTC for the given 'IntDate' +-- | Convert the given 'NumericDate' into seconds since 1970-01-01T0:0:0Z. +-- +-- >>> secondsSinceEpoch $ NumericDate 1777605333.111222 +-- 1777605333.111222s secondsSinceEpoch :: NumericDate -> NominalDiffTime -secondsSinceEpoch (NumericDate s) = fromInteger s +secondsSinceEpoch (NumericDate s) = realToFrac s -- | A JSON string value, with the additional requirement that while -- arbitrary string values MAY be used, any value containing a ":" @@ -268,7 +266,7 @@ -- key = hmacSecret . T.pack $ "secret-key" -- in encodeSigned key mempty cs -- :} --- "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJodHRwOi8vZXhhbXBsZS5jb20vaXNfcm9vdCI6dHJ1ZSwiaXNzIjoiRm9vIn0.vHQHuG3ujbnBUmEp-fSUtYxk27rLiP2hrNhxpyWhb2E" +-- "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJpc3MiOiJGb28iLCJodHRwOi8vZXhhbXBsZS5jb20vaXNfcm9vdCI6dHJ1ZX0.9uim_nuzFyiZ3qqJrzZRieGTOLRNOYlYvmhrqg8KYfQ" encodeSigned :: EncodeSigner -> JOSEHeader -> JWTClaimsSet -> T.Text encodeSigned signer header' claims' = dotted [header'', claim, signature'] where claim = encodeJWT claims' @@ -292,7 +290,7 @@ -- } -- in encodeUnsigned cs mempty -- :} --- "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJpYXQiOjEzOTQ3MDA5MzQsImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlLCJpc3MiOiJGb28ifQ." +-- "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJpc3MiOiJGb28iLCJpYXQiOjEzOTQ3MDA5MzQsImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ." encodeUnsigned :: JWTClaimsSet -> JOSEHeader -> T.Text encodeUnsigned claims' header' = dotted [header'', claim, ""] where claim = encodeJWT claims' @@ -471,11 +469,10 @@ intDate = numericDate -- | Convert the `NominalDiffTime` into an NumericDate. Returns a Nothing if the --- argument is invalid (e.g. the NominalDiffTime must be convertible into a --- positive Integer representing the seconds since epoch). +-- argument is invalid (e.g. negative NominalDiffTime). numericDate :: NominalDiffTime -> Maybe NumericDate numericDate i | i < 0 = Nothing -numericDate i = Just $ NumericDate $ round i +numericDate i = Just $ NumericDate $ normalize $ realToFrac i -- | Convert a `T.Text` into a 'StringOrURI`. Returns a Nothing if the -- String cannot be converted (e.g. if the String contains a ':' but is @@ -555,13 +552,7 @@ ClaimsMap $ a Semigroup.<> b fromHashMap :: Object -> ClaimsMap -fromHashMap = ClaimsMap . Map.fromList . map (first toText) . KeyMap.toList - where -#if MIN_VERSION_aeson(2,0,0) - toText = Key.toText -#else - toText = id -#endif +fromHashMap = ClaimsMap . Map.fromList . map (first Key.toText) . KeyMap.toList removeRegisteredClaims :: ClaimsMap -> ClaimsMap removeRegisteredClaims (ClaimsMap input) = ClaimsMap $ Map.differenceWithKey (\_ _ _ -> Nothing) input registeredClaims @@ -577,13 +568,19 @@ , fmap ("nbf" .=) nbf , fmap ("iat" .=) iat , fmap ("jti" .=) jti - ] ++ map (first fromText) (Map.toList $ unClaimsMap $ removeRegisteredClaims unregisteredClaims) - where -#if MIN_VERSION_aeson(2,0,0) - fromText = Key.fromText -#else - fromText = id -#endif + ] ++ map (first Key.fromText) + (Map.toList $ unClaimsMap $ removeRegisteredClaims unregisteredClaims) + -- See [NOTE] Encoding VS Value, and json objects keys ordering + toEncoding JWTClaimsSet{..} = pairs . mconcat $ catMaybes [ + fmap ("iss" .=) iss + , fmap ("sub" .=) sub + , either ("aud" .=) ("aud" .=) <$> aud + , fmap ("exp" .=) exp + , fmap ("nbf" .=) nbf + , fmap ("iat" .=) iat + , fmap ("jti" .=) jti + ] ++ map (uncurry (.=) . first Key.fromText) + (Map.toList $ unClaimsMap $ removeRegisteredClaims unregisteredClaims) instance FromJSON JWTClaimsSet where parseJSON = withObject "JWTClaimsSet" @@ -615,13 +612,59 @@ , fmap ("alg" .=) alg , fmap ("kid" .=) kid ] + -- See [NOTE] Encoding VS Value, and json objects keys ordering + toEncoding JOSEHeader{..} = pairs . mconcat . catMaybes $ [ + fmap ("typ" .=) typ + , fmap ("cty" .=) cty + , fmap ("alg" .=) alg + , fmap ("kid" .=) kid + ] +{- [NOTE] Encoding VS Value, and json objects keys ordering + +Unlike Encoding, aeson's Value may, and will, reorder keys. + +This can cause annoying issues, where the JWT encodings that we produce may "wobble" +across (non-breaking) updates in dependencies (particularly, in unordered-containers). + +One such issue was reported at https://github.com/puffnfresh/haskell-jwt/issues/2 . +Both encodings are technically correct and valid -- yet, this broke somebody's test +and ate people's time. + +Another occurrence manifested in doctests of this very module. There, it is especially +vexing, because doctests showcase API usage primarily (and as a bonus, double-duty as tests). +I.e. doctests are not the place to be explicitly handling multiple valid outputs +(the in-code "expected value" may validly be this, or that, depending on what exact versions +of dependencies we're compiling with), all the while exemplifying how to get any JWT output +in the first place. But, where? + +In ToJSON class, there's an optional toEncoding method that can stabilize the ordering. +-} + instance ToJSON NumericDate where - toJSON (NumericDate i) = Number $ scientific (fromIntegral i) 0 + toJSON (NumericDate i) = Number i +-- | Per the RFC, supports fractional durations. +-- +-- At the same time, exp=1e999999999 should not blow up programs. +-- +-- >>> eitherDecode "1777605333" :: Either String NumericDate +-- Right (NumericDate 1.777605333e9) +-- +-- >>> eitherDecode "1777605333.005" :: Either String NumericDate +-- Right (NumericDate 1.777605333005e9) +-- +-- >>> eitherDecode "1777605333e9999" :: Either String NumericDate +-- Left "Error in $: NumericDate too far into future" instance FromJSON NumericDate where - parseJSON (Number x) = return $ NumericDate $ coefficient x - parseJSON _ = mzero + parseJSON = withScientific "exp claim" + $ (. normalize) + $ \x -> do + -- this is withBoundedScientific; prevents huge exponent DoS. + -- 10'000 nominal years is ~3.1e11 seconds. + when (base10Exponent x > 12) $ + fail "NumericDate too far into future" + return $ NumericDate x instance ToJSON Algorithm where toJSON HS256 = String ("HS256"::T.Text) @@ -640,6 +683,9 @@ parseJSON (String s) | URI.isURI $ T.unpack s = return $ U $ fromMaybe URI.nullURI $ URI.parseURI $ T.unpack s parseJSON (String s) = return $ S s parseJSON _ = mzero + +-- $setup +-- >>> :seti -XOverloadedStrings -- $docDecoding -- There are three use cases supported by the set of decoding/verification 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 @@ -24,6 +24,7 @@ import Prelude hiding (exp) import Control.Lens +import qualified Data.Aeson.Key as Key import Data.Aeson.Lens import Data.Aeson.Types import qualified Data.Map as Map @@ -56,7 +57,7 @@ shouldBeMaybeStringOrUri :: ToJSON a => T.Text -> (a -> Maybe StringOrURI) -> a -> Bool shouldBeMaybeStringOrUri key' f claims' = - let json = toJSON claims' ^? key key' + let json = toJSON claims' ^? key (Key.fromText key') in json == (fmap (String . stringOrURIToText) $ f claims') prop_encode_decode_aud :: JWTClaimsSet -> Bool