diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# Haskell JSON Web Token (JWT) + +JSON Web Token (JWT) is a compact URL-safe means of representing claims to be transferred between two parties. + +From http://self-issued.info/docs/draft-ietf-oauth-json-web-token.html + +> JSON Web Token (JWT) is a compact URL-safe means of representing claims to be transferred +> between two parties. The claims in a JWT are encoded as a JavaScript Object Notation (JSON) +> object that is used as the payload of a JSON Web Signature (JWS) structure or as the plaintext +> 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. + + diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,14 @@ +2014-03-10 0.2.0 +================= + + * Export the IntDate and StringOrURI types #5a1137b + +2014-03-03 0.1.1 +================= + + * Verify that invalid input to the decode* functions fails as expected + +2014-03-03 0.1.0 +================= + + * Initial release 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.1.1 +version: 0.2.0 synopsis: JSON Web Token (JWT) decoding and encoding license: MIT license-file: LICENSE @@ -19,12 +19,18 @@ . To get started, see the documentation for the "Web.JWT" module. +extra-source-files: + changelog + README.md + source-repository head type: git location: https://ssaasen@bitbucket.org/ssaasen/haskell-jwt.git + library exposed-modules: Web.JWT + other-modules: Web.Base64 build-depends: base >= 4.6 && < 4.7 , cryptohash >= 0.11 , base64-bytestring >= 1.0 @@ -37,6 +43,7 @@ , data-default >= 0.5 , http-types >= 0.8 , network >= 2.4 + , time >= 1.1 hs-source-dirs: src default-language: Haskell2010 @@ -50,7 +57,7 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: TestRunner.hs - other-modules: Web.JWTTests + other-modules: Web.JWTTests, Web.Base64Tests hs-source-dirs: tests/src, src build-depends: base < 5 && >= 4.4 , tasty >= 0.7 @@ -71,5 +78,6 @@ , data-default , http-types , network + , time >= 1.1 cpp-options: -DTEST diff --git a/src/Web/Base64.hs b/src/Web/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Web/Base64.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Web.Base64 ( + base64Encode + , base64Encode' + , base64Decode + , removePaddingBase64Encoding +) where + + +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Base64.URL as BASE64 + +base64Decode :: T.Text -> T.Text +base64Decode = operateOnText BASE64.decodeLenient + +base64Encode :: T.Text -> T.Text +base64Encode = removePaddingBase64Encoding . operateOnText BASE64.encode + +base64Encode' :: B.ByteString -> T.Text +base64Encode' = removePaddingBase64Encoding . TE.decodeUtf8 . BASE64.encode + +removePaddingBase64Encoding :: T.Text -> T.Text +removePaddingBase64Encoding = T.dropWhileEnd (=='=') + + +operateOnText :: (B.ByteString -> B.ByteString) -> T.Text -> T.Text +operateOnText f = TE.decodeUtf8 . f . TE.encodeUtf8 diff --git a/src/Web/JWT.hs b/src/Web/JWT.hs --- a/src/Web/JWT.hs +++ b/src/Web/JWT.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} - --- TODO: --- * StringOrUri is not valdiated +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} {-| Module: Web.JWT @@ -35,12 +33,20 @@ , encodeUnsigned -- * Utility functions + -- ** Common , tokenIssuer , secret + -- ** JWT structure , claims , header , signature - , module Data.Default + -- ** JWT claims set + , intDate + , stringOrURI + -- ** JWT header + , typ + , cty + , alg -- * Types , UnverifiedJWT @@ -51,16 +57,13 @@ , JSON , Algorithm(..) , JWTClaimsSet(..) + , IntDate + , StringOrURI + , JWTHeader -#ifdef TEST - , IntDate(..) - , JWTHeader(..) - , base64Encode - , base64Decode -#endif + , module Data.Default ) where -import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL (fromStrict, toStrict) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -71,12 +74,14 @@ import qualified Crypto.MAC.HMAC as HMAC import Data.Aeson hiding (decode, encode) import qualified Data.Aeson as JSON -import qualified Data.ByteString.Base64.URL as BASE64 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 Web.Base64 import Prelude hiding (exp) @@ -118,15 +123,39 @@ -- | A JSON numeric value representing the number of seconds from -- 1970-01-01T0:0:0Z UTC until the specified UTC date/time. -newtype IntDate = IntDate Integer deriving (Eq, Show) +newtype IntDate = IntDate Integer deriving (Show, Eq) + +-- | A JSON string value, with the additional requirement that while +-- arbitrary string values MAY be used, any value containing a ":" +-- character MUST be a URI [RFC3986]. StringOrURI values are +-- compared as case-sensitive strings with no transformations or +-- canonicalizations applied. +data StringOrURI = S T.Text | U URI.URI deriving (Eq) + +instance Show StringOrURI where + show (S s) = T.unpack s + show (U u) = show u + + data Algorithm = HS256 -- ^ HMAC using SHA-256 hash algorithm deriving (Eq, Show) -- | JWT Header, describes the cryptographic operations applied to the JWT data JWTHeader = JWTHeader { + -- | The typ (type) Header Parameter defined by [JWS] and [JWE] is used to + -- declare the MIME Media Type [IANA.MediaTypes] of this complete JWT in + -- contexts where this is useful to the application. + -- This parameter has no effect upon the JWT processing. typ :: Maybe T.Text + -- | 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. + -- + -- See , alg :: Maybe Algorithm } deriving (Eq, Show) @@ -139,13 +168,13 @@ -- http://self-issued.info/docs/draft-ietf-oauth-json-web-token.html#ClaimsContents -- | The iss (issuer) claim identifies the principal that issued the JWT. - iss :: Maybe T.Text + iss :: Maybe StringOrURI -- | The sub (subject) claim identifies the principal that is the subject of the JWT. - , sub :: Maybe T.Text + , sub :: Maybe StringOrURI -- | The aud (audience) claim identifies the audiences that the JWT is intended for - , aud :: Maybe T.Text + , aud :: Maybe StringOrURI -- | The exp (expiration time) claim identifies the expiration time on or after which the JWT MUST NOT be accepted for processing. Its value MUST be a number containing an IntDate value. , exp :: Maybe IntDate @@ -157,11 +186,11 @@ , iat :: Maybe IntDate -- | The jti (JWT ID) claim provides a unique identifier for the JWT. - , jti :: Maybe T.Text + , jti :: Maybe StringOrURI , unregisteredClaims :: ClaimsMap -} deriving (Eq, Show) +} deriving (Show, Eq) instance Default JWTClaimsSet where @@ -171,9 +200,11 @@ -- | Encode a claims set using the given secret -- -- > {-# LANGUAGE OverloadedStrings #-} +-- > import Data.Aeson +-- > import qualified Data.Map as Map -- > -- > let cs = def { -- def returns a default JWTClaimsSet --- > iss = Just "Foo" +-- > iss = stringOrURI "Foo" -- > , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))] -- > } -- > key = secret "secret-key" @@ -195,9 +226,11 @@ -- | Encode a claims set without signing it -- -- > {-# LANGUAGE OverloadedStrings #-} +-- > import Data.Aeson +-- > import qualified Data.Map as Map -- > -- > let cs = def { -- def returns a default JWTClaimsSet --- > iss = Just "Foo" +-- > iss = stringOrURI "Foo" -- > , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))] -- > } -- > jwt = encodeUnsigned cs @@ -255,7 +288,7 @@ -- | Decode a claims set and verify that the signature matches by using the supplied secret. --- The algorithm is based on the supplied header value. +-- The algorithm is based on the supplied header value. -- -- This will return a VerifiedJWT if and only if the signature can be verified -- using the given secret. @@ -293,7 +326,7 @@ extractElems _ = Nothing -- | Try to extract the value for the issue claim field 'iss' from the web token in JSON form -tokenIssuer :: JSON -> Maybe T.Text +tokenIssuer :: JSON -> Maybe StringOrURI tokenIssuer = decode >=> fmap pure claims >=> iss -- | Create a Secret using the given key @@ -303,6 +336,20 @@ secret :: T.Text -> Secret secret = Secret +-- | 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). +intDate :: NominalDiffTime -> Maybe IntDate +intDate i | i < 0 = Nothing +intDate i = Just $ IntDate $ round 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 +-- *not* a valid URI). +stringOrURI :: T.Text -> Maybe StringOrURI +stringOrURI t | URI.isURI $ T.unpack t = U <$> (URI.parseURI $ T.unpack t) +stringOrURI t = Just (S t) + -- ================================================================================= encodeJWT :: ToJSON a => a -> T.Text @@ -317,23 +364,9 @@ -- ================================================================================= - -base64Decode :: T.Text -> T.Text -base64Decode = operateOnText BASE64.decodeLenient - -base64Encode :: T.Text -> T.Text -base64Encode = removePaddingBase64Encoding . operateOnText BASE64.encode - -operateOnText :: (B.ByteString -> B.ByteString) -> T.Text -> T.Text -operateOnText f = TE.decodeUtf8 . f . TE.encodeUtf8 - -removePaddingBase64Encoding :: T.Text -> T.Text -removePaddingBase64Encoding = T.dropWhileEnd (=='=') - calculateDigest :: Algorithm -> Secret -> T.Text -> T.Text calculateDigest _ (Secret key) msg = base64Encode' $ HMAC.hmac SHA.hash 64 (bs key) (bs msg) where bs = TE.encodeUtf8 - base64Encode' = removePaddingBase64Encoding . TE.decodeUtf8 . BASE64.encode -- ================================================================================= @@ -387,7 +420,7 @@ ] instance ToJSON IntDate where - toJSON (IntDate ts) = Number $ scientific (fromIntegral ts) 0 + toJSON (IntDate i) = Number $ scientific (fromIntegral i) 0 instance FromJSON IntDate where parseJSON (Number x) = return $ IntDate $ coefficient x @@ -399,3 +432,14 @@ instance FromJSON Algorithm where parseJSON (String "HS256") = return HS256 parseJSON _ = mzero + +instance ToJSON StringOrURI where + toJSON (S s) = String s + toJSON (U uri) = String $ T.pack $ URI.uriToString id uri "" + +instance FromJSON StringOrURI where + 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 + + diff --git a/tests/src/TestRunner.hs b/tests/src/TestRunner.hs --- a/tests/src/TestRunner.hs +++ b/tests/src/TestRunner.hs @@ -1,6 +1,7 @@ module Main where import qualified Web.JWTTests +import qualified Web.Base64Tests import Test.Tasty main :: IO () @@ -9,5 +10,6 @@ tests :: TestTree tests = testGroup "JWT Tests" [ Web.JWTTests.defaultTestGroup + , Web.Base64Tests.defaultTestGroup ] diff --git a/tests/src/Web/Base64Tests.hs b/tests/src/Web/Base64Tests.hs new file mode 100644 --- /dev/null +++ b/tests/src/Web/Base64Tests.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +module Web.Base64Tests + ( + 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 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 Web.Base64 + +defaultTestGroup :: TestTree +defaultTestGroup = $(testGroupGenerator) + +main :: IO () +main = defaultMain defaultTestGroup + + + +case_base64EncodeString = do + let header = "{\"typ\":\"JWT\",\r\n \"alg\":\"HS256\"}" + "eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9" @=? base64Encode header + +case_base64EncodeStringNoPadding = do + let header = "sdjkfhaks jdhfak sjldhfa lkjsdf" + "c2Rqa2ZoYWtzIGpkaGZhayBzamxkaGZhIGxranNkZg" @=? base64Encode header + +case_base64EncodeDecodeStringNoPadding = do + let header = "sdjkfhaks jdhfak sjldhfa lkjsdf" + header @=? (base64Decode $ base64Encode header) + +case_base64DecodeString = do + let str = "eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9" + "{\"typ\":\"JWT\",\r\n \"alg\":\"HS256\"}" @=? base64Decode str + +prop_base64_encode_decode = f + where f :: T.Text -> Bool + f input = (base64Decode $ base64Encode input) == input + + +instance Arbitrary T.Text where + arbitrary = fromString <$> (arbitrary :: QC.Gen String) + +instance Arbitrary TL.Text where + arbitrary = fromString <$> (arbitrary :: QC.Gen String) 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 @@ -16,8 +16,11 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Aeson.Types +import qualified Data.Aeson as JSON import Data.Maybe import Data.String (fromString, IsString) +import Data.Time + import Web.JWT defaultTestGroup :: TestTree @@ -27,6 +30,17 @@ main = defaultMain defaultTestGroup + +case_stringOrURIString = do + let str = "foo bar baz 2312j!@&^#^*!(*@" + sou = stringOrURI str + (Just str) @=? (fmap (T.pack . show) sou) + +case_stringOrURI= do + let str = "http://user@example.com:8900/foo/bar?baz=t;" + sou = stringOrURI str + (Just str) @=? (fmap (T.pack . show) sou) + case_decodeJWT = do -- Generated with ruby-jwt let input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" @@ -64,7 +78,7 @@ case_encodeJWTNoMac = do let cs = def { - iss = Just "Foo" + iss = stringOrURI "Foo" , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))] } jwt = encodeUnsigned cs @@ -73,7 +87,7 @@ case_encodeDecodeJWTNoMac = do let cs = def { - iss = Just "Foo" + iss = stringOrURI "Foo" , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))] } mJwt = decode $ encodeUnsigned cs @@ -83,7 +97,7 @@ case_encodeDecodeJWT = do let cs = def { - iss = Just "Foo" + iss = stringOrURI "Foo" , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))] } key = secret "secret-key" @@ -93,49 +107,38 @@ cs @=? claims unverified case_tokenIssuer = do - let cs = def { - iss = Just "Foo" + let iss' = stringOrURI "Foo" + cs = def { + iss = iss' , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))] } key = secret "secret-key" t = encodeSigned HS256 key cs - Just "Foo" @=? tokenIssuer t + iss' @=? tokenIssuer t case_encodeJWTClaimsSet = do let cs = def { - iss = Just "Foo" + iss = stringOrURI "Foo" } -- This is a valid JWT string that can be decoded with the given secret using the ruby JWT library "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJpc3MiOiJGb28ifQ.dfhkuexBONtkewFjLNz9mZlFc82GvRkaZKD8Pd53zJ8" @=? encodeSigned HS256 (secret "secret") cs case_encodeJWTClaimsSetCustomClaims = do - let cs = def { - iss = Just "Foo" + let now = 1234 + cs = def { + iss = stringOrURI "Foo" + , iat = intDate now , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))] } -- The expected string can be decoded using the ruby-jwt library - "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJodHRwOi8vZXhhbXBsZS5jb20vaXNfcm9vdCI6dHJ1ZSwiaXNzIjoiRm9vIn0.UVp4TIg8-OmY_vNHbyxMPx7v0P6jCY4rqYVWVcjdXQk" @=? encodeSigned HS256 (secret "secret") cs + "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJpYXQiOjEyMzQsImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlLCJpc3MiOiJGb28ifQ.F3VCSxBBnY2caX4AH4GvIHyTVUhOnJF9Av_G_N4m710" @=? encodeSigned HS256 (secret "secret") cs -case_base64EncodeString = do - let header = "{\"typ\":\"JWT\",\r\n \"alg\":\"HS256\"}" - "eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9" @=? base64Encode header -case_base64EncodeStringNoPadding = do - let header = "sdjkfhaks jdhfak sjldhfa lkjsdf" - "c2Rqa2ZoYWtzIGpkaGZhayBzamxkaGZhIGxranNkZg" @=? base64Encode header - -case_base64EncodeDecodeStringNoPadding = do - let header = "sdjkfhaks jdhfak sjldhfa lkjsdf" - header @=? (base64Decode $ base64Encode header) - -case_base64DecodeString = do - let str = "eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9" - "{\"typ\":\"JWT\",\r\n \"alg\":\"HS256\"}" @=? base64Decode str - -prop_base64_encode_decode = f - where f :: T.Text -> Bool - f input = (base64Decode $ base64Encode input) == input +prop_stringOrURIProp = f + where f :: StringOrURI -> Bool + f sou = let s = stringOrURI $ T.pack $ show sou + in (Just sou) == s prop_encode_decode_prop = f where f :: JWTClaimsSet -> Bool @@ -164,7 +167,17 @@ arbitrary = return Map.empty instance Arbitrary IntDate where - arbitrary = IntDate <$> (arbitrary :: QC.Gen Integer) + arbitrary = fmap (f . intDate) (arbitrary :: QC.Gen NominalDiffTime) + where f mIntDate = fromMaybe (fromJust $ intDate 1) mIntDate + +instance Arbitrary NominalDiffTime where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +instance Arbitrary StringOrURI where + arbitrary = fmap (f . stringOrURI) (arbitrary :: QC.Gen T.Text) + where + f mSou = fromMaybe (fromJust $ stringOrURI "http://example.com") mSou instance Arbitrary T.Text where arbitrary = fromString <$> (arbitrary :: QC.Gen String)