jose 0.6.0.3 → 0.7.0.0
raw patch · 11 files changed
+343/−129 lines, 11 filesdep ~tasty-hspecnew-component:exe:jose-example
Dependency ranges changed: tasty-hspec
Files
- README.md +67/−5
- example/Main.hs +17/−19
- jose.cabal +4/−4
- src/Crypto/JOSE/JWA/JWK.hs +91/−73
- src/Crypto/JOSE/JWK.hs +11/−5
- src/Crypto/JOSE/Types.hs +43/−8
- src/Crypto/JOSE/Types/Internal.hs +9/−4
- src/Crypto/JWT.hs +50/−1
- test/JWS.hs +26/−0
- test/JWT.hs +13/−10
- test/Types.hs +12/−0
README.md view
@@ -1,6 +1,6 @@ # jose - Javascript Object Signing and Encryption & JWT (JSON Web Token) -jose is a Haskell implementation of [Javascript Object Signing and+*jose* is a Haskell implementation of [Javascript Object Signing and Encryption](https://datatracker.ietf.org/wg/jose/) and [JSON Web Token](https://tools.ietf.org/html/rfc7519). @@ -9,9 +9,71 @@ **EdDSA** signatures (RFC 8037) are supported (Ed25519 only). -The **ECDSA implementation is vulnerable to timing attacks** and-should therefore only be used for verification.- JWK Thumbprint (RFC 7638) is supported (requires *aeson* >= 0.10). -Contributions are welcome.+[Contributions](#contributing) are welcome.++## Security++If you discover a security issue in this library, please email me+the details, ideally with a proof of concept (`frase @ frase.id.au`+; [PGP key](https://pgp.mit.edu/pks/lookup?op=get&search=0x4B5390524111E1E2)).++Before reporting an issue, please note the following known+vulnerabilities:++- The **ECDSA** implementation is vulnerable to **timing attacks** and+ should therefore only be used for verification.++and the following known **not-vulnerabilities**:++- The library is not vulnerable to [JWS **algorithm substitution+ attacks**](+ https://auth0.com/blog/critical-vulnerabilities-in-json-web-token-libraries/).+ Haskell's type system excludes this attack.++- The default JWS validation settings reject the **`"none"`+ algorithm**, as [required by RFC 7518](+ https://tools.ietf.org/html/rfc7518#section-3.6).++- The library is not vulnerable to ECDH [**invalid curve attacks**](+ https://blogs.adobe.com/security/2017/03/critical-vulnerability-uncovered-in-json-encryption.html)+ because JWE is not implemented.+++## Interoperability issues++The following known interoperability issues will not be addressed,+so please do not open issues:++- Some JOSE tools and libraries permit the use of **short keys**, in+ violation of the RFCs. This implementation reject JWS or JWT+ objects minted with short keys, as required by the RFCs.++- The *Auth0* software produces objects with an [invalid `"x5t"`+ parameter](+ https://community.auth0.com/questions/7227/certificate-thumbprint-is-longer-than-20-bytes).+ The datum [should be a base64url-encoded SHA-1 digest](+ https://tools.ietf.org/html/rfc7515#section-4.1.7), but *Auth0*+ produces a base64url-encoded hex-encoded SHA-1 digest. The object+ can be repaired so that this library will admit it, unless the+ offending parameter is part of the *JWS Protected Header* in which+ case you are out of luck until *Auth0* bring their implementation+ into compliance.+++## Contributing++Bug reports, patches, feature requests, code review, crypto review,+examples and documentation are welcome.++If you are wondering about how or whether to implement some feature+or fix, please open an issue where it can be discussed. I+appreciate your efforts, but I do not wish such efforts to be+misplaced.++To submit a patch, please use ``git send-email`` or open a pull+request. Write a [well formed commit message](+http://tbaggery.com/2008/04/19/a-note-about-git-commit-messages.html).+If your patch is nontrivial, update the copyright notice at the top+of the modified files
example/Main.hs view
@@ -31,22 +31,20 @@ doGen :: [String] -> IO () doGen [kty] = do- let- param = case kty of- "oct" -> OctGenParam 32- "rsa" -> RSAGenParam 256- "ec" -> ECGenParam P_256- "eddsa" -> OKPGenParam Ed25519- jwk <- genJWK param+ k <- genJWK $ case kty of+ "oct" -> OctGenParam 32+ "rsa" -> RSAGenParam 256+ "ec" -> ECGenParam P_256+ "eddsa" -> OKPGenParam Ed25519 #if MIN_VERSION_aeson(0,10,0) let- h = view thumbprint jwk :: Digest SHA256- kid = view (re (base64url . digest) . utf8) h- jwk' = set jwkKid (Just kid) jwk+ h = view thumbprint k :: Digest SHA256+ kid' = view (re (base64url . digest) . utf8) h+ k' = set jwkKid (Just kid') k #else- let jwk' = jwk+ let k' = k #endif- L.putStr (encode jwk')+ L.putStr (encode k') -- | Mint a JWT. Args are: --@@ -57,11 +55,11 @@ -- doJwtSign :: [String] -> IO () doJwtSign [jwkFilename, claimsFilename] = do- Just jwk <- decode <$> L.readFile jwkFilename+ Just k <- decode <$> L.readFile jwkFilename Just claims <- decode <$> L.readFile claimsFilename result <- runExceptT $ do- alg <- bestJWSAlg jwk- signClaims jwk (newJWSHeader ((), alg)) claims+ alg' <- bestJWSAlg k+ signClaims k (newJWSHeader ((), alg')) claims case result of Left e -> print (e :: Error) >> exitFailure Right jwt -> L.putStr (encodeCompact jwt)@@ -83,10 +81,10 @@ let aud' = fromJust $ preview stringOrUri aud conf = defaultJWTValidationSettings (== aud')- Just jwk <- decode <$> L.readFile jwkFilename+ Just k <- decode <$> L.readFile jwkFilename jwtData <- L.readFile jwtFilename result <- runExceptT- (decodeCompact jwtData >>= verifyClaims conf (jwk :: JWK))+ (decodeCompact jwtData >>= verifyClaims conf (k :: JWK)) case result of Left e -> print (e :: JWTError) >> exitFailure Right claims -> L.putStr $ encode claims@@ -99,7 +97,7 @@ -- doThumbprint :: [String] -> IO () doThumbprint (jwkFilename : _) = do- Just jwk <- decode <$> L.readFile jwkFilename- let h = view thumbprint jwk :: Digest SHA256+ Just k <- decode <$> L.readFile jwkFilename+ let h = view thumbprint k :: Digest SHA256 L.putStr $ review (base64url . digest) h #endif
jose.cabal view
@@ -1,5 +1,5 @@ name: jose-version: 0.6.0.3+version: 0.7.0.0 synopsis: Javascript Object Signing and Encryption and JSON Web Token library description:@@ -31,7 +31,7 @@ build-type: Simple cabal-version: >= 1.8 tested-with:- GHC==7.10.3, GHC==8.0.1, GHC==8.0.2, GHC==8.2.1+ GHC==7.10.3, GHC==8.0.1, GHC==8.0.2, GHC==8.2.2, GHC==8.4.1 library exposed-modules:@@ -126,13 +126,13 @@ , jose , tasty- , tasty-hspec+ , tasty-hspec >= 1.0 , tasty-quickcheck , hspec , QuickCheck , quickcheck-instances -executable example+executable jose-example hs-source-dirs: example ghc-options: -Wall main-is: Main.hs
src/Crypto/JOSE/JWA/JWK.hs view
@@ -32,7 +32,11 @@ -- * Parameters for Elliptic Curve Keys , Crv(..)- , ECKeyParameters(..)+ , ECKeyParameters+ , ecCrv, ecX, ecY, ecD+ , curve+ , point+ , ecPrivateKey -- * Parameters for RSA Keys , RSAPrivateKeyOthElem(..)@@ -48,6 +52,7 @@ -- * Parameters for Symmetric Keys , OctKeyParameters(..)+ , octK -- * Parameters for CFRG EC keys (RFC 8037) , OKPKeyParameters(..)@@ -79,6 +84,7 @@ import Crypto.MAC.HMAC import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Generate as ECC+import qualified Crypto.PubKey.ECC.Prim as ECC import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15 import qualified Crypto.PubKey.RSA.PSS as PSS@@ -199,45 +205,62 @@ -- | Parameters for Elliptic Curve Keys -- data ECKeyParameters = ECKeyParameters- { ecCrv :: Crv- , ecX :: Types.SizedBase64Integer- , ecY :: Types.SizedBase64Integer- , ecD :: Maybe Types.SizedBase64Integer+ { _ecCrv :: Crv+ , _ecX :: Types.SizedBase64Integer+ , _ecY :: Types.SizedBase64Integer+ , _ecD :: Maybe Types.SizedBase64Integer } deriving (Eq, Show) +ecCrv :: Getter ECKeyParameters Crv+ecCrv = to (\(ECKeyParameters crv _ _ _) -> crv)++ecX, ecY :: Getter ECKeyParameters Types.SizedBase64Integer+ecX = to (\(ECKeyParameters _ x _ _) -> x)+ecY = to (\(ECKeyParameters _ _ y _) -> y)++ecD :: Getter ECKeyParameters (Maybe Types.SizedBase64Integer)+ecD = to (\(ECKeyParameters _ _ _ d) -> d)+ instance FromJSON ECKeyParameters where parseJSON = withObject "EC" $ \o -> do o .: "kty" >>= guard . (== ("EC" :: T.Text)) crv <- o .: "crv"- ECKeyParameters- <$> pure crv- <*> (o .: "x" >>= Types.checkSize (ecCoordBytes crv))- <*> (o .: "y" >>= Types.checkSize (ecCoordBytes crv))- <*> (o .:? "d" >>= \case- Nothing -> return Nothing- Just v -> Just <$> Types.checkSize (ecDBytes crv) v)+ let w = ecCoordBytes crv+ x <- o .: "x" >>= Types.checkSize w+ y <- o .: "y" >>= Types.checkSize w+ let int (Types.SizedBase64Integer _ n) = n+ if ECC.isPointValid (curve crv) (ECC.Point (int x) (int y))+ then ECKeyParameters crv x y+ <$> (o .:? "d" >>= traverse (Types.checkSize w))+ else fail "point is not on specified curve" instance ToJSON ECKeyParameters where- toJSON (ECKeyParameters {..}) = object $+ toJSON k = object $ [ "kty" .= ("EC" :: T.Text)- , "crv" .= ecCrv- , "x" .= ecX- , "y" .= ecY- ] ++ fmap ("d" .=) (toList ecD)+ , "crv" .= view ecCrv k+ , "x" .= view ecX k+ , "y" .= view ecY k+ ] <> fmap ("d" .=) (toList (view ecD k)) instance Arbitrary ECKeyParameters where arbitrary = do+ drg <- drgNewTest <$> arbitrary crv <- arbitrary- let w = ecCoordBytes crv- ECKeyParameters crv- <$> Types.genSizedBase64IntegerOf w- <*> Types.genSizedBase64IntegerOf w- <*> oneof- [ pure Nothing- , Just <$> Types.genSizedBase64IntegerOf (ecDBytes crv)- ]+ let (params, _) = withDRG drg (genEC crv)+ includePrivate <- arbitrary+ if includePrivate+ then pure params+ else pure params { _ecD = Nothing } +genEC :: MonadRandom m => Crv -> m ECKeyParameters+genEC crv = do+ let i = Types.SizedBase64Integer (ecCoordBytes crv)+ (ECDSA.PublicKey _ p, ECDSA.PrivateKey _ d) <- ECC.generate (curve crv)+ case p of+ ECC.Point x y -> pure $ ECKeyParameters crv (i x) (i y) (Just (i d))+ ECC.PointO -> genEC crv -- JWK cannot represent point at infinity; recurse+ signEC :: (BA.ByteArrayAccess msg, HashAlgorithm h, MonadRandom m, MonadError e m, AsError e)@@ -245,13 +268,14 @@ -> ECKeyParameters -> msg -> m B.ByteString-signEC h (ECKeyParameters {..}) m = case ecD of+signEC h k m = case view ecD k of Just ecD' -> sigToBS <$> sig where- w = ecCoordBytes ecCrv+ crv = view ecCrv k+ w = ecCoordBytes crv sig = ECDSA.sign privateKey h m sigToBS (ECDSA.Signature r s) = Types.sizedIntegerToBS w r <> Types.sizedIntegerToBS w s- privateKey = ECDSA.PrivateKey (curve ecCrv) (d ecD')+ privateKey = ECDSA.PrivateKey (curve crv) (d ecD') d (Types.SizedBase64Integer _ n) = n Nothing -> throwError (review _KeyMismatch "not an EC private key") @@ -264,7 +288,7 @@ -> Bool verifyEC h k m s = ECDSA.verify h pubkey sig m where- pubkey = ECDSA.PublicKey (curve $ ecCrv k) (point k)+ pubkey = ECDSA.PublicKey (curve $ view ecCrv k) (point k) sig = uncurry ECDSA.Signature $ bimap Types.bsToInteger Types.bsToInteger $ B.splitAt (B.length s `div` 2) s@@ -276,23 +300,24 @@ curveName P_521 = ECC.SEC_p521r1 point :: ECKeyParameters -> ECC.Point-point ECKeyParameters {..} = ECC.Point (integer ecX) (integer ecY) where- integer (Types.SizedBase64Integer _ n) = n+point k = ECC.Point (f ecX) (f ecY) where+ f l = case view l k of+ Types.SizedBase64Integer _ n -> n ecCoordBytes :: Integral a => Crv -> a ecCoordBytes P_256 = 32 ecCoordBytes P_384 = 48 ecCoordBytes P_521 = 66 -ecDBytes :: Integral a => Crv -> a-ecDBytes crv = ceiling (logBase 2 (fromIntegral order) / 8 :: Double) where- order = ECC.ecc_n $ ECC.common_curve $ curve crv+ecPrivateKey :: (MonadError e m, AsError e) => ECKeyParameters -> m Integer+ecPrivateKey (ECKeyParameters _ _ _ (Just (Types.SizedBase64Integer _ d))) = pure d+ecPrivateKey _ = throwError (review _KeyMismatch "Not an EC private key") -- | Parameters for RSA Keys -- data RSAKeyParameters = RSAKeyParameters- { _rsaN :: Types.SizedBase64Integer+ { _rsaN :: Types.Base64Integer , _rsaE :: Types.Base64Integer , _rsaPrivateKeyParameters :: Maybe RSAPrivateKeyParameters }@@ -326,10 +351,10 @@ genRSA size = toRSAKeyParameters . snd <$> RSA.generate size 65537 toRSAKeyParameters :: RSA.PrivateKey -> RSAKeyParameters-toRSAKeyParameters (RSA.PrivateKey (RSA.PublicKey s n e) d p q dp dq qi) =+toRSAKeyParameters (RSA.PrivateKey (RSA.PublicKey _ n e) d p q dp dq qi) = let i = Types.Base64Integer in RSAKeyParameters- ( Types.SizedBase64Integer s n )+ ( i n ) ( i e ) ( Just (RSAPrivateKeyParameters (i d) (Just (RSAPrivateKeyOptionalParameters@@ -341,9 +366,9 @@ -> RSAKeyParameters -> B.ByteString -> m B.ByteString-signPKCS15 h k m = case rsaPrivateKey k of- Left e -> throwError (review _Error e)- Right k' -> PKCS15.signSafer (Just h) k' m+signPKCS15 h k m = do+ k' <- rsaPrivateKey k+ PKCS15.signSafer (Just h) k' m >>= either (throwError . review _RSAError) pure verifyPKCS15@@ -361,9 +386,9 @@ -> RSAKeyParameters -> B.ByteString -> m B.ByteString-signPSS h k m = case rsaPrivateKey k of- Left e -> throwError (review _Error e)- Right k' -> PSS.signSafer (PSS.defaultPSSParams h) k' m+signPSS h k m = do+ k' <- rsaPrivateKey k+ PSS.signSafer (PSS.defaultPSSParams h) k' m >>= either (throwError . review _RSAError) pure verifyPSS@@ -375,44 +400,45 @@ -> Bool verifyPSS h k = PSS.verify (PSS.defaultPSSParams h) (rsaPublicKey k) -rsaPrivateKey :: RSAKeyParameters -> Either Error RSA.PrivateKey+rsaPrivateKey+ :: (MonadError e m, AsError e)+ => RSAKeyParameters -> m RSA.PrivateKey rsaPrivateKey (RSAKeyParameters- (Types.SizedBase64Integer size n)+ (Types.Base64Integer n) (Types.Base64Integer e) (Just (RSAPrivateKeyParameters (Types.Base64Integer d) opt)))- | isJust (opt >>= rsaOth) = Left OtherPrimesNotSupported- | n < 2 ^ (2040 :: Integer) = Left KeySizeTooSmall- | otherwise = Right $- RSA.PrivateKey (RSA.PublicKey size n e) d+ | isJust (opt >>= rsaOth) = throwError $ review _OtherPrimesNotSupported ()+ | n < 2 ^ (2040 :: Integer) = throwError $ review _KeySizeTooSmall ()+ | otherwise = pure $+ RSA.PrivateKey (RSA.PublicKey (Types.intBytes n) n e) d (opt' rsaP) (opt' rsaQ) (opt' rsaDp) (opt' rsaDq) (opt' rsaQi) where opt' f = fromMaybe 0 (unB64I . f <$> opt) unB64I (Types.Base64Integer x) = x--rsaPrivateKey _ = Left $ KeyMismatch "not an RSA private key"+rsaPrivateKey _ = throwError $ review _KeyMismatch "not an RSA private key" rsaPublicKey :: RSAKeyParameters -> RSA.PublicKey-rsaPublicKey (RSAKeyParameters- (Types.SizedBase64Integer size n) (Types.Base64Integer e) _)- = RSA.PublicKey size n e+rsaPublicKey (RSAKeyParameters (Types.Base64Integer n) (Types.Base64Integer e) _)+ = RSA.PublicKey (Types.intBytes n) n e -- | Symmetric key parameters data. ---newtype OctKeyParameters = OctKeyParameters- { octK :: Types.Base64Octets- }+newtype OctKeyParameters = OctKeyParameters Types.Base64Octets deriving (Eq, Show) +octK :: Iso' OctKeyParameters Types.Base64Octets+octK = iso (\(OctKeyParameters k) -> k) OctKeyParameters+ instance FromJSON OctKeyParameters where parseJSON = withObject "symmetric key" $ \o -> do o .: "kty" >>= guard . (== ("oct" :: T.Text)) OctKeyParameters <$> o .: "k" instance ToJSON OctKeyParameters where- toJSON OctKeyParameters {..} = object+ toJSON k = object [ "kty" .= ("oct" :: T.Text)- , "k" .= octK+ , "k" .= (view octK k :: Types.Base64Octets) ] instance Arbitrary OctKeyParameters where@@ -529,7 +555,7 @@ deriving (Eq, Show) showKeyType :: KeyMaterial -> String-showKeyType (ECKeyMaterial (ECKeyParameters { ecCrv = crv })) = "ECDSA (" ++ show crv ++ ")"+showKeyType (ECKeyMaterial (ECKeyParameters { _ecCrv = crv })) = "ECDSA (" ++ show crv ++ ")" showKeyType (RSAKeyMaterial _) = "RSA" showKeyType (OctKeyMaterial _) = "symmetric" showKeyType (OKPKeyMaterial _) = "OKP"@@ -569,15 +595,7 @@ ] genKeyMaterial :: MonadRandom m => KeyMaterialGenParam -> m KeyMaterial-genKeyMaterial (ECGenParam crv) = do- let- xyValue = Types.SizedBase64Integer (ecCoordBytes crv)- dValue = Types.SizedBase64Integer (ecDBytes crv)- (ECDSA.PublicKey _ p, ECDSA.PrivateKey _ d) <- ECC.generate (curve crv)- case p of- ECC.Point x y -> return $ ECKeyMaterial $- ECKeyParameters crv (xyValue x) (xyValue y) (Just (dValue d))- ECC.PointO -> genKeyMaterial (ECGenParam crv) -- JWK cannot represent point at infinity; recurse+genKeyMaterial (ECGenParam crv) = ECKeyMaterial <$> genEC crv genKeyMaterial (RSAGenParam size) = RSAKeyMaterial <$> genRSA size genKeyMaterial (OctGenParam n) = OctKeyMaterial . OctKeyParameters . Types.Base64Octets <$> getRandomBytes n@@ -590,9 +608,9 @@ -> B.ByteString -> m B.ByteString sign JWA.JWS.None _ = \_ -> return ""-sign JWA.JWS.ES256 (ECKeyMaterial k@(ECKeyParameters { ecCrv = P_256 })) = signEC SHA256 k-sign JWA.JWS.ES384 (ECKeyMaterial k@(ECKeyParameters { ecCrv = P_384 })) = signEC SHA384 k-sign JWA.JWS.ES512 (ECKeyMaterial k@(ECKeyParameters { ecCrv = P_521 })) = signEC SHA512 k+sign JWA.JWS.ES256 (ECKeyMaterial k@(ECKeyParameters { _ecCrv = P_256 })) = signEC SHA256 k+sign JWA.JWS.ES384 (ECKeyMaterial k@(ECKeyParameters { _ecCrv = P_384 })) = signEC SHA384 k+sign JWA.JWS.ES512 (ECKeyMaterial k@(ECKeyParameters { _ecCrv = P_521 })) = signEC SHA512 k sign JWA.JWS.RS256 (RSAKeyMaterial k) = signPKCS15 SHA256 k sign JWA.JWS.RS384 (RSAKeyMaterial k) = signPKCS15 SHA384 k sign JWA.JWS.RS512 (RSAKeyMaterial k) = signPKCS15 SHA512 k@@ -650,7 +668,7 @@ asPublicKey = to (Just . set rsaPrivateKeyParameters Nothing) instance AsPublicKey ECKeyParameters where- asPublicKey = to (\k -> Just k { ecD = Nothing })+ asPublicKey = to (\k -> Just k { _ecD = Nothing }) instance AsPublicKey OKPKeyParameters where asPublicKey = to $ \case
src/Crypto/JOSE/JWK.hs view
@@ -234,7 +234,10 @@ instance FromJSON JWKSet where parseJSON = withObject "JWKSet" (\o -> JWKSet <$> o .: "keys") +instance ToJSON JWKSet where+ toJSON (JWKSet ks) = object ["keys" .= toJSON ks] + -- | Choose the cryptographically strongest JWS algorithm for a -- given key. The JWK "alg" algorithm parameter is ignored. --@@ -243,18 +246,18 @@ => JWK -> m JWA.JWS.Alg bestJWSAlg jwk = case view jwkMaterial jwk of- ECKeyMaterial k -> pure $ case ecCrv k of+ ECKeyMaterial k -> pure $ case view ecCrv k of P_256 -> JWA.JWS.ES256 P_384 -> JWA.JWS.ES384 P_521 -> JWA.JWS.ES512 RSAKeyMaterial k -> let- Types.SizedBase64Integer _ n = view rsaN k+ Types.Base64Integer n = view rsaN k in if n >= 2 ^ (2040 :: Integer) then pure JWA.JWS.PS512 else throwError (review _KeySizeTooSmall ())- OctKeyMaterial (OctKeyParameters { octK = Types.Base64Octets k })+ OctKeyMaterial (OctKeyParameters (Types.Base64Octets k)) | B.length k >= 512 `div` 8 -> pure JWA.JWS.HS512 | B.length k >= 384 `div` 8 -> pure JWA.JWS.HS384 | B.length k >= 256 `div` 8 -> pure JWA.JWS.HS256@@ -281,8 +284,11 @@ thumbprintRepr :: JWK -> L.ByteString thumbprintRepr k = Builder.toLazyByteString . fromEncoding . pairs $ case view jwkMaterial k of- ECKeyMaterial ECKeyParameters {..} ->- "crv" .= ecCrv <> "kty" .= ("EC" :: T.Text) <> "x" .= ecX <> "y" .= ecY+ ECKeyMaterial k' -> "crv" .=+ view ecCrv k'+ <> "kty" .= ("EC" :: T.Text)+ <> "x" .= view ecX k'+ <> "y" .= view ecY k' RSAKeyMaterial k' -> "e" .= view rsaE k' <> "kty" .= ("RSA" :: T.Text) <> "n" .= view rsaN k' OctKeyMaterial (OctKeyParameters k') ->
src/Crypto/JOSE/Types.hs view
@@ -35,6 +35,8 @@ , base64url ) where +import Data.Word (Word8)+ import Control.Lens import Data.Aeson import Data.Aeson.Types (Parser)@@ -44,25 +46,60 @@ import Test.QuickCheck import Test.QuickCheck.Instances () +import Crypto.Number.Basic (log2) import Crypto.JOSE.Types.Internal import Crypto.JOSE.Types.Orphans () -- | A base64url encoded octet sequence interpreted as an integer. --+-- The value is encoded in the minimum number of octets (no leading+-- zeros) with the exception of @0@ which is encoded as @AA@.+-- A leading zero when decoding is an error.+-- newtype Base64Integer = Base64Integer Integer deriving (Eq, Show) makePrisms ''Base64Integer instance FromJSON Base64Integer where- parseJSON = withText "base64url integer" $ parseB64Url $- pure . Base64Integer . bsToInteger+ parseJSON = withText "base64url integer" $ parseB64Url+ (fmap Base64Integer . parseOctets) +-- | Parse an octet sequence into an integer.+--+-- This function deals with ugly special cases from+-- <https://tools.ietf.org/html/rfc7518#section-2>, specifically+--+-- * The empty sequence is invalid+-- * Leading null byte is invalid (unless it is the only byte)+--+parseOctets :: B.ByteString -> Parser Integer+parseOctets s+ | B.null s = fail "empty octet sequence"+ | s == "\NUL" = pure 0+ | B.head s == 0 = fail "leading null byte"+ | otherwise = pure (bsToInteger s)+ instance ToJSON Base64Integer where+ -- Urgh, special case: https://tools.ietf.org/html/rfc7518#section-2+ toJSON (Base64Integer 0) = "AA" toJSON (Base64Integer x) = encodeB64Url $ integerToBS x ++arbitraryBigInteger :: Gen Integer+arbitraryBigInteger = do+ size <- arbitrarySizedNatural -- number of octets+ go (size + 1) 0+ where+ go :: Integer -> Integer -> Gen Integer+ go 0 n = pure n+ go k n =+ (n * 256 +) . fromIntegral <$> (arbitraryBoundedIntegral :: Gen Word8)+ >>= go (k - 1)++ instance Arbitrary Base64Integer where- arbitrary = Base64Integer <$> arbitrarySizedNatural+ arbitrary = Base64Integer <$> arbitraryBigInteger -- | A base64url encoded octet sequence interpreted as an integer@@ -77,11 +114,9 @@ instance Arbitrary SizedBase64Integer where arbitrary = do- x <- arbitrarySizedNatural- l <- arbitrarySizedNatural -- arbitrary number of leading zero-bytes- return $ SizedBase64Integer- ((+ l) $ ceiling $ logBase 2 (fromInteger x :: Double))- x+ x <- arbitraryBigInteger+ l <- Test.QuickCheck.elements [0,1,2] -- number of leading zero-bytes+ pure $ SizedBase64Integer ((log2 x `div` 8) + 1 + l) x genByteStringOf :: Int -> Gen B.ByteString genByteStringOf n = B.pack <$> vectorOf n arbitrary
src/Crypto/JOSE/Types/Internal.hs view
@@ -32,6 +32,7 @@ , unpad , bsToInteger , integerToBS+ , intBytes , sizedIntegerToBS , base64url ) where@@ -44,6 +45,7 @@ import Control.Lens import Control.Lens.Cons.Extras+import Crypto.Number.Basic (log2) import Data.Aeson.Types import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L@@ -167,12 +169,15 @@ -- | Convert an integer to its unsigned big endian representation as -- an octet sequence. ---integerToBS :: Integer -> B.ByteString+integerToBS :: Integral a => a -> B.ByteString integerToBS = B.reverse . B.unfoldr (fmap swap . f) where- f x = if x == 0 then Nothing else Just (toWord8 $ quotRem x 256)- toWord8 (seed, x) = (seed, fromIntegral x)+ f 0 = Nothing+ f x = Just (fromIntegral <$> quotRem x 256) -sizedIntegerToBS :: Int -> Integer -> B.ByteString+sizedIntegerToBS :: Integral a => Int -> a -> B.ByteString sizedIntegerToBS w = zeroPad . integerToBS where zeroPad xs = B.replicate (w - B.length xs) 0 `B.append` xs++intBytes :: Integer -> Int+intBytes n = (log2 n `div` 8) + 1
src/Crypto/JWT.hs view
@@ -40,7 +40,7 @@ doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT') doJwtSign jwk claims = runExceptT $ do alg \<- 'bestJWSAlg' jwk- 'signClaims' jwk ('newJWSHeader' ('Protected', alg)) claims+ 'signClaims' jwk ('newJWSHeader' ((), alg)) claims doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet') doJwtVerify jwk jwt = runExceptT $ do@@ -48,6 +48,20 @@ 'verifyClaims' config jwk jwt @ +Some JWT libraries have a function that takes two strings: the+"secret" (a symmetric key) and the raw JWT. The following function+achieves the same:++@+verify :: L.ByteString -> L.ByteString -> IO (Either 'JWTError' 'ClaimsSet')+verify k s = runExceptT $ do+ let+ k' = 'fromOctets' k -- turn raw secret into symmetric JWK+ audCheck = const True -- should be a proper audience check+ s' <- 'decodeCompact' s -- decode JWT+ 'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' s'+@+ -} module Crypto.JWT (@@ -59,6 +73,7 @@ -- * Validating a JWT and extracting claims , defaultJWTValidationSettings , verifyClaims+ , verifyClaimsAt , HasAllowedSkew(..) , HasAudiencePredicate(..) , HasIssuerPredicate(..)@@ -113,6 +128,7 @@ Lens', _Just, over, preview, review, view, Prism', prism', Cons, cons, uncons, iso, Iso') import Control.Monad.Except (MonadError(throwError))+import Control.Monad.Reader (ReaderT, ask, runReaderT) import Data.Aeson import qualified Data.HashMap.Strict as M import qualified Data.Text as T@@ -503,6 +519,12 @@ toCompact (JWT a) = toCompact a +newtype WrappedUTCTime = WrappedUTCTime { getUTCTime :: UTCTime }++instance Monad m => MonadTime (ReaderT WrappedUTCTime m) where+ currentTime = getUTCTime <$> ask++ -- | Cryptographically verify a JWS JWT, then validate the -- Claims Set, returning it if valid. --@@ -510,6 +532,9 @@ -- enforcing that the claims are cryptographically and -- semantically valid before the application can use them. --+-- See also 'verifyClaimsAt' which allows you to explicitly specify+-- the time.+-- verifyClaims :: ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a@@ -529,6 +554,30 @@ verifyJWS conf k jws >>= either (throwError . review _JWTClaimsSetDecodeError) pure . eitherDecode >>= validateClaimsSet conf+++-- | Cryptographically verify a JWS JWT, then validate the+-- Claims Set, returning it if valid.+--+-- This is the same as 'verifyClaims' except that the time is+-- explicitly provided. If you process many requests per second+-- this will allow you to avoid unnecessary repeat system calls.+--+verifyClaimsAt+ ::+ ( HasAllowedSkew a, HasAudiencePredicate a+ , HasIssuerPredicate a+ , HasCheckIssuedAt a+ , HasValidationSettings a+ , AsError e, AsJWTError e, MonadError e m+ , JWKStore k+ )+ => a+ -> k+ -> UTCTime+ -> SignedJWT+ -> m ClaimsSet+verifyClaimsAt a k t jwt = runReaderT (verifyClaims a k jwt) (WrappedUTCTime t) -- | Create a JWS JWT --
test/JWS.hs view
@@ -251,6 +251,27 @@ 192,205,154,245,103,208,128,163] +jwkRSA1024 :: JWK+jwkRSA1024 = fromJust $ decode $+ "{\"qi\":\"qYMpiKTOyFktv0Z3pQbig1RNA1xH35HMtjwISviC_bGo2zvzrYztBC_RzWsw"+ <> "3Nwsc32n65HIdpNbau1UhB3EwQ\","+ <> "\"p\":\"3ovj_M4MMJamOtjhtjswZhhwSYBiK6f2TjIEWiji-XV9SRcoyJsnp5flpeX"+ <> "VTEXS_PgLmjtUi2MLGAvXLlTtyQ\","+ <> "\"n\":\"yy1luWS19u8F-9eAdJ2iwCvuFrjOKuj1YBeNegPZpMJ9mhi8YISQLg-FTFR"+ <> "J68FzMeZM0liJq9mm-tNfPsNFxU7VM_sha2jWuJI32u3W5m7myTb8vNjHAd8acvuIRJ"+ <> "3hoJpJtSc1XBHHHIUK6lXNepHwQMjSCWtTY2wjRMKvYBU\","+ <> "\"q\":\"6bgjSNOcMzZMh64q66kIU68_U6wHwdbSFyLLtwVORsEYPhQUjWEoO7thY9j"+ <> "7m5NLRWgumoPIdDlLhOOnEf_V7Q\","+ <> "\"d\":\"Mordhkv-VCpLs8V9KAVayjFjbfWVG-mNuNTDFfpFNw5GzoGewufXMg4cW8u"+ <> "QA_zAmkYvEBiETuK6_iR8yhErlqMwFA4mdS4Yq0OqOPd9rCalUOoJf8cV1W5scsWXmL"+ <> "-xX_TmnGnIpjYcDJw6Zw0KP7hvHKPTPUriY2Zb--LLhaE\","+ <> "\"dp\":\"EgxgUglX3bzqAE3EiGXmd_E1chCSZZ36kL7nsXQtbDPGFF5ndVV38tST0E"+ <> "-Ca-whv1hSgJCdO6ytoqabLeu_WQ\","+ <> "\"e\":\"AQAB\","+ <> "\"dq\":\"3gLqkY1hvUwBGomZf85LeKLp9uNdYwZa_1swRCSoHJHkI2QTudDm1QbEFo"+ <> "LRTxF12PKEAobYbX7Xe958n550aQ\","+ <> "\"kty\":\"RSA\"}"+ appendixA2Spec :: Spec appendixA2Spec = describe "RFC 7515 A.2. Example JWS using RSASSA-PKCS-v1_5 SHA-256" $ do it "computes the signature correctly" $@@ -260,6 +281,11 @@ it "validates the signature correctly" $ verify JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput' sig `shouldBe` (Right True :: Either Error Bool)++ it "prohibits signing with 1024-bit key" $+ fst (withDRG drg (runExceptT $+ signJWS signingInput' (Identity (newJWSHeader ((), JWA.JWS.RS256), jwkRSA1024))))+ `shouldBe` (Left KeySizeTooSmall :: Either Error (CompactJWS JWSHeader)) where signingInput' = "\
test/JWT.hs view
@@ -12,9 +12,9 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-} module JWT where @@ -51,8 +51,10 @@ & over unregisteredClaims (insert "http://example.com/is_root" (Bool True)) & addClaim "http://example.com/is_root" (Bool True) +#if ! MIN_VERSION_monad_time(0,3,0) instance Monad m => MonadTime (ReaderT UTCTime m) where currentTime = ask+#endif spec :: Spec spec = do@@ -62,10 +64,10 @@ describe "JWT Claims Set" $ do it "parses from JSON correctly" $ let- claimsJSON = "\- \{\"iss\":\"joe\",\r\n\- \ \"exp\":1300819380,\r\n\- \ \"http://example.com/is_root\":true}"+ claimsJSON =+ "{\"iss\":\"joe\",\r\n"+ <> "\"exp\":1300819380,\r\n"+ <> "\"http://example.com/is_root\":true}" in decode claimsJSON `shouldBe` Just exampleClaimsSet @@ -270,11 +272,12 @@ describe "RFC 7519 §6.1. Example Unsecured JWT" $ do let- exampleJWT = "eyJhbGciOiJub25lIn0\- \.\- \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\- \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ\- \."+ exampleJWT =+ "eyJhbGciOiJub25lIn0"+ <> "."+ <> "eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt"+ <> "cGxlLmNvbS9pc19yb290Ijp0cnVlfQ"+ <> "." jwt = decodeCompact exampleJWT k = fromJust $ decode "{\"kty\":\"oct\",\"k\":\"\"}" :: JWK
test/Types.hs view
@@ -61,6 +61,18 @@ it "formats to JSON correctly" $ toJSON (Base64Integer 65538) `shouldBe` "AQAC" + it "rejects empty string" $+ decode "[\"\"]" `shouldBe` (Nothing :: Maybe [Base64Integer])++ it "rejects leading zero" $+ decode "[\"AD8\"]" `shouldBe` (Nothing :: Maybe [Base64Integer])++ it "decodes AA as zero" $+ decode "[\"AA\"]" `shouldBe` Just [Base64Integer 0]++ it "encodes zero as AA" $+ toJSON (Base64Integer 0) `shouldBe` "AA"+ sizedBase64IntegerSpec :: Spec sizedBase64IntegerSpec = describe "SizedBase64Integer" $ do it "parses from JSON correctly" $ do