diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,11 @@ +2015-01-17 0.5.2 +================ + + * Tim McLean pointed out that comparing signatures may be susceptible to + a timing attack in the way the signatures were compared (using the default + Eq instance). Both `Signature` and `Secret` now have an `Eq` instance that + uses a constant time comparison function. Thanks Tim for reporting this. + 2015-01-03 0.5.1 ================ 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.1 +version: 0.5.2 synopsis: JSON Web Token (JWT) decoding and encoding license: MIT license-file: LICENSE @@ -33,7 +33,7 @@ library exposed-modules: Web.JWT - other-modules: Web.Base64 + other-modules: Web.Base64, Data.Text.Additions build-depends: base >= 4.6 && < 4.8 , cryptohash >= 0.11 , base64-bytestring >= 1.0 @@ -68,7 +68,6 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: TestRunner.hs - other-modules: Web.JWTTests, Web.Base64Tests hs-source-dirs: tests/src, src build-depends: base < 5 && >= 4.4 , tasty >= 0.7 diff --git a/src/Data/Text/Additions.hs b/src/Data/Text/Additions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Additions.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Text.Additions ( + constTimeCompare +) where + +import Control.Applicative ((<$>)) +import Data.Bits +import Data.Char +import Data.Function (on) +import Data.List (foldl') +import qualified Data.Text as T + +constTimeCompare :: T.Text -> T.Text -> Bool +constTimeCompare l r = T.length l == T.length r && comp' l r + where + comp' a b = 0 == foldl' (.|.) 0 (uncurry (on xor ord) <$> T.zip a b) diff --git a/src/Web/JWT.hs b/src/Web/JWT.hs --- a/src/Web/JWT.hs +++ b/src/Web/JWT.hs @@ -77,6 +77,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL (fromStrict, toStrict) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import qualified Data.Text.Additions as TA import Control.Applicative import Control.Monad @@ -98,9 +99,18 @@ type JSON = T.Text -- | The secret used for calculating the message signature -newtype Secret = Secret T.Text deriving (Eq, Show) +newtype Secret = Secret T.Text -newtype Signature = Signature T.Text deriving (Eq, Show) +instance Eq Secret where + (Secret s1) == (Secret s2) = s1 `TA.constTimeCompare` s2 + +instance Show Secret where + show _ = "" + +newtype Signature = Signature T.Text deriving (Show) + +instance Eq Signature where + (Signature s1) == (Signature s2) = s1 `TA.constTimeCompare` s2 -- | JSON Web Token without signature verification data UnverifiedJWT diff --git a/tests/src/TestRunner.hs b/tests/src/TestRunner.hs --- a/tests/src/TestRunner.hs +++ b/tests/src/TestRunner.hs @@ -3,6 +3,7 @@ import qualified Web.JWTTests import qualified Web.JWTInteropTests import qualified Web.Base64Tests +import qualified Data.Text.AdditionsTests import Test.Tasty main :: IO () @@ -13,5 +14,6 @@ Web.JWTTests.defaultTestGroup , Web.JWTInteropTests.defaultTestGroup , Web.Base64Tests.defaultTestGroup + , Data.Text.AdditionsTests.defaultTestGroup ] diff --git a/tests/src/Web/Base64Tests.hs b/tests/src/Web/Base64Tests.hs deleted file mode 100644 --- a/tests/src/Web/Base64Tests.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/src/Web/JWTTests.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# 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)