jose 0.9 → 0.10
raw patch · 22 files changed
+789/−452 lines, 22 filesdep +hedgehogdep +tasty-hedgehogdep −QuickCheckdep −quickcheck-instancesdep −tasty-quickcheckdep ~cryptonite
Dependencies added: hedgehog, tasty-hedgehog
Dependencies removed: QuickCheck, quickcheck-instances, tasty-quickcheck
Dependency ranges changed: cryptonite
Files
- CHANGELOG.md +46/−0
- README.md +7/−6
- example/JWS.hs +2/−3
- example/Main.hs +2/−3
- jose.cabal +11/−13
- src/Crypto/JOSE/AESKW.hs +2/−1
- src/Crypto/JOSE/Error.hs +48/−12
- src/Crypto/JOSE/Header.hs +17/−4
- src/Crypto/JOSE/JWA/JWK.hs +49/−100
- src/Crypto/JOSE/JWA/JWS.hs +1/−0
- src/Crypto/JOSE/JWE.hs +6/−5
- src/Crypto/JOSE/JWK.hs +45/−31
- src/Crypto/JOSE/JWS.hs +14/−7
- src/Crypto/JOSE/Types.hs +0/−47
- src/Crypto/JOSE/Types/Orphans.hs +0/−29
- src/Crypto/JOSE/Types/URI.hs +29/−0
- src/Crypto/JWT.hs +233/−95
- test/AESKW.hs +24/−18
- test/JWS.hs +5/−7
- test/JWT.hs +86/−14
- test/Properties.hs +162/−44
- test/Types.hs +0/−13
+ CHANGELOG.md view
@@ -0,0 +1,46 @@+## Version 0.10 (2022-09-01)++- Introduce `newtype JOSE e m a` which behaves like `ExceptT e m a`+ but also has `instance (MonadRandom m) => MonadRandom (JOSE e m)`.+ The orphan `MonadRandom` instances were removed. ([#91][])++- Parameterise `JWT` over the claims data type. This is a+ cleaner mechanism to support applications that use additional+ claims beyond those registered by RFC 7519. `unregisteredClaims`+ and `addClaim` are deprecated and will be removed in a future+ release. ([#39][])++- Add Ed448 and X448 support. ([#74][])++- Add secp256k1 curve support (RFC 8812).++- Added `checkJWK :: (MonadError e m, AsError e) => JWK -> m ()`.+ This action performs some key usability checks. In particular+ it identifies too-small symmetric keys. ([#46][])++- Removed `QuickCheck` instances. *jose* no longer depends on+ `QuickCheck`. ([#106][])++- Removed orphan `ToJSON` and `FromJSON` instances for `URI`.++- Fail signature verification when curve does not match algorithm.+ This is an additional defence against curve substitution attacks.++- Improved error reporting when constructing a JWK from an X.509+ certificate with ECDSA key.++- Make compatible with `mtl == 2.3.*` ([#107][])++- Make compatible with `monad-time == 0.4`++[#39]: https://github.com/frasertweedale/hs-jose/issues/39+[#46]: https://github.com/frasertweedale/hs-jose/issues/46+[#74]: https://github.com/frasertweedale/hs-jose/issues/74+[#91]: https://github.com/frasertweedale/hs-jose/issues/91+[#106]: https://github.com/frasertweedale/hs-jose/issues/106+[#107]: https://github.com/frasertweedale/hs-jose/issues/107+++## Older versions++See Git commit history
README.md view
@@ -1,15 +1,16 @@-# jose - Javascript Object Signing and Encryption & JWT (JSON Web Token)+# jose - JSON Object Signing and Encryption & JWT (JSON Web Token) -*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).+*jose* is a Haskell implementation of [JSON Object Signing and+Encryption (JOSE)](https://datatracker.ietf.org/wg/jose/) and [JSON+Web Token (JWT)](https://tools.ietf.org/html/rfc7519). The JSON Web Signature (JWS; RFC 7515) implementation is complete. JSON Web Encryption (JWE; RFC 7516) is not yet implemented. -**EdDSA** signatures (RFC 8037) are supported (Ed25519 only).+**EdDSA** signatures (RFC 8037) and secp256k1 signatures (RFC 8812)+are supported. -JWK Thumbprint (RFC 7638) is supported (requires *aeson* >= 0.10).+JWK Thumbprint (RFC 7638) is supported. [Contributions](#contributing) are welcome.
example/JWS.hs view
@@ -2,7 +2,6 @@ import System.Exit (exitFailure) -import Control.Monad.Except (runExceptT) import Data.Aeson (decode, encode) import qualified Data.ByteString.Lazy as L @@ -19,7 +18,7 @@ doJwsSign [jwkFilename, payloadFilename] = do Just jwk <- decode <$> L.readFile jwkFilename payload <- L.readFile payloadFilename- result <- runExceptT $ do+ result <- runJOSE $ do h <- makeJWSHeader jwk signJWS payload [(h :: JWSHeader Protection, jwk)] case result of@@ -38,7 +37,7 @@ doJwsVerify [jwkFilename, jwsFilename] = do Just jwk <- decode <$> L.readFile jwkFilename Just jws <- decode <$> L.readFile jwsFilename- result <- runExceptT $ verifyJWS' (jwk :: JWK) (jws :: GeneralJWS JWSHeader)+ result <- runJOSE $ verifyJWS' (jwk :: JWK) (jws :: GeneralJWS JWSHeader) case result of Left e -> print (e :: Error) >> exitFailure Right s -> L.putStr s
example/Main.hs view
@@ -11,7 +11,6 @@ import Data.Text.Strict.Lens (utf8) import System.Posix.Files (getFileStatus, isDirectory) -import Control.Monad.Except (runExceptT) import Control.Lens (preview, re, review, set, view) import Crypto.JWT@@ -54,7 +53,7 @@ doJwtSign [jwkFilename, claimsFilename] = do Just k <- decode <$> L.readFile jwkFilename Just claims <- decode <$> L.readFile claimsFilename- result <- runExceptT $ makeJWSHeader k >>= \h -> signClaims k h claims+ result <- runJOSE $ makeJWSHeader k >>= \h -> signClaims k h claims case result of Left e -> print (e :: Error) >> exitFailure Right jwt -> L.putStr (encodeCompact jwt)@@ -77,7 +76,7 @@ let aud' = fromJust $ preview stringOrUri aud conf = defaultJWTValidationSettings (== aud')- go k = runExceptT (decodeCompact jwtData >>= verifyClaims conf k)+ go k = runJOSE $ decodeCompact jwtData >>= verifyClaims conf k jwkDir <- isDirectory <$> getFileStatus jwkFilename result <-
jose.cabal view
@@ -1,16 +1,16 @@ cabal-version: 2.2 name: jose-version: 0.9+version: 0.10 synopsis: JSON Object Signing and Encryption (JOSE) and JSON Web Token (JWT) library description: .- An implementation of the Javascript Object Signing and Encryption- (JOSE) and JSON Web Token (JWT; RFC 7519) formats.+ Implementation of JSON Object Signing and Encryption+ (JOSE) and JSON Web Token (JWT; RFC 7519). . The JSON Web Signature (JWS; RFC 7515) implementation is complete. .- EdDSA signatures (RFC 8037) are supported (Ed25519 only).+ EdDSA signatures (RFC 8037) and secp256k1 (RFC 8812) are supported. . JWK Thumbprint (RFC 7638) is supported. .@@ -24,6 +24,7 @@ license: Apache-2.0 license-file: LICENSE extra-source-files:+ CHANGELOG.md README.md test/data/fido.jwt author: Fraser Tweedale@@ -32,7 +33,7 @@ category: Cryptography build-type: Simple tested-with:- GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.0.1+ GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.4, GHC==9.4.2 flag demos description: Build demonstration programs@@ -40,7 +41,7 @@ common common default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall -Werror=missing-methods build-depends: base >= 4.9 && < 5@@ -73,20 +74,18 @@ other-modules: Crypto.JOSE.TH Crypto.JOSE.Types.Internal- Crypto.JOSE.Types.Orphans+ Crypto.JOSE.Types.URI build-depends: , base64-bytestring >= 1.2.1.0 && < 1.3 , concise >= 0.1 , containers >= 0.5- , cryptonite >= 0.7+ , cryptonite >= 0.24 , memory >= 0.7 , monad-time >= 0.3 , template-haskell >= 2.11 , time >= 1.5 , network-uri >= 2.6- , QuickCheck >= 2.9- , quickcheck-instances , x509 >= 1.4 hs-source-dirs: src@@ -122,11 +121,10 @@ , jose , tasty+ , tasty-hedgehog , tasty-hspec >= 1.0- , tasty-quickcheck+ , hedgehog , hspec- , QuickCheck >= 2.9- , quickcheck-instances test-suite perf import: common
src/Crypto/JOSE/AESKW.hs view
@@ -26,7 +26,8 @@ , aesKeyUnwrap ) where -import Control.Monad.State+import Control.Monad (join)+import Control.Monad.State (StateT, execStateT, get, lift, put) import Crypto.Cipher.Types import Data.Bits (xor) import Data.ByteArray as BA hiding (replicate, xor)
src/Crypto/JOSE/Error.hs view
@@ -1,4 +1,4 @@--- Copyright (C) 2014 Fraser Tweedale+-- Copyright (C) 2014-2022 Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -13,18 +13,23 @@ -- limitations under the License. {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} {-| -JOSE error types.+JOSE error types and helpers. -} module Crypto.JOSE.Error (- Error(..)+ -- * Running JOSE computations+ runJOSE+ , unwrapJOSE+ , JOSE(..)++ -- * Base error type and class+ , Error(..) , AsError(..) -- * JOSE compact serialisation errors@@ -33,12 +38,14 @@ , CompactDecodeError(..) , _CompactInvalidNumberOfParts , _CompactInvalidText+ ) where import Data.Semigroup ((<>)) import Numeric.Natural -import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.Except+import Control.Monad.Trans import qualified Crypto.PubKey.RSA as RSA import Crypto.Error (CryptoError) import Crypto.Random (MonadRandom(..))@@ -118,10 +125,39 @@ makeClassyPrisms ''Error -instance (- MonadRandom m- , MonadTrans t- , Functor (t m)- , Monad (t m)- ) => MonadRandom (t m) where+newtype JOSE e m a = JOSE (ExceptT e m a)++-- | Run the 'JOSE' computation. Result is an @Either e a@+-- where @e@ is the error type (typically 'Error' or 'Crypto.JWT.JWTError')+runJOSE :: JOSE e m a -> m (Either e a)+runJOSE = runExceptT . (\(JOSE m) -> m)++-- | Get the inner 'ExceptT' value of the 'JOSE' computation.+-- Typically 'runJOSE' would be preferred, unless you specifically+-- need an 'ExceptT' value.+unwrapJOSE :: JOSE e m a -> ExceptT e m a+unwrapJOSE (JOSE m) = m+++instance (Functor m) => Functor (JOSE e m) where+ fmap f (JOSE ma) = JOSE (fmap f ma)++instance (Monad m) => Applicative (JOSE e m) where+ pure = JOSE . pure+ JOSE mf <*> JOSE ma = JOSE (mf <*> ma)++instance (Monad m) => Monad (JOSE e m) where+ JOSE ma >>= f = JOSE (ma >>= unwrapJOSE . f)++instance MonadTrans (JOSE e) where+ lift = JOSE . lift++instance (Monad m) => MonadError e (JOSE e m) where+ throwError = JOSE . throwError+ catchError (JOSE m) handle = JOSE (catchError m (unwrapJOSE . handle))++instance (MonadIO m) => MonadIO (JOSE e m) where+ liftIO = JOSE . liftIO++instance (MonadRandom m) => MonadRandom (JOSE e m) where getRandomBytes = lift . getRandomBytes
src/Crypto/JOSE/Header.hs view
@@ -36,6 +36,7 @@ , headerRequired , headerRequiredProtected , headerOptional+ , headerOptional' , headerOptionalProtected -- * Parsing headers@@ -78,7 +79,6 @@ import qualified Crypto.JOSE.JWA.JWS as JWA.JWS import Crypto.JOSE.JWK (JWK)-import Crypto.JOSE.Types.Orphans () import Crypto.JOSE.Types.Internal (base64url) import qualified Crypto.JOSE.Types as Types @@ -230,12 +230,25 @@ -> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))-headerOptional kText hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of+headerOptional = headerOptional' parseJSON++-- | Parse an optional parameter that may be carried in either+-- the protected or the unprotected header. Like 'headerOptional',+-- but with an explicit argument for the parser.+--+headerOptional'+ :: (ProtectionIndicator p)+ => (Value -> Parser a)+ -> T.Text+ -> Maybe Object+ -> Maybe Object+ -> Parser (Maybe (HeaderParam p a))+headerOptional' parser kText hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of (Just _, Just _) -> fail $ "duplicate header " ++ show kText- (Just v, Nothing) -> Just . HeaderParam getProtected <$> parseJSON v+ (Just v, Nothing) -> Just . HeaderParam getProtected <$> parser v (Nothing, Just v) -> maybe (fail "unprotected header not supported")- (\p -> Just . HeaderParam p <$> parseJSON v)+ (\p -> Just . HeaderParam p <$> parser v) getUnprotected (Nothing, Nothing) -> pure Nothing where
src/Crypto/JOSE/JWA/JWK.hs view
@@ -18,8 +18,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-} {-| @@ -38,6 +36,7 @@ , point , ecPrivateKey , ecParametersFromX509+ , genEC -- * Parameters for RSA Keys , RSAPrivateKeyOthElem(..)@@ -59,6 +58,7 @@ -- * Parameters for CFRG EC keys (RFC 8037) , OKPKeyParameters(..) , OKPCrv(..)+ , genOKP -- * Key generation , KeyMaterialGenParam(..)@@ -72,7 +72,6 @@ , module Crypto.Random ) where -import Control.Applicative import Control.Monad (guard) import Control.Monad.Except (MonadError) import Data.Bifunctor@@ -93,7 +92,9 @@ import qualified Crypto.PubKey.RSA.PSS as PSS import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.Curve25519 as Curve25519+import qualified Crypto.PubKey.Curve448 as Curve448 import Crypto.Random import Data.Aeson import qualified Data.Aeson.KeyMap as M@@ -103,22 +104,17 @@ import qualified Data.Text as T import Data.X509 as X509 import Data.X509.EC as X509.EC-import Test.QuickCheck (Arbitrary(..), arbitrarySizedNatural, elements, oneof, vectorOf) import Crypto.JOSE.Error import qualified Crypto.JOSE.JWA.JWS as JWA.JWS import qualified Crypto.JOSE.TH import qualified Crypto.JOSE.Types as Types import qualified Crypto.JOSE.Types.Internal as Types-import Crypto.JOSE.Types.Orphans () -- | \"crv\" (Curve) Parameter ---$(Crypto.JOSE.TH.deriveJOSEType "Crv" ["P-256", "P-384", "P-521"])--instance Arbitrary Crv where- arbitrary = elements [P_256, P_384, P_521]+$(Crypto.JOSE.TH.deriveJOSEType "Crv" ["P-256", "P-384", "P-521", "secp256k1"]) -- | \"oth\" (Other Primes Info) Parameter@@ -139,10 +135,7 @@ instance ToJSON RSAPrivateKeyOthElem where toJSON (RSAPrivateKeyOthElem r d t) = object ["r" .= r, "d" .= d, "t" .= t] -instance Arbitrary RSAPrivateKeyOthElem where- arbitrary = RSAPrivateKeyOthElem <$> arbitrary <*> arbitrary <*> arbitrary - -- | Optional parameters for RSA private keys -- data RSAPrivateKeyOptionalParameters = RSAPrivateKeyOptionalParameters {@@ -173,16 +166,7 @@ , "qi" .= rsaQi ] ++ maybe [] ((:[]) . ("oth" .=)) rsaOth -instance Arbitrary RSAPrivateKeyOptionalParameters where- arbitrary = RSAPrivateKeyOptionalParameters- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary - -- | RSA private key parameters -- data RSAPrivateKeyParameters = RSAPrivateKeyParameters@@ -204,10 +188,7 @@ Types.insertToObject "d" rsaD $ maybe (Object mempty) toJSON rsaOptionalParameters -instance Arbitrary RSAPrivateKeyParameters where- arbitrary = RSAPrivateKeyParameters <$> arbitrary <*> arbitrary - -- | Parameters for Elliptic Curve Keys -- data ECKeyParameters = ECKeyParameters@@ -249,16 +230,6 @@ , "y" .= view ecY k ] <> fmap ("d" .=) (toList (view ecD k)) -instance Arbitrary ECKeyParameters where- arbitrary = do- drg <- drgNewTest <$> arbitrary- crv <- arbitrary- 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)@@ -308,11 +279,13 @@ (\case P_256 -> ECC.SEC_p256r1 P_384 -> ECC.SEC_p384r1- P_521 -> ECC.SEC_p521r1)+ P_521 -> ECC.SEC_p521r1+ Secp256k1 -> ECC.SEC_p256k1) (\case ECC.SEC_p256r1 -> Just P_256 ECC.SEC_p384r1 -> Just P_384 ECC.SEC_p521r1 -> Just P_521+ ECC.SEC_p256k1 -> Just Secp256k1 _ -> Nothing) point :: ECKeyParameters -> ECC.Point@@ -324,19 +297,20 @@ ecCoordBytes P_256 = 32 ecCoordBytes P_384 = 48 ecCoordBytes P_521 = 66+ecCoordBytes Secp256k1 = 32 ecPrivateKey :: (MonadError e m, AsError e) => ECKeyParameters -> m Integer ecPrivateKey (ECKeyParameters _ _ _ (Just (Types.SizedBase64Integer _ d))) = pure d ecPrivateKey _ = throwing _KeyMismatch "Not an EC private key" -ecParametersFromX509 :: X509.PubKeyEC -> Maybe ECKeyParameters+ecParametersFromX509 :: (MonadError e m, AsError e) => X509.PubKeyEC -> m ECKeyParameters ecParametersFromX509 pubKeyEC = do- ecCurve <- X509.EC.ecPubKeyCurve pubKeyEC- curveName <- X509.EC.ecPubKeyCurveName pubKeyEC- crv <- preview fromCurveName curveName- pt <- X509.EC.unserializePoint ecCurve (X509.pubkeyEC_pub pubKeyEC)+ ecCurve <- maybe (throwing _KeyMismatch "Invalid EC point") pure $ X509.EC.ecPubKeyCurve pubKeyEC+ curveName <- maybe (throwing _KeyMismatch "Unknown curve") pure $ X509.EC.ecPubKeyCurveName pubKeyEC+ crv <- maybe (throwing _KeyMismatch "Unsupported curve TODO ") pure $ preview fromCurveName curveName+ pt <- maybe (throwing _KeyMismatch "Invalid EC point") pure $ X509.EC.unserializePoint ecCurve (X509.pubkeyEC_pub pubKeyEC) (x, y) <- case pt of- ECC.PointO -> Nothing+ ECC.PointO -> throwing _KeyMismatch "Cannot use point at infinity" ECC.Point x y -> pure (Types.makeSizedBase64Integer x, Types.makeSizedBase64Integer y) pure $ ECKeyParameters crv x y Nothing@@ -370,12 +344,6 @@ ] $ maybe (Object mempty) toJSON _rsaPrivateKeyParameters -instance Arbitrary RSAKeyParameters where- arbitrary = RSAKeyParameters- <$> arbitrary- <*> arbitrary- <*> arbitrary- genRSA :: MonadRandom m => Int -> m RSAKeyParameters genRSA size = toRSAKeyParameters . snd <$> RSA.generate size 65537 @@ -475,9 +443,6 @@ , "k" .= (view octK k :: Types.Base64Octets) ] -instance Arbitrary OctKeyParameters where- arbitrary = OctKeyParameters <$> arbitrary- signOct :: forall h e m. (HashAlgorithm h, MonadError e m, AsError e) => h@@ -494,13 +459,17 @@ -- data OKPKeyParameters = Ed25519Key Ed25519.PublicKey (Maybe Ed25519.SecretKey)+ | Ed448Key Ed448.PublicKey (Maybe Ed448.SecretKey) | X25519Key Curve25519.PublicKey (Maybe Curve25519.SecretKey)+ | X448Key Curve448.PublicKey (Maybe Curve448.SecretKey) deriving (Eq) instance Show OKPKeyParameters where show = \case Ed25519Key pk sk -> "Ed25519 " <> showKeys pk sk+ Ed448Key pk sk -> "Ed448 " <> showKeys pk sk X25519Key pk sk -> "X25519 " <> showKeys pk sk+ X448Key pk sk -> "X448 " <> showKeys pk sk where showKeys pk sk = show pk <> " " <> show (("SECRET" :: String) <$ sk) @@ -511,8 +480,8 @@ case (crv :: T.Text) of "Ed25519" -> parseOKPKey Ed25519Key Ed25519.publicKey Ed25519.secretKey o "X25519" -> parseOKPKey X25519Key Curve25519.publicKey Curve25519.secretKey o- "Ed448" -> fail "Ed448 keys not implemented"- "X448" -> fail "X448 not implemented"+ "Ed448" -> parseOKPKey Ed448Key Ed448.publicKey Ed448.secretKey o+ "X448" -> parseOKPKey X448Key Curve448.publicKey Curve448.secretKey o _ -> fail "unrecognised OKP key subtype" where bs (Types.Base64Octets k) = k@@ -525,39 +494,22 @@ toJSON x = object $ "kty" .= ("OKP" :: T.Text) : case x of Ed25519Key pk sk -> "crv" .= ("Ed25519" :: T.Text) : params pk sk+ Ed448Key pk sk -> "crv" .= ("Ed448" :: T.Text) : params pk sk X25519Key pk sk -> "crv" .= ("X25519" :: T.Text) : params pk sk+ X448Key pk sk -> "crv" .= ("X448" :: T.Text) : params pk sk where b64 = Types.Base64Octets . BA.convert params pk sk = "x" .= b64 pk : (("d" .=) . b64 <$> toList sk) -instance Arbitrary OKPKeyParameters where- arbitrary = oneof- [ Ed25519Key- <$> keyOfLen 32 Ed25519.publicKey- <*> oneof [pure Nothing, Just <$> keyOfLen 32 Ed25519.secretKey]- , X25519Key- <$> keyOfLen 32 Curve25519.publicKey- <*> oneof [pure Nothing, Just <$> keyOfLen 32 Curve25519.secretKey]- ]- where- bsOfLen n = B.pack <$> vectorOf n arbitrary- keyOfLen n con = onCryptoFailure (error . show) id . con <$> bsOfLen n--data OKPCrv = Ed25519 | X25519+data OKPCrv = Ed25519 | Ed448 | X25519 | X448 deriving (Eq, Show) -instance Arbitrary OKPCrv where- arbitrary = elements [Ed25519, X25519]- genOKP :: MonadRandom m => OKPCrv -> m OKPKeyParameters genOKP = \case- Ed25519 -> go 32 Ed25519Key Ed25519.secretKey Ed25519.toPublic- X25519 -> go 32 X25519Key Curve25519.secretKey Curve25519.toPublic- where- go len con skCon toPub = do- (bs :: B.ByteString) <- getRandomBytes len- let sk = onCryptoFailure (error . show) id (skCon bs)- pure $ con (toPub sk) (Just sk)+ Ed25519 -> Ed25519.generateSecretKey >>= \k -> pure (Ed25519Key (Ed25519.toPublic k) (Just k))+ Ed448 -> Ed448.generateSecretKey >>= \k -> pure (Ed448Key (Ed448.toPublic k) (Just k))+ X25519 -> Curve25519.generateSecretKey >>= \k -> pure (X25519Key (Curve25519.toPublic k) (Just k))+ X448 -> Curve448.generateSecretKey >>= \k -> pure (X448Key (Curve448.toPublic k) (Just k)) signEdDSA :: (MonadError e m, AsError e)@@ -565,8 +517,11 @@ -> B.ByteString -> m B.ByteString signEdDSA (Ed25519Key pk (Just sk)) m = pure . BA.convert $ Ed25519.sign sk pk m-signEdDSA (Ed25519Key _ Nothing) _ = throwing _KeyMismatch "not a private key"-signEdDSA _ _ = throwing _KeyMismatch "not an EdDSA key"+signEdDSA (Ed25519Key _ Nothing) _ = throwing _KeyMismatch "not a private key"+signEdDSA (Ed448Key pk (Just sk)) m = pure . BA.convert $ Ed448.sign sk pk m+signEdDSA (Ed448Key _ Nothing) _ = throwing _KeyMismatch "not a private key"+signEdDSA (X25519Key _ _) _ = throwing _KeyMismatch "not an EdDSA key"+signEdDSA (X448Key _ _) _ = throwing _KeyMismatch "not an EdDSA key" verifyEdDSA :: (BA.ByteArrayAccess msg, BA.ByteArrayAccess sig, MonadError e m, AsError e)@@ -576,7 +531,13 @@ (throwing _CryptoError) (pure . Ed25519.verify pk m) (Ed25519.signature s)-verifyEdDSA _ _ _ = throwing _AlgorithmMismatch "not an EdDSA key"+verifyEdDSA (Ed448Key pk _) m s =+ onCryptoFailure+ (throwing _CryptoError)+ (pure . Ed448.verify pk m)+ (Ed448.signature s)+verifyEdDSA (X25519Key _ _) _ _ = throwing _AlgorithmMismatch "not an EdDSA key"+verifyEdDSA (X448Key _ _) _ _ = throwing _AlgorithmMismatch "not an EdDSA key" -- | Key material sum type.@@ -623,14 +584,6 @@ -- ^ Generate an EdDSA or Edwards ECDH key with specified curve. deriving (Eq, Show) -instance Arbitrary KeyMaterialGenParam where- arbitrary = oneof- [ ECGenParam <$> arbitrary- , RSAGenParam <$> elements ((`div` 8) <$> [2048, 3072, 4096])- , OctGenParam <$> liftA2 (+) arbitrarySizedNatural (elements [32, 48, 64])- , OKPGenParam <$> arbitrary- ]- genKeyMaterial :: MonadRandom m => KeyMaterialGenParam -> m KeyMaterial genKeyMaterial (ECGenParam crv) = ECKeyMaterial <$> genEC crv genKeyMaterial (RSAGenParam size) = RSAKeyMaterial <$> genRSA size@@ -648,6 +601,7 @@ 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.ES256K (ECKeyMaterial k@ECKeyParameters{ _ecCrv = Secp256k1 }) = signEC SHA256 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@@ -669,9 +623,10 @@ -> B.ByteString -> m Bool verify JWA.JWS.None _ = \_ s -> pure $ s == ""-verify JWA.JWS.ES256 (ECKeyMaterial k) = fmap pure . verifyEC SHA256 k-verify JWA.JWS.ES384 (ECKeyMaterial k) = fmap pure . verifyEC SHA384 k-verify JWA.JWS.ES512 (ECKeyMaterial k) = fmap pure . verifyEC SHA512 k+verify JWA.JWS.ES256 (ECKeyMaterial k@ECKeyParameters{ _ecCrv = P_256 }) = fmap pure . verifyEC SHA256 k+verify JWA.JWS.ES384 (ECKeyMaterial k@ECKeyParameters{ _ecCrv = P_384 }) = fmap pure . verifyEC SHA384 k+verify JWA.JWS.ES512 (ECKeyMaterial k@ECKeyParameters{ _ecCrv = P_521 }) = fmap pure . verifyEC SHA512 k+verify JWA.JWS.ES256K (ECKeyMaterial k@ECKeyParameters{ _ecCrv = Secp256k1 }) = fmap pure . verifyEC SHA256 k verify JWA.JWS.RS256 (RSAKeyMaterial k) = fmap pure . verifyPKCS15 SHA256 k verify JWA.JWS.RS384 (RSAKeyMaterial k) = fmap pure . verifyPKCS15 SHA384 k verify JWA.JWS.RS512 (RSAKeyMaterial k) = fmap pure . verifyPKCS15 SHA512 k@@ -685,15 +640,7 @@ verify h k = \_ _ -> throwing _AlgorithmMismatch (show h <> " cannot be used with " <> showKeyType k <> " key") -instance Arbitrary KeyMaterial where- arbitrary = oneof- [ ECKeyMaterial <$> arbitrary- , RSAKeyMaterial <$> arbitrary- , OctKeyMaterial <$> arbitrary- , OKPKeyMaterial <$> arbitrary- ] - -- | Keys that may have have public material -- class AsPublicKey k where@@ -709,8 +656,10 @@ instance AsPublicKey OKPKeyParameters where asPublicKey = to $ \case- Ed25519Key pk _ -> Just (Ed25519Key pk Nothing)- X25519Key pk _ -> Just (X25519Key pk Nothing)+ Ed25519Key pk _ -> Just (Ed25519Key pk Nothing)+ Ed448Key pk _ -> Just (Ed448Key pk Nothing)+ X25519Key pk _ -> Just (X25519Key pk Nothing)+ X448Key pk _ -> Just (X448Key pk Nothing) instance AsPublicKey KeyMaterial where asPublicKey = to $ \case
src/Crypto/JOSE/JWA/JWS.hs view
@@ -37,6 +37,7 @@ , "ES256" -- ECDSA P curve and SHA ; RECOMMENDED+ , "ES384" -- ECDSA P curve and SHA ; OPTIONAL , "ES512" -- ECDSA P curve and SHA ; OPTIONAL+ , "ES256K" -- ECDSA using secp256k1 curve and SHA-256 , "PS256" -- RSASSA-PSS SHA ; OPTIONAL , "PS384" -- RSASSA-PSS SHA ; OPTIONAL , "PS512" -- RSSSSA-PSS SHA ; OPTIONAL
src/Crypto/JOSE/JWE.hs view
@@ -29,7 +29,7 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) -import Control.Lens (view)+import Control.Lens (view, views) import Data.Aeson import Data.Aeson.Types import qualified Data.ByteArray as BA@@ -53,6 +53,7 @@ import Crypto.JOSE.JWA.JWE import Crypto.JOSE.JWK import qualified Crypto.JOSE.Types as Types+import Crypto.JOSE.Types.URI import qualified Crypto.JOSE.Types.Internal as Types @@ -92,10 +93,10 @@ <$> parseJSON (Object (fromMaybe mempty hp <> fromMaybe mempty hu)) <*> headerRequired "enc" hp hu <*> headerOptionalProtected "zip" hp hu- <*> headerOptional "jku" hp hu+ <*> headerOptional' uriFromJSON "jku" hp hu <*> headerOptional "jwk" hp hu <*> headerOptional "kid" hp hu- <*> headerOptional "x5u" hp hu+ <*> headerOptional' uriFromJSON "x5u" hp hu <*> (fmap . fmap . fmap . fmap) (\(Types.Base64X509 cert) -> cert) (headerOptional "x5c" hp hu) <*> headerOptional "x5t" hp hu@@ -110,10 +111,10 @@ [ undefined -- TODO , Just (view isProtected enc, "enc" .= view param enc) , fmap (\p -> (True, "zip" .= p)) zip'- , fmap (\p -> (view isProtected p, "jku" .= view param p)) jku+ , fmap (\p -> (view isProtected p, "jku" .= views param uriToJSON p)) jku , fmap (\p -> (view isProtected p, "jwk" .= view param p)) jwk , fmap (\p -> (view isProtected p, "kid" .= view param p)) kid- , fmap (\p -> (view isProtected p, "x5u" .= view param p)) x5u+ , fmap (\p -> (view isProtected p, "x5u" .= views param uriToJSON p)) x5u , fmap (\p -> (view isProtected p, "x5c" .= fmap Types.Base64X509 (view param p))) x5c , fmap (\p -> (view isProtected p, "x5t" .= view param p)) x5t , fmap (\p -> (view isProtected p, "x5t#S256" .= view param p)) x5tS256
src/Crypto/JOSE/JWK.hs view
@@ -18,6 +18,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} {-| @@ -32,10 +33,10 @@ -- doGen :: IO JWK doGen = do- jwk <- 'genJWK' (RSAGenParam (4096 \`div` 8))+ jwk <- 'genJWK' ('RSAGenParam' (4096 \`div` 8)) let h = view 'thumbprint' jwk :: Digest SHA256- kid = view (re ('base64url' . 'digest') . utf8) h+ kid = view (re ('Types.base64url' . 'digest') . utf8) h pure $ set 'jwkKid' (Just kid) jwk @ @@ -81,6 +82,7 @@ , JWKSet(..) -- Miscellaneous+ , checkJWK , bestJWSAlg , module Crypto.JOSE.JWA.JWK@@ -95,11 +97,12 @@ import Control.Lens hiding ((.=)) import Control.Lens.Cons.Extras (recons)-import Control.Monad.Except (MonadError)+import Control.Monad.Except (MonadError, runExcept) import Control.Monad.Error.Lens (throwing, throwing_) import Crypto.Hash import qualified Crypto.PubKey.RSA as RSA import Data.Aeson+import Data.Aeson.Types (explicitParseFieldMaybe') import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L@@ -108,14 +111,13 @@ import qualified Data.Text as T import qualified Data.X509 as X509 -import Test.QuickCheck- import Crypto.JOSE.Error import qualified Crypto.JOSE.JWA.JWE.Alg as JWA.JWE import Crypto.JOSE.JWA.JWK import qualified Crypto.JOSE.JWA.JWS as JWA.JWS import qualified Crypto.JOSE.TH import qualified Crypto.JOSE.Types as Types+import Crypto.JOSE.Types.URI import qualified Crypto.JOSE.Types.Internal as Types @@ -197,7 +199,7 @@ <*> o .:? "key_ops" <*> o .:? "alg" <*> o .:? "kid"- <*> o .:? "x5u"+ <*> explicitParseFieldMaybe' uriFromJSON o "x5u" <*> ((fmap . fmap) (\(Types.Base64X509 cert) -> cert) <$> o .:? "x5c") <*> o .:? "x5t" <*> o .:? "x5t#S256"@@ -216,7 +218,7 @@ , fmap ("use" .=) _jwkUse , fmap ("key_ops" .=) _jwkKeyOps , fmap ("kid" .=) _jwkKid- , fmap ("x5u" .=) _jwkX5u+ , fmap ("x5u" .=) (uriToJSON <$> _jwkX5u) , fmap (("x5c" .=) . fmap Types.Base64X509) _jwkX5cRaw , fmap ("x5t" .=) _jwkX5t , fmap ("x5t#S256" .=) _jwkX5tS256@@ -227,18 +229,6 @@ genJWK :: MonadRandom m => KeyMaterialGenParam -> m JWK genJWK p = fromKeyMaterial <$> genKeyMaterial p -instance Arbitrary JWK where- arbitrary = JWK- <$> arbitrary- <*> pure Nothing- <*> pure Nothing- <*> pure Nothing- <*> arbitrary- <*> pure Nothing- <*> pure Nothing- <*> arbitrary- <*> arbitrary- fromKeyMaterial :: KeyMaterial -> JWK fromKeyMaterial k = JWK k z z z z z z z z where z = Nothing @@ -255,7 +245,7 @@ -- | Convert an EC public key into a JWK ---fromECPublic :: X509.PubKeyEC -> Maybe JWK+fromECPublic :: (AsError e, MonadError e m) => X509.PubKeyEC -> m JWK fromECPublic = fmap (fromKeyMaterial . ECKeyMaterial) . ecParametersFromX509 @@ -270,26 +260,27 @@ -- | Convert an X.509 certificate into a JWK. ----- Only RSA keys are supported. Other key types will throw--- 'KeyMismatch'.+-- Supports RSA and ECDSA (when the curve is supported). Other key types+-- will throw 'AlgorithmNotImplemented'. -- -- The @"x5c"@ field of the resulting JWK contains the certificate. -- fromX509Certificate :: (AsError e, MonadError e m) => X509.SignedCertificate -> m JWK-fromX509Certificate =- maybe (throwing _KeyMismatch "X.509 key type not supported") pure- . fromX509CertificateMaybe--fromX509CertificateMaybe :: X509.SignedCertificate -> Maybe JWK-fromX509CertificateMaybe cert = do+fromX509Certificate cert = do k <- case (X509.certPubKey . X509.signedObject . X509.getSigned) cert of X509.PubKeyRSA k -> pure (fromRSAPublic k) X509.PubKeyEC k -> fromECPublic k- _ -> Nothing+ _ -> throwing _KeyMismatch "X.509 key type not supported" pure $ k & set jwkX5cRaw (Just (pure cert)) +fromX509CertificateMaybe :: X509.SignedCertificate -> Maybe JWK+fromX509CertificateMaybe = f . runExcept . fromX509Certificate+ where+ f :: Either Error JWK -> Maybe JWK+ f (Left _) = Nothing+ f (Right jwk) = Just jwk instance AsPublicKey JWK where@@ -307,6 +298,23 @@ toJSON (JWKSet ks) = object ["keys" .= toJSON ks] +-- | Sanity-check a JWK.+--+-- Return an appropriate error if the key is size is too small to be+-- used with any JOSE algorithm, or for other problems that mean the+-- key cannot be used.+--+checkJWK :: (MonadError e m, AsError e) => JWK -> m ()+checkJWK jwk = case view jwkMaterial jwk of+ RSAKeyMaterial (view rsaN -> Types.Base64Integer n)+ | n >= 2 ^ (2040 :: Integer) -> pure ()+ | otherwise -> throwing _KeySizeTooSmall ()+ OctKeyMaterial (view octK -> Types.Base64Octets k)+ | B.length k >= 256 `div` 8 -> pure ()+ | otherwise -> throwing _KeySizeTooSmall ()+ _ -> pure ()++ -- | Choose the cryptographically strongest JWS algorithm for a -- given key. The JWK "alg" algorithm parameter is ignored. --@@ -319,6 +327,7 @@ P_256 -> JWA.JWS.ES256 P_384 -> JWA.JWS.ES384 P_521 -> JWA.JWS.ES512+ Secp256k1 -> JWA.JWS.ES256K RSAKeyMaterial k -> let Types.Base64Integer n = view rsaN k@@ -331,8 +340,11 @@ | B.length k >= 384 `div` 8 -> pure JWA.JWS.HS384 | B.length k >= 256 `div` 8 -> pure JWA.JWS.HS256 | otherwise -> throwing_ _KeySizeTooSmall- OKPKeyMaterial (Ed25519Key _ _) -> pure JWA.JWS.EdDSA- OKPKeyMaterial _ -> throwing _KeyMismatch "Cannot sign with OKP ECDH key"+ OKPKeyMaterial k -> case k of+ (Ed25519Key _ _) -> pure JWA.JWS.EdDSA+ (Ed448Key _ _) -> pure JWA.JWS.EdDSA+ (X25519Key _ _) -> throwing _KeyMismatch "Cannot sign with X25519 key"+ (X448Key _ _) -> throwing _KeyMismatch "Cannot sign with X448 key" -- | Compute the JWK Thumbprint of a JWK@@ -362,7 +374,9 @@ OctKeyMaterial (OctKeyParameters k') -> "k" .= k' <> "kty" .= ("oct" :: T.Text) OKPKeyMaterial (Ed25519Key pk _) -> okpSeries "Ed25519" pk+ OKPKeyMaterial (Ed448Key pk _) -> okpSeries "Ed448" pk OKPKeyMaterial (X25519Key pk _) -> okpSeries "X25519" pk+ OKPKeyMaterial (X448Key pk _) -> okpSeries "X448" pk where b64 = Types.Base64Octets . BA.convert okpSeries crv pk =
src/Crypto/JOSE/JWS.hs view
@@ -20,13 +20,16 @@ <https://tools.ietf.org/html/rfc7515 RFC 7515>. @+import Crypto.JOSE+ doJwsSign :: 'JWK' -> L.ByteString -> IO (Either 'Error' ('GeneralJWS' 'JWSHeader'))-doJwsSign jwk payload = runExceptT $ do+doJwsSign jwk payload = 'runJOSE' $ do alg \<- 'bestJWSAlg' jwk 'signJWS' payload [('newJWSHeader' ('Protected', alg), jwk)] doJwsVerify :: 'JWK' -> 'GeneralJWS' 'JWSHeader' -> IO (Either 'Error' ())-doJwsVerify jwk jws = runExceptT $ 'verifyJWS'' jwk jws+doJwsVerify jwk jws = 'runJOSE' $+ 'verifyJWS'' jwk jws @ -}@@ -86,6 +89,7 @@ ) where import Control.Applicative ((<|>))+import Control.Monad (unless) import Data.Foldable (toList) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>))@@ -95,7 +99,7 @@ import Control.Lens hiding ((.=)) import Control.Lens.Cons.Extras (recons) import Control.Monad.Error.Lens (throwing, throwing_)-import Control.Monad.Except (MonadError, unless)+import Control.Monad.Except (MonadError) import Data.Aeson import qualified Data.Aeson.KeyMap as M import qualified Data.ByteString as B@@ -110,6 +114,7 @@ import Crypto.JOSE.JWK.Store import Crypto.JOSE.Header import qualified Crypto.JOSE.Types as Types+import Crypto.JOSE.Types.URI import qualified Crypto.JOSE.Types.Internal as Types {- $extending@@ -154,6 +159,7 @@ - 'headerRequired' - 'headerRequiredProtected' - 'headerOptional'+- 'headerOptional'' - 'headerOptionalProtected' -}@@ -329,10 +335,10 @@ instance HasParams JWSHeader where parseParamsFor proxy hp hu = JWSHeader <$> headerRequired "alg" hp hu- <*> headerOptional "jku" hp hu+ <*> headerOptional' uriFromJSON "jku" hp hu <*> headerOptional "jwk" hp hu <*> headerOptional "kid" hp hu- <*> headerOptional "x5u" hp hu+ <*> headerOptional' uriFromJSON "x5u" hp hu <*> (fmap . fmap . fmap . fmap) (\(Types.Base64X509 cert) -> cert) (headerOptional "x5c" hp hu) <*> headerOptional "x5t" hp hu@@ -345,10 +351,10 @@ params h = catMaybes [ Just (view (alg . isProtected) h, "alg" .= view (alg . param) h)- , fmap (\p -> (view isProtected p, "jku" .= view param p)) (view jku h)+ , fmap (\p -> (view isProtected p, "jku" .= views param uriToJSON p)) (view jku h) , fmap (\p -> (view isProtected p, "jwk" .= view param p)) (view jwk h) , fmap (\p -> (view isProtected p, "kid" .= view param p)) (view kid h)- , fmap (\p -> (view isProtected p, "x5u" .= view param p)) (view x5u h)+ , fmap (\p -> (view isProtected p, "x5u" .= views param uriToJSON p)) (view x5u h) , fmap (\p -> (view isProtected p, "x5c" .= fmap Types.Base64X509 (view param p))) (view x5c h) , fmap (\p -> (view isProtected p, "x5t" .= view param p)) (view x5t h) , fmap (\p -> (view isProtected p, "x5t#S256" .= view param p)) (view x5tS256 h)@@ -567,6 +573,7 @@ , ES256, ES384, ES512 , PS256, PS384, PS512 , EdDSA+ , ES256K ] ) AllValidated
src/Crypto/JOSE/Types.hs view
@@ -26,7 +26,6 @@ , _Base64Integer , SizedBase64Integer(..) , makeSizedBase64Integer- , genSizedBase64IntegerOf , checkSize , Base64Octets(..) , Base64SHA1(..)@@ -37,20 +36,14 @@ , base64url ) where -import Data.Word (Word8)- import Control.Lens import Data.Aeson import Data.Aeson.Types (Parser) import qualified Data.ByteString as B import Data.X509 import Network.URI (URI)-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.@@ -88,22 +81,6 @@ 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 =- (arbitraryBoundedIntegral :: Gen Word8)- >>= go (k - 1) . (n * 256 +) . fromIntegral---instance Arbitrary Base64Integer where- arbitrary = Base64Integer <$> arbitraryBigInteger-- -- | A base64url encoded octet sequence interpreted as an integer -- and where the number of octets carries explicit bit-length -- information.@@ -114,21 +91,6 @@ instance Eq SizedBase64Integer where SizedBase64Integer _ n == SizedBase64Integer _ m = n == m -instance Arbitrary SizedBase64Integer where- arbitrary = do- 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---- | Generate a 'SizedBase64Integer' of the given number of bytes----genSizedBase64IntegerOf :: Int -> Gen SizedBase64Integer-genSizedBase64IntegerOf n =- SizedBase64Integer n . bsToInteger <$> genByteStringOf n- -- | Create a 'SizedBase64Integer'' from an 'Integer'. makeSizedBase64Integer :: Integer -> SizedBase64Integer makeSizedBase64Integer x = SizedBase64Integer (intBytes x) x@@ -160,10 +122,7 @@ instance ToJSON Base64Octets where toJSON (Base64Octets bytes) = encodeB64Url bytes -instance Arbitrary Base64Octets where- arbitrary = Base64Octets <$> arbitrary - -- | A base64url encoded SHA-1 digest. Used for X.509 certificate -- thumbprints. --@@ -179,10 +138,7 @@ instance ToJSON Base64SHA1 where toJSON (Base64SHA1 bytes) = encodeB64Url bytes -instance Arbitrary Base64SHA1 where- arbitrary = Base64SHA1 <$> genByteStringOf 20 - -- | A base64url encoded SHA-256 digest. Used for X.509 certificate -- thumbprints. --@@ -197,9 +153,6 @@ instance ToJSON Base64SHA256 where toJSON (Base64SHA256 bytes) = encodeB64Url bytes--instance Arbitrary Base64SHA256 where- arbitrary = Base64SHA256 <$> genByteStringOf 32 -- | A base64 encoded X.509 certificate.
− src/Crypto/JOSE/Types/Orphans.hs
@@ -1,29 +0,0 @@--- Copyright (C) 2014, 2015, 2016 Fraser Tweedale------ Licensed under the Apache License, Version 2.0 (the "License");--- you may not use this file except in compliance with the License.--- You may obtain a copy of the License at------ http://www.apache.org/licenses/LICENSE-2.0------ Unless required by applicable law or agreed to in writing, software--- distributed under the License is distributed on an "AS IS" BASIS,--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.--- See the License for the specific language governing permissions and--- limitations under the License.--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Crypto.JOSE.Types.Orphans where--import Data.Aeson-import qualified Data.Text as T-import Network.URI (URI, parseURI)---instance FromJSON URI where- parseJSON = withText "URI" $- maybe (fail "not a URI") return . parseURI . T.unpack--instance ToJSON URI where- toJSON = String . T.pack . show
+ src/Crypto/JOSE/Types/URI.hs view
@@ -0,0 +1,29 @@+-- Copyright (C) 2014-2022 Fraser Tweedale+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++module Crypto.JOSE.Types.URI+ ( uriFromJSON+ , uriToJSON+ ) where++import Data.Aeson+import Data.Aeson.Types (Parser)+import qualified Data.Text as T+import Network.URI (URI, parseURI)++uriFromJSON :: Value -> Parser URI+uriFromJSON = withText "URI" $ maybe (fail "not a URI") pure . parseURI . T.unpack++uriToJSON :: URI -> Value+uriToJSON = String . T.pack . show
src/Crypto/JWT.hs view
@@ -31,6 +31,8 @@ See "Crypto.JOSE.Compact" for details. @+import Crypto.JWT+ mkClaims :: IO 'ClaimsSet' mkClaims = do t <- 'currentTime'@@ -40,12 +42,12 @@ & 'claimIat' ?~ 'NumericDate' t doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT')-doJwtSign jwk claims = runExceptT $ do+doJwtSign jwk claims = 'runJOSE' $ do alg \<- 'bestJWSAlg' jwk 'signClaims' jwk ('newJWSHeader' ((), alg)) claims doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet')-doJwtVerify jwk jwt = runExceptT $ do+doJwtVerify jwk jwt = 'runJOSE' $ do let config = 'defaultJWTValidationSettings' (== "bob") 'verifyClaims' config jwk jwt @@@ -56,25 +58,56 @@ @ verify :: L.ByteString -> L.ByteString -> IO (Either 'JWTError' 'ClaimsSet')-verify k s = runExceptT $ do+verify k s = 'runJOSE' $ 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'+ jwt <- 'decodeCompact' s -- decode JWT+ 'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' jwt @ +For applications that use __additional claims__, define a data type that wraps+'ClaimsSet' and includes fields for the additional claims. You will also need+to define 'FromJSON' if verifying JWTs, and 'ToJSON' if producing JWTs. The+following example is taken from+<https://datatracker.ietf.org/doc/html/rfc7519#section-3.1 RFC 7519 §3.1>.++@+import qualified Data.Aeson.KeyMap as M++data Super = Super { jwtClaims :: 'ClaimsSet', isRoot :: Bool }++instance 'HasClaimsSet' Super where+ 'claimsSet' f s = fmap (\\a' -> s { jwtClaims = a' }) (f (jwtClaims s))++instance FromJSON Super where+ parseJSON = withObject "Super" $ \\o -> Super+ \<$\> parseJSON (Object o)+ \<*\> o .: "http://example.com/is_root"++instance ToJSON Super where+ toJSON s =+ ins "http://example.com/is_root" (isRoot s) (toJSON (jwtClaims s))+ where+ ins k v (Object o) = Object $ M.insert k (toJSON v) o+ ins _ _ a = a+@++__Use 'signJWT' and 'verifyJWT' when using custom payload types__ (instead of+'signClaims' and 'verifyClaims' which are specialised to 'ClaimsSet').+ -} module Crypto.JWT ( -- * Creating a JWT- signClaims- , SignedJWT+ SignedJWT+ , signClaims+ , signJWT -- * Validating a JWT and extracting claims , defaultJWTValidationSettings , verifyClaims- , verifyClaimsAt+ , verifyJWT , HasAllowedSkew(..) , HasAudiencePredicate(..) , HasIssuerPredicate(..)@@ -82,18 +115,17 @@ , JWTValidationSettings , HasJWTValidationSettings(..) + -- ** Specifying the verification time+ , WrappedUTCTime(..)+ , verifyClaimsAt+ , verifyJWTAt+ -- * Claims Set+ , HasClaimsSet(..) , ClaimsSet- , claimAud- , claimExp- , claimIat- , claimIss- , claimJti- , claimNbf- , claimSub- , unregisteredClaims- , addClaim , emptyClaimsSet+ , addClaim+ , unregisteredClaims , validateClaimsSet -- * JWT errors@@ -241,9 +273,14 @@ -- | The JWT Claims Set represents a JSON object whose members are--- the registered claims defined by RFC 7519. Unrecognised--- claims are gathered into the 'unregisteredClaims' map.+-- the registered claims defined by RFC 7519. To construct a+-- @ClaimsSet@ use 'emptyClaimsSet' then use the lenses from this+-- class to set relevant claims. --+-- For applications that use additional claims beyond those defined+-- by RFC 7519, define a new data type and instance 'HasClaimsSet'.+-- See the module synopsis for more details and an example.+-- data ClaimsSet = ClaimsSet { _claimIss :: Maybe StringOrURI , _claimSub :: Maybe StringOrURI@@ -256,83 +293,118 @@ } deriving (Eq, Show) --- | The issuer claim identifies the principal that issued the--- JWT. The processing of this claim is generally application--- specific.-claimIss :: Lens' ClaimsSet (Maybe StringOrURI)-claimIss f h@ClaimsSet{ _claimIss = a} =- fmap (\a' -> h { _claimIss = a' }) (f a)+class HasClaimsSet a where+ claimsSet :: Lens' a ClaimsSet --- | The subject claim identifies the principal that is the--- subject of the JWT. The Claims in a JWT are normally--- statements about the subject. The subject value MAY be scoped--- to be locally unique in the context of the issuer or MAY be--- globally unique. The processing of this claim is generally--- application specific.-claimSub :: Lens' ClaimsSet (Maybe StringOrURI)-claimSub f h@ClaimsSet{ _claimSub = a} =- fmap (\a' -> h { _claimSub = a' }) (f a)+ -- | The issuer claim identifies the principal that issued the+ -- JWT. The processing of this claim is generally application+ -- specific.+ claimIss :: Lens' a (Maybe StringOrURI)+ {-# INLINE claimIss #-} --- | The audience claim identifies the recipients that the JWT is--- intended for. Each principal intended to process the JWT MUST--- identify itself with a value in the audience claim. If the--- principal processing the claim does not identify itself with a--- value in the /aud/ claim when this claim is present, then the--- JWT MUST be rejected.-claimAud :: Lens' ClaimsSet (Maybe Audience)-claimAud f h@ClaimsSet{ _claimAud = a} =- fmap (\a' -> h { _claimAud = a' }) (f a)+ -- | The subject claim identifies the principal that is the+ -- subject of the JWT. The Claims in a JWT are normally+ -- statements about the subject. The subject value MAY be scoped+ -- to be locally unique in the context of the issuer or MAY be+ -- globally unique. The processing of this claim is generally+ -- application specific.+ claimSub :: Lens' a (Maybe StringOrURI)+ {-# INLINE claimSub #-} --- | The expiration time claim identifies the expiration time on--- or after which the JWT MUST NOT be accepted for processing.--- The processing of /exp/ claim requires that the current--- date\/time MUST be before expiration date\/time listed in the--- /exp/ claim. Implementers MAY provide for some small leeway,--- usually no more than a few minutes, to account for clock skew.-claimExp :: Lens' ClaimsSet (Maybe NumericDate)-claimExp f h@ClaimsSet{ _claimExp = a} =- fmap (\a' -> h { _claimExp = a' }) (f a)+ -- | The audience claim identifies the recipients that the JWT is+ -- intended for. Each principal intended to process the JWT MUST+ -- identify itself with a value in the audience claim. If the+ -- principal processing the claim does not identify itself with a+ -- value in the /aud/ claim when this claim is present, then the+ -- JWT MUST be rejected.+ claimAud :: Lens' a (Maybe Audience)+ {-# INLINE claimAud #-} --- | The not before claim identifies the time before which the JWT--- MUST NOT be accepted for processing. The processing of the--- /nbf/ claim requires that the current date\/time MUST be after--- or equal to the not-before date\/time listed in the /nbf/--- claim. Implementers MAY provide for some small leeway, usually--- no more than a few minutes, to account for clock skew.-claimNbf :: Lens' ClaimsSet (Maybe NumericDate)-claimNbf f h@ClaimsSet{ _claimNbf = a} =- fmap (\a' -> h { _claimNbf = a' }) (f a)+ -- | The expiration time claim identifies the expiration time on+ -- or after which the JWT MUST NOT be accepted for processing.+ -- The processing of /exp/ claim requires that the current+ -- date\/time MUST be before expiration date\/time listed in the+ -- /exp/ claim. Implementers MAY provide for some small leeway,+ -- usually no more than a few minutes, to account for clock skew.+ claimExp :: Lens' a (Maybe NumericDate)+ {-# INLINE claimExp #-} --- | The issued at claim identifies the time at which the JWT was--- issued. This claim can be used to determine the age of the--- JWT.-claimIat :: Lens' ClaimsSet (Maybe NumericDate)-claimIat f h@ClaimsSet{ _claimIat = a} =- fmap (\a' -> h { _claimIat = a' }) (f a)+ -- | The not before claim identifies the time before which the JWT+ -- MUST NOT be accepted for processing. The processing of the+ -- /nbf/ claim requires that the current date\/time MUST be after+ -- or equal to the not-before date\/time listed in the /nbf/+ -- claim. Implementers MAY provide for some small leeway, usually+ -- no more than a few minutes, to account for clock skew.+ claimNbf :: Lens' a (Maybe NumericDate)+ {-# INLINE claimNbf #-} --- | The JWT ID claim provides a unique identifier for the JWT.--- The identifier value MUST be assigned in a manner that ensures--- that there is a negligible probability that the same value will--- be accidentally assigned to a different data object. The /jti/--- claim can be used to prevent the JWT from being replayed. The--- /jti/ value is a case-sensitive string.-claimJti :: Lens' ClaimsSet (Maybe T.Text)-claimJti f h@ClaimsSet{ _claimJti = a} =- fmap (\a' -> h { _claimJti = a' }) (f a)+ -- | The issued at claim identifies the time at which the JWT was+ -- issued. This claim can be used to determine the age of the+ -- JWT.+ claimIat :: Lens' a (Maybe NumericDate)+ {-# INLINE claimIat #-} + -- | The JWT ID claim provides a unique identifier for the JWT.+ -- The identifier value MUST be assigned in a manner that ensures+ -- that there is a negligible probability that the same value will+ -- be accidentally assigned to a different data object. The /jti/+ -- claim can be used to prevent the JWT from being replayed. The+ -- /jti/ value is a case-sensitive string.+ claimJti :: Lens' a (Maybe T.Text)+ {-# INLINE claimJti #-}++ claimAud = ((.) claimsSet) claimAud+ claimExp = ((.) claimsSet) claimExp+ claimIat = ((.) claimsSet) claimIat+ claimIss = ((.) claimsSet) claimIss+ claimJti = ((.) claimsSet) claimJti+ claimNbf = ((.) claimsSet) claimNbf+ claimSub = ((.) claimsSet) claimSub++instance HasClaimsSet ClaimsSet where+ claimsSet = id++ claimIss f h@ClaimsSet{ _claimIss = a} = fmap (\a' -> h { _claimIss = a' }) (f a)+ {-# INLINE claimIss #-}++ claimSub f h@ClaimsSet{ _claimSub = a} = fmap (\a' -> h { _claimSub = a' }) (f a)+ {-# INLINE claimSub #-}++ claimAud f h@ClaimsSet{ _claimAud = a} = fmap (\a' -> h { _claimAud = a' }) (f a)+ {-# INLINE claimAud #-}++ claimExp f h@ClaimsSet{ _claimExp = a} = fmap (\a' -> h { _claimExp = a' }) (f a)+ {-# INLINE claimExp #-}++ claimNbf f h@ClaimsSet{ _claimNbf = a} = fmap (\a' -> h { _claimNbf = a' }) (f a)+ {-# INLINE claimNbf #-}++ claimIat f h@ClaimsSet{ _claimIat = a} = fmap (\a' -> h { _claimIat = a' }) (f a)+ {-# INLINE claimIat #-}++ claimJti f h@ClaimsSet{ _claimJti = a} = fmap (\a' -> h { _claimJti = a' }) (f a)+ {-# INLINE claimJti #-}+ -- | Claim Names can be defined at will by those using JWTs.+-- Use this lens to access a map non-RFC 7519 claims in the+-- Claims Set object. unregisteredClaims :: Lens' ClaimsSet (M.Map T.Text Value) unregisteredClaims f h@ClaimsSet{ _unregisteredClaims = a} = fmap (\a' -> h { _unregisteredClaims = a' }) (f a)-+{-# INLINE unregisteredClaims #-}+{-# DEPRECATED unregisteredClaims "use a sub-type" #-} -- | Return an empty claims set. -- emptyClaimsSet :: ClaimsSet emptyClaimsSet = ClaimsSet n n n n n n n M.empty where n = Nothing +-- | Add a __non-RFC 7519__ claim. Use the lenses from the+-- 'HasClaimsSet' class for setting registered claims.+-- addClaim :: T.Text -> Value -> ClaimsSet -> ClaimsSet addClaim k v = over unregisteredClaims (M.insert k v)+{-# DEPRECATED addClaim "'unregisteredClaims' is deprecated; use a sub-type" #-} registeredClaims :: S.Set T.Text registeredClaims = S.fromDistinctAscList@@ -448,9 +520,9 @@ -- | Validate the claims made by a ClaimsSet. ----- These checks are performed by 'verifyClaims', which also--- validates any signatures, so you shouldn't need to use this--- function directly.+-- __You should never need to use this function directly.__+-- These checks are always performed by 'verifyClaims' and 'verifyJWT'.+-- The function is exported mainly for testing purposes. -- validateClaimsSet ::@@ -538,45 +610,90 @@ instance Monad m => MonadTime (ReaderT WrappedUTCTime m) where currentTime = asks getUTCTime+#if MIN_VERSION_monad_time(0,4,0)+ -- | /jose/ doesn't use this, so we fake it.+ -- @monotonicTime = pure 0@+ monotonicTime = pure 0+#endif -- | Cryptographically verify a JWS JWT, then validate the--- Claims Set, returning it if valid.+-- Claims Set, returning it if valid. The claims are validated+-- at the current system time. -- -- This is the only way to get at the claims of a JWS JWT, -- enforcing that the claims are cryptographically and -- semantically valid before the application can use them. --+-- This function is abstracted over any payload type with 'HasClaimsSet' and+-- 'FromJSON' instances. The 'verifyClaims' variant uses 'ClaimsSet' as the+-- payload type.+-- -- See also 'verifyClaimsAt' which allows you to explicitly specify--- the time.+-- the time of validation (against which time-related claims will be+-- validated). ---verifyClaims+verifyJWT :: ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a , HasIssuerPredicate a , HasCheckIssuedAt a , HasValidationSettings a , AsError e, AsJWTError e, MonadError e m- , VerificationKeyStore m (JWSHeader ()) ClaimsSet k+ , VerificationKeyStore m (JWSHeader ()) payload k+ , HasClaimsSet payload, FromJSON payload ) => a -> k -> SignedJWT- -> m ClaimsSet-verifyClaims conf k jws =+ -> m payload+verifyJWT conf k jws = -- It is important, for security reasons, that the signature get -- verified before the claims.- verifyJWSWithPayload f conf k jws >>= validateClaimsSet conf+ verifyJWSWithPayload f conf k jws >>= claimsSet (validateClaimsSet conf) where f = either (throwing _JWTClaimsSetDecodeError) pure . eitherDecode +-- | Variant of 'verifyJWT' that uses 'ClaimsSet' as the payload type.+--+verifyClaims+ ::+ ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a+ , HasIssuerPredicate a+ , HasCheckIssuedAt a+ , HasValidationSettings a+ , AsError e, AsJWTError e, MonadError e m+ , VerificationKeyStore m (JWSHeader ()) ClaimsSet k+ )+ => a+ -> k+ -> SignedJWT+ -> m ClaimsSet+verifyClaims = verifyJWT --- | Cryptographically verify a JWS JWT, then validate the--- Claims Set, returning it if valid.+-- | Variant of 'verifyJWT' where the validation time is provided by+-- caller. If you process many tokens per second+-- this lets you avoid unnecessary repeat system calls. ----- 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.+verifyJWTAt+ ::+ ( HasAllowedSkew a, HasAudiencePredicate a+ , HasIssuerPredicate a+ , HasCheckIssuedAt a+ , HasValidationSettings a+ , AsError e, AsJWTError e, MonadError e m+ , VerificationKeyStore (ReaderT WrappedUTCTime m) (JWSHeader ()) payload k+ , HasClaimsSet payload, FromJSON payload+ )+ => a+ -> k+ -> UTCTime+ -> SignedJWT+ -> m payload+verifyJWTAt a k t jwt = runReaderT (verifyJWT a k jwt) (WrappedUTCTime t)++-- | Variant of 'verifyJWT' that uses 'ClaimsSet' as the payload type and+-- where validation time is provided by caller. -- verifyClaimsAt ::@@ -592,14 +709,35 @@ -> UTCTime -> SignedJWT -> m ClaimsSet-verifyClaimsAt a k t jwt = runReaderT (verifyClaims a k jwt) (WrappedUTCTime t)+verifyClaimsAt = verifyJWTAt --- | Create a JWS JWT++-- | Create a JWS JWT. The payload can be any type with a 'ToJSON'+-- instance. See also 'signClaims' which uses 'ClaimsSet' as the+-- payload type. --+-- __Does not set any fields in the Claims Set__, such as @"iat"@+-- ("Issued At") Claim. The payload is encoded as-is.+--+signJWT+ :: ( MonadRandom m, MonadError e m, AsError e+ , ToJSON payload )+ => JWK+ -> JWSHeader ()+ -> payload+ -> m SignedJWT+signJWT k h c = signJWS (encode c) (Identity (h, k))++-- | Create a JWS JWT. Specialisation of 'signJWT' with payload type fixed+-- at 'ClaimsSet'.+--+-- __Does not set any fields in the Claims Set__, such as @"iat"@+-- ("Issued At") Claim. The payload is encoded as-is.+-- signClaims :: (MonadRandom m, MonadError e m, AsError e) => JWK -> JWSHeader () -> ClaimsSet -> m SignedJWT-signClaims k h c = signJWS (encode c) (Identity (h, k))+signClaims = signJWT
test/AESKW.hs view
@@ -12,6 +12,9 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+ module AESKW where import qualified Data.ByteString as B@@ -19,36 +22,39 @@ import Crypto.Cipher.Types import Crypto.Error -import Test.QuickCheck.Monadic+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range import Test.Tasty-import Test.Tasty.QuickCheck+import Test.Tasty.Hedgehog import Crypto.JOSE.AESKW aeskwProperties :: TestTree aeskwProperties = testGroup "AESKW"- [ testProperty "AESKW round-trip" prop_roundTrip+ [ let n = "AESKW round-trip" in testPropertyNamed n n prop_roundTrip ] prop_roundTrip :: Property-prop_roundTrip = monadicIO $ do- cekLen <- (* 8) . (+ 2) <$> pick arbitrarySizedNatural- cek <- pick $ B.pack <$> vectorOf cekLen arbitrary- kekLen <- pick $ oneof $ pure <$> [16, 24, 32]- kek <- pick $ B.pack <$> vectorOf kekLen arbitrary+prop_roundTrip = property $ do+ cekLen <- forAll $ (* 8) . (+ 2) <$> Gen.integral (Range.linear 0 16)+ cek <- forAll $ Gen.bytes (Range.singleton cekLen)+ kekLen <- forAll $ Gen.element [16, 24, 32]+ kek <- forAll $ Gen.bytes (Range.singleton kekLen) let- check :: BlockCipher128 cipher => CryptoFailable cipher -> Bool- check cipher' = case cipher' of- CryptoFailed _ -> False- CryptoPassed cipher ->+ go cipher' = case cipher' of+ CryptoFailed _ -> do+ annotate "cipherInit failed"+ failure+ CryptoPassed cipher -> do let c = aesKeyWrap cipher cek :: B.ByteString cek' = aesKeyUnwrap cipher c- in- B.length c == cekLen + 8 && cek' == Just cek+ B.length c === cekLen + 8+ cek' === Just cek case kekLen of- 16 -> assert $ check (cipherInit kek :: CryptoFailable AES128)- 24 -> assert $ check (cipherInit kek :: CryptoFailable AES192)- 32 -> assert $ check (cipherInit kek :: CryptoFailable AES256)- _ -> assert False -- can't happen+ 16 -> go (cipherInit kek :: CryptoFailable AES128)+ 24 -> go (cipherInit kek :: CryptoFailable AES192)+ 32 -> go (cipherInit kek :: CryptoFailable AES256)+ _ -> annotate "the impossible happened" *> failure -- can't happen
test/JWS.hs view
@@ -22,7 +22,6 @@ import Control.Lens hiding ((.=)) import Control.Lens.Extras (is) import Control.Lens.Cons.Extras (recons)-import Control.Monad.Except (runExceptT) import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Base64.URL as B64U@@ -221,8 +220,7 @@ fmap encodeCompact jws `shouldBe` Right compactJWS it "computes the HMAC correctly" $- fst (withDRG drg $- runExceptT (sign alg_ (k ^. jwkMaterial) (signingInput' ^. recons)))+ fst (withDRG drg $ runJOSE $ (sign alg_ (k ^. jwkMaterial) (signingInput' ^. recons))) `shouldBe` (Right mac :: Either Error BS.ByteString) it "validates the JWS correctly" $@@ -275,7 +273,7 @@ appendixA2Spec :: Spec appendixA2Spec = describe "RFC 7515 A.2. Example JWS using RSASSA-PKCS-v1_5 SHA-256" $ do it "computes the signature correctly" $- fst (withDRG drg $ runExceptT (sign JWA.JWS.RS256 (k ^. jwkMaterial) signingInput'))+ fst (withDRG drg $ runJOSE (sign JWA.JWS.RS256 (k ^. jwkMaterial) signingInput')) `shouldBe` (Right sig :: Either Error BS.ByteString) it "validates the signature correctly" $@@ -283,7 +281,7 @@ `shouldBe` (Right True :: Either Error Bool) it "prohibits signing with 1024-bit key" $- fst (withDRG drg (runExceptT $+ fst (withDRG drg (runJOSE $ signJWS signingInput' (Identity (newJWSHeader ((), JWA.JWS.RS256), jwkRSA1024)))) `shouldBe` (Left KeySizeTooSmall :: Either Error (CompactJWS JWSHeader)) @@ -366,7 +364,7 @@ decodeCompact exampleJWS `shouldBe` jws where- jws = fst $ withDRG drg $ runExceptT $+ jws = fst $ withDRG drg $ runJOSE $ signJWS examplePayloadBytes (Identity (newJWSHeader ((), JWA.JWS.None), undefined)) :: Either Error (CompactJWS JWSHeader) exampleJWS = "eyJhbGciOiJub25lIn0\@@ -514,7 +512,7 @@ sig = BS.pack sigOctets signingInput = "eyJhbGciOiJFZERTQSJ9.RXhhbXBsZSBvZiBFZDI1NTE5IHNpZ25pbmc" it "computes the correct signature" $- fst (withDRG drg $ runExceptT (sign JWA.JWS.EdDSA (view jwkMaterial k) signingInput))+ fst (withDRG drg $ runJOSE (sign JWA.JWS.EdDSA (view jwkMaterial k) signingInput)) `shouldBe` (Right sig :: Either Error BS.ByteString) it "validates signatures correctly" $ verify JWA.JWS.EdDSA (view jwkMaterial k) signingInput sig
test/JWT.hs view
@@ -20,12 +20,13 @@ import Data.Maybe import Data.Monoid ((<>)) +import qualified Data.ByteString.Lazy as L import Control.Lens import Control.Lens.Extras (is)-import Control.Monad.Except (runExceptT) import Control.Monad.Trans (liftIO) import Control.Monad.Reader (runReaderT) import Data.Aeson hiding ((.=))+import qualified Data.Aeson.KeyMap as M import qualified Data.Set as S import Data.Time import Network.URI (parseURI)@@ -37,9 +38,43 @@ intDate :: String -> Maybe NumericDate intDate = fmap NumericDate . parseTimeM True defaultTimeLocale "%F %T" -utcTime :: String -> UTCTime-utcTime = fromJust . parseTimeM True defaultTimeLocale "%F %T"+utcTime :: String -> WrappedUTCTime+utcTime = WrappedUTCTime . fromJust . parseTimeM True defaultTimeLocale "%F %T" +--+-- example extended JWT payload type+--++data Super = Super { jwtClaims :: ClaimsSet, isRoot :: Bool }+ deriving (Eq, Show)++instance HasClaimsSet Super where+ claimsSet f s = fmap (\a' -> s { jwtClaims = a' }) (f (jwtClaims s))++instance FromJSON Super where+ parseJSON = withObject "Super" $ \o -> Super+ <$> parseJSON (Object o)+ <*> o .: "http://example.com/is_root"++instance ToJSON Super where+ toJSON s =+ ins "http://example.com/is_root" (isRoot s) (toJSON (jwtClaims s))+ where+ ins k v (Object o) = Object $ M.insert k (toJSON v) o+ ins _ _ a = a++super :: Super+super = Super+ { jwtClaims = exampleClaimsSet+ , isRoot = True+ }++claimsJSON :: L.ByteString+claimsJSON =+ "{\"iss\":\"joe\",\r\n"+ <> "\"exp\":1300819380,\r\n"+ <> "\"http://example.com/is_root\":true}"+ exampleClaimsSet :: ClaimsSet exampleClaimsSet = emptyClaimsSet & claimIss .~ preview stringOrUri ("joe" :: String)@@ -54,25 +89,40 @@ headMay (h:_) = Just h describe "JWT Claims Set" $ do- it "parses from JSON correctly" $+ it "parses from JSON correctly" $ do+ decode claimsJSON `shouldBe` Just exampleClaimsSet+ decode claimsJSON `shouldBe` Just super++ it "JWT round-trip (sign, serialise, decode, verify)" $ do let- claimsJSON =- "{\"iss\":\"joe\",\r\n"- <> "\"exp\":1300819380,\r\n"- <> "\"http://example.com/is_root\":true}"- in- decode claimsJSON `shouldBe` Just exampleClaimsSet+ claims = emptyClaimsSet+ valConf = defaultJWTValidationSettings (const True)+ k <- genJWK $ RSAGenParam 256+ res <- runJOSE $ do+ token <- signClaims k (newJWSHeader ((), RS512)) claims+ token' <- decodeCompact . encodeCompact $ token+ liftIO $ token' `shouldBe` token+ claims' <- verifyClaims valConf k token'+ liftIO $ claims' `shouldBe` claims+ either (error . show) return (res :: Either JWTError ()) :: IO () - it "JWT compact round-trip" $ do+ it "JWT round-trip (sign, serialise, decode, verify) [extended payload type]" $ do+ let+ claims = emptyClaimsSet+ valConf = defaultJWTValidationSettings (const True)+ now = utcTime "2010-01-01 00:00:00" k <- genJWK $ RSAGenParam 256- res <- runExceptT $ do- token <- signClaims k (newJWSHeader ((), RS512)) emptyClaimsSet+ res <- runJOSE $ do+ token <- signJWT k (newJWSHeader ((), RS512)) super token' <- decodeCompact . encodeCompact $ token liftIO $ token' `shouldBe` token+ claims' <- runReaderT (verifyJWT valConf k token') now+ liftIO $ claims' `shouldBe` super either (error . show) return (res :: Either JWTError ()) :: IO () - it "formats to a parsable and equal value" $+ it "formats to a parsable and equal value" $ do decode (encode exampleClaimsSet) `shouldBe` Just exampleClaimsSet+ decode (encode super) `shouldBe` Just super describe "with an Expiration Time claim" $ do describe "when the current time is prior to the Expiration Time" $ do@@ -269,6 +319,28 @@ decode "[0]" `shouldBe` fmap (:[]) (intDate "1970-01-01 00:00:00") decode "[1382245921]" `shouldBe` fmap (:[]) (intDate "2013-10-20 05:12:01") decode "[\"notnum\"]" `shouldBe` (Nothing :: Maybe [NumericDate])++ describe "RFC 7519 §3.1. Example JWT" $+ it "verifies JWT" $ do+ let+ exampleJWT =+ "eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9"+ <> "."+ <> "eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt"+ <> "cGxlLmNvbS9pc19yb290Ijp0cnVlfQ"+ <> "."+ <> "dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"+ k = fromOctets+ [3,35,53,75,43,15,165,188,131,126,6,101,119,123,166,143,90,179,40,+ 230,240,84,201,40,169,15,132,178,210,80,46,191,211,251,90,146,+ 210,6,71,239,150,138,180,195,119,98,61,34,61,46,33,114,5,46,79,8,+ 192,205,154,245,103,208,128,163]+ now = utcTime "2010-01-01 00:00:00"+ settings = defaultJWTValidationSettings (const True)+ runReaderT (decodeCompact exampleJWT >>= verifyClaims settings k) now+ `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)+ runReaderT (decodeCompact exampleJWT >>= verifyJWT settings k) now+ `shouldBe` (Right super :: Either JWTError Super) describe "RFC 7519 §6.1. Example Unsecured JWT" $ do let
test/Properties.hs view
@@ -12,70 +12,188 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Properties where -import Control.Monad.Except (runExceptT)+import Control.Applicative (liftA2)+import Control.Monad.IO.Class -import Data.Aeson+import Control.Lens ((&), set, view)+import Crypto.Number.Basic (log2)+import Crypto.Random+import Data.Aeson (FromJSON, ToJSON, decode, encode) import qualified Data.ByteString as B +import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range import Test.Tasty-import Test.Tasty.QuickCheck-import Test.QuickCheck.Monadic-import Test.QuickCheck.Instances ()+import Test.Tasty.Hedgehog import Crypto.JOSE.Types import Crypto.JOSE.JWK import Crypto.JOSE.JWS ++instance (MonadIO m) => MonadRandom (PropertyT m) where+ getRandomBytes = liftIO . getRandomBytes+ properties :: TestTree properties = testGroup "Properties"- [ testProperty "SizedBase64Integer round-trip"- (prop_roundTrip :: SizedBase64Integer -> Property)- , testProperty "JWK round-trip" (prop_roundTrip :: JWK -> Property)- , testProperty "RSA gen, sign and verify" prop_rsaSignAndVerify- , testProperty "gen, sign with best alg, verify" prop_bestJWSAlg+ [ let n = "SizedBase64Integer round-trip" in testPropertyNamed n n (prop_roundTrip genSizedBase64Integer)+ , let n = "JWK round-trip" in testPropertyNamed n n (prop_roundTrip genJWK')+ , let n = "RSA gen, sign and verify" in testPropertyNamed n n prop_rsaSignAndVerify+ , let n = "gen, sign with best alg, verify" in testPropertyNamed n n prop_bestJWSAlg ] -prop_roundTrip :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Property-prop_roundTrip a = decode (encode [a]) === Just [a]+genBigInteger :: Gen Integer+genBigInteger = Gen.integral $ Range.exponential 0 (2 ^ (4096 :: Integer)) -debugRoundTrip- :: (Show a, Arbitrary a, ToJSON a, FromJSON a)- => (a -> Bool)- -> Property-debugRoundTrip f = monadicIO $ do- a :: a <- pick arbitrary- let encoded = encode [a]- monitor $ counterexample $- "JSON: \n" ++ show encoded ++ "\n\nDecoded: \n" ++ show (decode encoded :: Maybe [a])- assert $ f a+genBase64Integer :: Gen Base64Integer+genBase64Integer = Base64Integer <$> genBigInteger -prop_rsaSignAndVerify :: B.ByteString -> Property-prop_rsaSignAndVerify msg = monadicIO $ do- keylen <- pick $ elements ((`div` 8) <$> [2048, 3072, 4096])- k :: JWK <- run $ genJWK (RSAGenParam keylen)- alg_ <- pick $ elements [RS256, RS384, RS512, PS256, PS384, PS512]- monitor (collect alg_)- wp (runExceptT (signJWS msg [(newJWSHeader (Protected, alg_), k)]- >>= verifyJWS defaultValidationSettings k)) (checkSignVerifyResult msg)+genSizedBase64Integer :: Gen SizedBase64Integer+genSizedBase64Integer = do+ x <- genBigInteger+ l <- Gen.element [0, 1, 2] -- number of leading zero-bytes+ pure $ SizedBase64Integer ((log2 x `div` 8) + 1 + l) x -prop_bestJWSAlg :: B.ByteString -> Property-prop_bestJWSAlg msg = monadicIO $ do- genParam <- pick arbitrary- k <- run $ genJWK genParam++prop_roundTrip :: (Eq a, Show a, ToJSON a, FromJSON a) => Gen a -> Property+prop_roundTrip gen = property $+ forAll gen >>= \a -> decode (encode [a]) === Just [a]++prop_rsaSignAndVerify :: Property+prop_rsaSignAndVerify = property $ do+ msg <- forAll $ Gen.bytes (Range.linear 0 100)+ keylen <- forAll $ Gen.element ((`div` 8) <$> [2048, 3072, 4096])+ k <- evalIO $ genJWK (RSAGenParam keylen)+ alg_ <- forAll $ Gen.element [RS256, RS384, RS512, PS256, PS384, PS512]+ collect alg_+ msg' <- evalExceptT $ unwrapJOSE+ ( signJWS msg [(newJWSHeader (Protected, alg_), k)]+ >>= verifyJWS defaultValidationSettings k+ :: JOSE Error (PropertyT IO) B.ByteString+ )+ msg' === msg+++genCrv :: Gen Crv+genCrv = Gen.element [P_256, P_384, P_521, Secp256k1]++genOKPCrv :: Gen OKPCrv+genOKPCrv = Gen.element [Ed25519, Ed448, X25519, X448]++genKeyMaterialGenParam :: Gen KeyMaterialGenParam+genKeyMaterialGenParam = Gen.choice+ [ ECGenParam <$> genCrv+ , RSAGenParam <$> Gen.element ((`div` 8) <$> [2048, 3072, 4096])+ , OctGenParam <$> liftA2 (+) (Gen.integral (Range.exponential 0 64)) (Gen.element [32, 48, 64])+ , OKPGenParam <$> genOKPCrv+ ]++prop_bestJWSAlg :: Property+prop_bestJWSAlg = property $ do+ msg <- forAll $ Gen.bytes (Range.linear 0 100)++ genParam <- forAll $ genKeyMaterialGenParam+ k <- evalIO $ genJWK genParam+ case bestJWSAlg k of- Left (KeyMismatch _) -> pre False -- skip non-signing keys+ Left (KeyMismatch _) -> discard -- skip non-signing keys Left _ -> assert False Right alg_ -> do- monitor (collect alg_)- let- go = do- jws <- signJWS msg [(newJWSHeader (Protected, alg_), k)]- verifyJWS defaultValidationSettings k jws- wp (runExceptT go) (checkSignVerifyResult msg)+ collect alg_+ msg' <- evalExceptT $ unwrapJOSE+ ( signJWS msg [(newJWSHeader (Protected, alg_), k)]+ >>= verifyJWS defaultValidationSettings k+ :: JOSE Error (PropertyT IO) B.ByteString+ )+ msg' === msg -checkSignVerifyResult :: Monad m => B.ByteString -> Either Error B.ByteString -> PropertyM m ()-checkSignVerifyResult msg = assert . either (const False) (== msg)++++genRSAPrivateKeyOthElem :: Gen RSAPrivateKeyOthElem+genRSAPrivateKeyOthElem =+ RSAPrivateKeyOthElem <$> genBase64Integer <*> genBase64Integer <*> genBase64Integer++genRSAPrivateKeyOptionalParameters :: Gen RSAPrivateKeyOptionalParameters+genRSAPrivateKeyOptionalParameters =+ RSAPrivateKeyOptionalParameters+ <$> genBase64Integer+ <*> genBase64Integer+ <*> genBase64Integer+ <*> genBase64Integer+ <*> genBase64Integer+ <*> Gen.maybe (Gen.nonEmpty (Range.linear 1 3) genRSAPrivateKeyOthElem)++genRSAPrivateKeyParameters :: Gen RSAPrivateKeyParameters+genRSAPrivateKeyParameters =+ RSAPrivateKeyParameters+ <$> genBase64Integer+ <*> Gen.maybe (genRSAPrivateKeyOptionalParameters)++genRSAKeyParameters :: Gen RSAKeyParameters+genRSAKeyParameters =+ RSAKeyParameters+ <$> genBase64Integer+ <*> genBase64Integer+ <*> Gen.maybe (genRSAPrivateKeyParameters)++genDRG :: Gen ChaChaDRG+genDRG = do+ let word64 = Gen.word64 Range.constantBounded+ seed <- (,,,,) <$> word64 <*> word64 <*> word64 <*> word64 <*> word64+ pure $ drgNewTest seed++genECKeyParameters :: Gen ECKeyParameters+genECKeyParameters = do+ drg <- genDRG+ crv <- genCrv+ let (k, _) = withDRG drg (genEC crv)+ includePrivate <- Gen.bool+ pure $ if includePrivate+ then k+ else (let Just a = view asPublicKey k in a)++genOctKeyParameters :: Gen OctKeyParameters+genOctKeyParameters = OctKeyParameters . Base64Octets <$> Gen.bytes (Range.linear 16 128)++genOKPKeyParameters :: Gen OKPKeyParameters+genOKPKeyParameters = do+ drg <- genDRG+ crv <- genOKPCrv+ let (k, _) = withDRG drg (genOKP crv)+ includePrivate <- Gen.bool+ pure $ if includePrivate+ then k+ else (let Just a = view asPublicKey k in a)++genKeyMaterial' :: Gen KeyMaterial+genKeyMaterial' = Gen.choice+ [ ECKeyMaterial <$> genECKeyParameters+ , RSAKeyMaterial <$> genRSAKeyParameters+ , OctKeyMaterial <$> genOctKeyParameters+ , OKPKeyMaterial <$> genOKPKeyParameters+ ]++genBase64SHA1 :: Gen Base64SHA1+genBase64SHA1 = Base64SHA1 <$> Gen.bytes (Range.singleton 20)++genBase64SHA256 :: Gen Base64SHA256+genBase64SHA256 = Base64SHA256 <$> Gen.bytes (Range.singleton 32)++genJWK' :: Gen JWK+genJWK' = do+ key <- genKeyMaterial'+ kid_ <- Gen.text (Range.linear 8 16) Gen.hexit+ x5t_ <- genBase64SHA1+ x5tS256_ <- genBase64SHA256+ pure $ fromKeyMaterial key+ & set jwkKid (Just kid_)+ & set jwkX5t (Just x5t_)+ & set jwkX5tS256 (Just x5tS256_)
test/Types.hs view
@@ -19,7 +19,6 @@ import Data.Aeson import qualified Data.ByteString as BS import Data.List.NonEmpty-import Network.URI (parseURI) import Test.Hspec import Crypto.JOSE.Types@@ -27,7 +26,6 @@ spec :: Spec spec = do base64OctetsSpec- uriSpec base64IntegerSpec sizedBase64IntegerSpec base64X509Spec@@ -40,17 +38,6 @@ where iv = BS.pack [3, 22, 60, 12, 43, 67, 104, 105, 108, 108, 105, 99, 111, 116, 104, 101] tag = BS.pack [246, 17, 244, 190, 4, 95, 98, 3, 231, 0, 115, 157, 242, 203, 100, 191]--uriSpec :: Spec-uriSpec = describe "URI typeclasses" $ do- it "gets parsed from JSON correctly" $ do- decode "[\"http://example.com\"]" `shouldBe`- fmap (fmap (:[])) parseURI "http://example.com"- decode "[\"foo\"]" `shouldBe` (Nothing :: Maybe [URI])-- it "gets formatted to JSON correctly" $- fmap toJSON (Network.URI.parseURI "http://example.com")- `shouldBe` Just (String "http://example.com") base64IntegerSpec :: Spec base64IntegerSpec = describe "Base64Integer" $ do