diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,10 @@ +2015-01-19 0.5.3 +================ + + * Add the missing `other-modules` field to the .cabal file so that + all the tests are present in the source distribution. Thanks to + Richard Wallace for reporting this. + 2015-01-17 0.5.2 ================ 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.5.2 +version: 0.5.3 synopsis: JSON Web Token (JWT) decoding and encoding license: MIT license-file: LICENSE @@ -68,6 +68,8 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: TestRunner.hs + -- Make sure the tests are listed here so that they will be part of the source distribution + other-modules: Web.Base64Tests, Web.JWTInteropTests, Web.JWTTests, Data.Text.AdditionsTests hs-source-dirs: tests/src, src build-depends: base < 5 && >= 4.4 , tasty >= 0.7 diff --git a/tests/src/Data/Text/AdditionsTests.hs b/tests/src/Data/Text/AdditionsTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/Data/Text/AdditionsTests.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.Text.AdditionsTests + ( + main + , defaultTestGroup +) where + +import Control.Applicative +import Data.String (fromString) +import qualified Data.Text as T +import Data.Text.Additions +import qualified Test.QuickCheck as QC +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.TH + +defaultTestGroup :: TestTree +defaultTestGroup = $(testGroupGenerator) + +main :: IO () +main = defaultMain defaultTestGroup + +prop_constTimeCompare :: T.Text -> T.Text -> Bool +prop_constTimeCompare a b = (a == b) == (a `constTimeCompare` b) + +instance Arbitrary T.Text where + arbitrary = fromString <$> (arbitrary :: QC.Gen String) + 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/JWTInteropTests.hs b/tests/src/Web/JWTInteropTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/Web/JWTInteropTests.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-| +Tests that verify that the shape of the JSON used is matching the spec. + +It's not sufficient to just ensure that + +`fromJSON . toJSON = id` + +This would only verify that an isomorphism exists but wouldn't tests the specific shape we expect. + +While the above would be sufficent if the haskell-jwt library would be used on the sender and receiver side, +interoperability couldn't be guaranteed. We need to ensure that the JSON conforms to the spec so that every +JWT compliant library can decode it. +-} +module Web.JWTInteropTests ( + main + , defaultTestGroup +) 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 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 + +defaultTestGroup :: TestTree +defaultTestGroup = $(testGroupGenerator) + +main :: IO () +main = defaultMain defaultTestGroup + +prop_encode_decode_jti :: JWTClaimsSet -> Bool +prop_encode_decode_jti = shouldBeMaybeStringOrUri "jti" jti + +prop_encode_decode_sub :: JWTClaimsSet -> Bool +prop_encode_decode_sub = shouldBeMaybeStringOrUri "sub" sub + +prop_encode_decode_iss :: JWTClaimsSet -> Bool +prop_encode_decode_iss = shouldBeMaybeStringOrUri "iss" iss + +shouldBeMaybeStringOrUri key' f claims' = + let json = toJSON claims' ^? key key' + in json == (fmap (String . stringOrURIToText) $ f claims') + +prop_encode_decode_aud :: JWTClaimsSet -> Bool +prop_encode_decode_aud claims' = + let json = toJSON claims' ^? key "aud" + in json == (case aud claims' of + Just (Left s) -> Just $ String $ stringOrURIToText s -- aud is just a single element + Just (Right xs) -> Just $ Array $ fmap (String . stringOrURIToText) $ Vector.fromList xs -- aud is a list of elements + Nothing -> Nothing -- aud is absent + ) + +instance Arbitrary JWTClaimsSet where + arbitrary = JWTClaimsSet <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +type ClaimsMap = Map.Map T.Text Value +instance Arbitrary ClaimsMap where + arbitrary = return Map.empty + +instance Arbitrary IntDate where + arbitrary = fmap (f . intDate) (arbitrary :: QC.Gen NominalDiffTime) + where f = fromMaybe (fromJust $ intDate 1) + +instance Arbitrary NominalDiffTime where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +instance Arbitrary StringOrURI where + arbitrary = fmap (f . stringOrURI) (arbitrary :: QC.Gen T.Text) + where + f = fromMaybe (fromJust $ stringOrURI "http://example.com") + +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 new file mode 100644 --- /dev/null +++ b/tests/src/Web/JWTTests.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +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 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 +defaultTestGroup = $(testGroupGenerator) + +main :: IO () +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_intDateDeriveOrd = do + let i1 = intDate 1231231231 -- Tue 6 Jan 2009 19:40:31 AEDT + i2 = intDate 1231232231 -- Tue 6 Jan 2009 19:57:11 AEDT + LT @=? i1 `compare` i2 + + +case_decodeJWT = do + -- Generated with ruby-jwt + let input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" + mJwt = decode input + True @=? isJust mJwt + True @=? isJust (fmap signature mJwt) + let (Just unverified) = mJwt + Just HS256 @=? alg (header unverified) + Just "payload" @=? Map.lookup "some" (unregisteredClaims $ claims unverified) + +case_verify = do + -- Generated with ruby-jwt + let input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" + mVerified = verify (secret "secret") =<< decode input + True @=? isJust mVerified + +case_decodeAndVerifyJWT = do + -- Generated with ruby-jwt + let input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" + mJwt = decodeAndVerifySignature (secret "secret") input + True @=? isJust mJwt + let (Just verified) = mJwt + Just HS256 @=? alg (header verified) + Just "payload" @=? Map.lookup "some" (unregisteredClaims $ claims verified) + +case_decodeAndVerifyJWTFailing = do + -- Generated with ruby-jwt, modified to be invalid + let input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2u" + mJwt = decodeAndVerifySignature (secret "secret") input + False @=? isJust mJwt + +case_decodeInvalidInput = do + let inputs = ["", "a.", "a.b"] + result = map decode inputs + True @=? all isNothing result + +case_decodeAndVerifySignatureInvalidInput = do + let inputs = ["", "a.", "a.b"] + result = map (decodeAndVerifySignature (secret "secret")) inputs + True @=? all isNothing result + +case_encodeJWTNoMac = do + let cs = def { + iss = stringOrURI "Foo" + , unregisteredClaims = 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 + --
.. + let (h:c:s:_) = T.splitOn "." jwt + False @=? T.null h + False @=? T.null c + True @=? T.null s + + +case_encodeDecodeJWTNoMac = do + let cs = def { + iss = stringOrURI "Foo" + , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)] + } + mJwt = decode $ encodeUnsigned cs + True @=? isJust mJwt + let (Just unverified) = mJwt + cs @=? claims unverified + +case_encodeDecodeJWT = do + let now = 1394573404 + cs = def { + iss = stringOrURI "Foo" + , iat = intDate now + , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)] + } + key = secret "secret-key" + mJwt = decode $ encodeSigned HS256 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 { + iss = iss' + , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)] + } + key = secret "secret-key" + t = encodeSigned HS256 key cs + iss' @=? tokenIssuer t + +case_encodeDecodeJWTClaimsSetCustomClaims = do + let now = 1234 + cs = def { + iss = stringOrURI "Foo" + , iat = intDate now + , unregisteredClaims = Map.fromList [("http://example.com/is_root", Bool True)] + } + let secret' = secret "secret" + jwt = decodeAndVerifySignature secret' $ encodeSigned HS256 secret' cs + Just cs @=? fmap claims jwt + +case_encodeDecodeJWTClaimsSetWithSingleAud = do + let now = 1234 + cs = def { + iss = stringOrURI "Foo" + , aud = Left <$> stringOrURI "single-audience" + , iat = intDate now + } + let secret' = secret "secret" + jwt = decodeAndVerifySignature secret' $ encodeSigned HS256 secret' cs + Just cs @=? fmap claims jwt + +case_encodeDecodeJWTClaimsSetWithMultipleAud = do + let now = 1234 + cs = def { + iss = stringOrURI "Foo" + , aud = Right <$> (:[]) <$> stringOrURI "audience" + , iat = intDate now + } + let secret' = secret "secret" + jwt = decodeAndVerifySignature secret' $ encodeSigned HS256 secret' cs + Just cs @=? fmap claims jwt + +prop_stringOrURIProp = f + where f :: StringOrURI -> Bool + f sou = let s = stringOrURI $ T.pack $ show sou + in Just sou == s + +prop_stringOrURIToText= f + where f :: T.Text -> Bool + f t = let mSou = stringOrURI t + in case mSou of + Just sou -> stringOrURIToText sou == t + Nothing -> True + +prop_encode_decode_prop = f + where f :: JWTClaimsSet -> Bool + f claims' = let Just unverified = (decode $ encodeSigned HS256 (secret "secret") claims') + in claims unverified == claims' + +prop_encode_decode_verify_signature_prop = f + where f :: JWTClaimsSet -> Bool + f claims' = let key = secret "secret" + Just verified = (decodeAndVerifySignature key $ encodeSigned HS256 key claims') + in claims verified == claims' + + +instance Arbitrary JWTClaimsSet where + arbitrary = JWTClaimsSet <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +type ClaimsMap = Map.Map T.Text Value +instance Arbitrary ClaimsMap where + arbitrary = return Map.empty + +instance Arbitrary IntDate where + arbitrary = fmap (f . intDate) (arbitrary :: QC.Gen NominalDiffTime) + where f = fromMaybe (fromJust $ intDate 1) + +instance Arbitrary NominalDiffTime where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +instance Arbitrary StringOrURI where + arbitrary = fmap (f . stringOrURI) (arbitrary :: QC.Gen T.Text) + where + f = fromMaybe (fromJust $ stringOrURI "http://example.com") + +instance Arbitrary T.Text where + arbitrary = fromString <$> (arbitrary :: QC.Gen String) + +instance Arbitrary TL.Text where + arbitrary = fromString <$> (arbitrary :: QC.Gen String)