jose 0.9 → 0.13
raw patch · 32 files changed
Files
- CHANGELOG.md +146/−0
- README.md +7/−6
- example/JWS.hs +26/−8
- example/KeyDB.hs +0/−5
- example/Main.hs +2/−5
- jose.cabal +50/−29
- src/Crypto/JOSE/AESKW.hs +2/−3
- src/Crypto/JOSE/Compact.hs +6/−1
- src/Crypto/JOSE/Error.hs +47/−14
- src/Crypto/JOSE/Header.hs +75/−28
- src/Crypto/JOSE/JWA/JWE.hs +7/−1
- src/Crypto/JOSE/JWA/JWE/Alg.hs +3/−1
- src/Crypto/JOSE/JWA/JWK.hs +90/−107
- src/Crypto/JOSE/JWA/JWS.hs +4/−1
- src/Crypto/JOSE/JWE.hs +17/−18
- src/Crypto/JOSE/JWK.hs +147/−58
- src/Crypto/JOSE/JWK/Store.hs +0/−3
- src/Crypto/JOSE/JWS.hs +78/−42
- src/Crypto/JOSE/TH.hs +3/−8
- src/Crypto/JOSE/Types.hs +0/−47
- src/Crypto/JOSE/Types/Internal.hs +0/−2
- src/Crypto/JOSE/Types/Orphans.hs +0/−29
- src/Crypto/JOSE/Types/URI.hs +29/−0
- src/Crypto/JWT.hs +356/−149
- test/AESKW.hs +27/−19
- test/Examples.hs +6/−4
- test/JWK.hs +4/−3
- test/JWS.hs +33/−31
- test/JWT.hs +114/−41
- test/Perf.hs +3/−5
- test/Properties.hs +165/−45
- test/Types.hs +3/−14
+ CHANGELOG.md view
@@ -0,0 +1,146 @@+## Version 0.13 (2026-06-06)++- Update to *crypton >= 1.1.0* and *ram*. There are no+ functional changes in this release. Until the release+ of 0.14, any behavioural changes (bug fixes, etc) will+ be released to both the 0.13 and 0.12 series.++## Version 0.12 (2025-08-18)++- GHC 9.6 is now the earliest supported version.++- Changed the header protection data types for better ergonomics+ ([#125](https://github.com/frasertweedale/hs-jose/issues/125)).+ Previously, `()` was used for serialisations that only support+ protected headers (thus, a single constructor). This release+ introduces the new singleton data type `RequiredProtected` to+ replace the use of `()` for this purpose. This is a breaking+ change and some library users will need to update their code.++ The `Protection` type has been renamed to `OptionalProtection`,+ with the old name retained as a (deprecated) type synonym.++ The `ProtectionIndicator` class has been renamed to+ `ProtectionSupport`, with the old name retained as a (deprecated)+ type synonym.++ Added some convenience header and header parameter constructors:+ `newJWSHeaderProtected`, `newHeaderParamProtected` and+ `newHeaderParamUnprotected`.++- Generalised the types of `signJWT`, `verifyJWT` and related+ functions to accept custom JWS header types. Added new type+ synonym `SignedJWTWithHeader h`. This change could break some+ applications by introducing ambiguity. The solution is to use+ a type annotation, type application, or explicit coercion+ function, as in the below examples:++ ```haskell+ -- type application+ {-# LANGUAGE TypeApplications #-}+ decodeCompact @SignedJWT s >>= verifyClaims settings k++ -- type annotation+ do+ jwt <- decodeCompact s+ verifyClaims settings k (jwt :: SignedJWT)++ -- coercion function+ let+ fixType = id :: SignedJWT -> SignedJWT+ in+ verifyClaims settings k . fixType =<< decodeCompact s+ ```++- Added `unsafeGetPayload`, `unsafeGetJWTPayload` and+ `unsafeGetJWTClaimsSet` functions. These enable access to+ the JWS/JWT payload without cryptographic verification. As+ the name implies, these should be used with the utmost caution!+ ([#126](https://github.com/frasertweedale/hs-jose/issues/126))++- Add `Crypto.JOSE.JWK.negotiateJWSAlg` which chooses the+ cryptographically strongest JWS algorithm for a given key,+ restricted to a given set of algorithms. ([#118][])++- Added new conversion functions `Crypto.JOSE.JWK.fromX509PubKey`+ and `Crypto.JOSE.JWK.fromX509PrivKey`. These convert from the+ `Data.X509.PubKey` and `Data.X509.PrivKey` types, which can be+ read via the *crypton-x509-store* package. They supports RSA,+ NIST ECC, and Edwards curve key types (Ed25519, Ed448, X25519,+ X448).++- Updated `Crypto.JOSE.JWK.fromX509Certificate` to support Edwards+ curve key types (Ed25519, Ed448, X25519, X448).++- Added `Crypto.JOSE.JWK.fromRSAPublic :: RSA.PublicKey -> JWK`.++- Added `Ord` instance for `StringOrURI` ([#134]; contributed by+ Chris Penner).++- Added `Semigroup` and `Monoid` instances for `JWKSet`+ ([#135]; contributed by Torgeir Strand Henriksen).++[#134]: https://github.com/frasertweedale/hs-jose/pull/134+[#135]: https://github.com/frasertweedale/hs-jose/pull/135+++## Version 0.11 (2023-10-31)++- Migrate to the *crypton* library ecosystem. *crypton* was a hard+ fork of *cryptonite*, which was no longer maintained. With this+ change, the minimum supported version of GHC increased to 8.8.+ There are no other notable changes in this release.++- The `v0.10` series is the last release series to support+ *cryptonite*. It will continue to receive important bug fixes+ until the end of 2024.+++## 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+[#118]: https://github.com/frasertweedale/hs-jose/issues/118+[#122]: https://github.com/frasertweedale/hs-jose/issues/122+++## 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
@@ -1,8 +1,26 @@-module JWS where+-- Copyright (C) 2017-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. +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++module JWS+ ( doJwsSign+ , doJwsVerify+ ) where+ import System.Exit (exitFailure) -import Control.Monad.Except (runExceptT) import Data.Aeson (decode, encode) import qualified Data.ByteString.Lazy as L @@ -17,11 +35,11 @@ -- doJwsSign :: [String] -> IO () doJwsSign [jwkFilename, payloadFilename] = do- Just jwk <- decode <$> L.readFile jwkFilename+ Just k <- decode <$> L.readFile jwkFilename payload <- L.readFile payloadFilename- result <- runExceptT $ do- h <- makeJWSHeader jwk- signJWS payload [(h :: JWSHeader Protection, jwk)]+ result <- runJOSE $ do+ h <- makeJWSHeader k+ signJWS payload [(h :: JWSHeader OptionalProtection, k)] case result of Left e -> print (e :: Error) >> exitFailure Right jws -> L.putStr (encode jws)@@ -36,9 +54,9 @@ -- doJwsVerify :: [String] -> IO () doJwsVerify [jwkFilename, jwsFilename] = do- Just jwk <- decode <$> L.readFile jwkFilename+ Just k <- decode <$> L.readFile jwkFilename Just jws <- decode <$> L.readFile jwsFilename- result <- runExceptT $ verifyJWS' (jwk :: JWK) (jws :: GeneralJWS JWSHeader)+ result <- runJOSE $ verifyJWS' (k :: JWK) (jws :: GeneralJWS JWSHeader) case result of Left e -> print (e :: Error) >> exitFailure Right s -> L.putStr s
example/KeyDB.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}- module KeyDB ( KeyDB(..)@@ -9,7 +5,6 @@ import Control.Exception (IOException, handle) import Data.Maybe (catMaybes)-import Data.Semigroup ((<>)) import Control.Monad.Trans (MonadIO(..)) import Control.Lens (_Just, preview)
example/Main.hs view
@@ -1,8 +1,6 @@ {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-{-# LANGUAGE FlexibleContexts #-} import Data.Maybe (fromJust)-import Data.Semigroup ((<>)) import System.Environment (getArgs) import System.Exit (die, exitFailure) @@ -11,7 +9,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 +51,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 +74,7 @@ let aud' = fromJust $ preview stringOrUri aud conf = defaultJWTValidationSettings (== aud')- go k = runExceptT (decodeCompact jwtData >>= verifyClaims conf k)+ go k = runJOSE $ decodeCompact @SignedJWT 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.13 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,31 +24,50 @@ license: Apache-2.0 license-file: LICENSE extra-source-files:- README.md test/data/fido.jwt+extra-doc-files:+ CHANGELOG.md+ README.md author: Fraser Tweedale maintainer: frase@frase.id.au-copyright: Copyright (C) 2013-2021 Fraser Tweedale+copyright: Copyright (C) 2013-2025 Fraser Tweedale 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 ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.4 || ==9.14.1 flag demos description: Build demonstration programs default: False common common- default-language: Haskell2010- ghc-options: -Wall+ default-language: GHC2021+ default-extensions: LambdaCase+ ghc-options:+ -Wall+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Werror=missing-methods+ -Wcompat+ -Wnoncanonical-monad-instances+ -Wredundant-constraints+ -fhide-source-paths+ -Wmissing-export-lists+ -Wpartial-fields+ -Wunused-packages+ -Winvalid-haddock+ -Werror=unicode-bidirectional-format-characters+ -Wimplicit-lift+ -Woperator-whitespace+ -Wredundant-bang-patterns+ -Wredundant-strictness-flags build-depends:- base >= 4.9 && < 5- , aeson >= 2.0.1.0 && < 3- , bytestring >= 0.10 && < 0.12+ base >= 4.18 && < 5+ , bytestring >= 0.10 && < 0.13 , lens >= 4.16- , mtl >= 2- , text >= 1.1+ , mtl >= 2.2.1 library import: common@@ -73,21 +92,21 @@ other-modules: Crypto.JOSE.TH Crypto.JOSE.Types.Internal- Crypto.JOSE.Types.Orphans+ Crypto.JOSE.Types.URI build-depends:+ , aeson >= 2.0.1.0 && < 3 , base64-bytestring >= 1.2.1.0 && < 1.3 , concise >= 0.1- , containers >= 0.5- , cryptonite >= 0.7- , memory >= 0.7- , monad-time >= 0.3- , template-haskell >= 2.11+ , containers >= 0.5.8+ , crypton >= 1.1.0+ , ram >= 0.19+ , monad-time >= 0.4+ , template-haskell >= 2.12+ , text >= 1.1 , time >= 1.5 , network-uri >= 2.6- , QuickCheck >= 2.9- , quickcheck-instances- , x509 >= 1.4+ , crypton-x509 >= 1.7.6 hs-source-dirs: src @@ -110,23 +129,23 @@ Types build-depends:+ , aeson , base64-bytestring , containers- , cryptonite+ , crypton , time , network-uri- , x509+ , crypton-x509 , pem , concise , jose , tasty+ , tasty-hedgehog >= 1.2 , tasty-hspec >= 1.0- , tasty-quickcheck+ , hedgehog , hspec- , QuickCheck >= 2.9- , quickcheck-instances test-suite perf import: common@@ -147,5 +166,7 @@ JWS build-depends:- unix+ aeson+ , text+ , unix , jose
src/Crypto/JOSE/AESKW.hs view
@@ -12,8 +12,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE ScopedTypeVariables #-}- {- | Advanced Encryption Standard (AES) Key Wrap Algorithm;@@ -26,7 +24,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/Compact.hs view
@@ -21,7 +21,12 @@ functions for working with such data. -}-module Crypto.JOSE.Compact where+module Crypto.JOSE.Compact+ ( FromCompact(..)+ , decodeCompact+ , ToCompact(..)+ , encodeCompact+ ) where import Control.Monad.Except (MonadError) import qualified Data.ByteString.Lazy as L
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.@@ -12,19 +12,22 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE FlexibleInstances #-} {-# 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 +36,13 @@ , CompactDecodeError(..) , _CompactInvalidNumberOfParts , _CompactInvalidText+ ) where -import Data.Semigroup ((<>)) import Numeric.Natural -import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)+import Control.Monad.Trans (MonadIO(liftIO), MonadTrans(lift)) import qualified Crypto.PubKey.RSA as RSA import Crypto.Error (CryptoError) import Crypto.Random (MonadRandom(..))@@ -118,10 +122,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
@@ -12,9 +12,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}- {-| Types and functions for working with JOSE header parameters.@@ -22,10 +19,19 @@ -} module Crypto.JOSE.Header (- -- * Defining header data types+ -- * Constructing header parameters HeaderParam(..)- , ProtectionIndicator(..)- , Protection(..)+ , newHeaderParamProtected+ , newHeaderParamUnprotected++ -- ** Header protection support+ , ProtectionSupport(..)+ , ProtectionIndicator++ , OptionalProtection(..)+ , RequiredProtection(..)+ , Protection+ , protection , isProtected , param@@ -36,6 +42,7 @@ , headerRequired , headerRequiredProtected , headerOptional+ , headerOptional' , headerOptionalProtected -- * Parsing headers@@ -65,7 +72,6 @@ import qualified Control.Monad.Fail as Fail import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty)-import Data.Monoid ((<>)) import Data.Proxy (Proxy(..)) import Control.Lens (Lens', Getter, review, to)@@ -78,7 +84,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 @@ -88,7 +93,7 @@ class HasParams (a :: Type -> Type) where -- | Return a list of parameters, -- each paired with whether it is protected or not.- params :: ProtectionIndicator p => a p -> [(Bool, Pair)]+ params :: ProtectionSupport p => a p -> [(Bool, Pair)] -- | List of "known extensions", i.e. keys that may appear in the -- "crit" header parameter.@@ -96,7 +101,7 @@ extensions = const [] parseParamsFor- :: (HasParams b, ProtectionIndicator p)+ :: (HasParams b, ProtectionSupport p) => Proxy b -> Maybe Object -> Maybe Object -> Parser (a p) -- | Parse a pair of objects (protected and unprotected header)@@ -106,14 +111,14 @@ -- to access "known extensions" understood by the target type.) -- parseParams- :: forall a p. (HasParams a, ProtectionIndicator p)+ :: forall a p. (HasParams a, ProtectionSupport p) => Maybe Object -- ^ protected header -> Maybe Object -- ^ unprotected header -> Parser (a p) parseParams = parseParamsFor (Proxy :: Proxy a) protectedParams- :: (HasParams a, ProtectionIndicator p)+ :: (HasParams a, ProtectionSupport p) => a p -> Maybe Value {- ^ Object -} protectedParams h = case (map snd . filter fst . params) h of@@ -123,7 +128,7 @@ -- | Return the base64url-encoded protected parameters -- protectedParamsEncoded- :: (HasParams a, ProtectionIndicator p)+ :: (HasParams a, ProtectionSupport p) => a p -> L.ByteString protectedParamsEncoded = maybe mempty (review base64url . encode) . protectedParams@@ -131,19 +136,18 @@ -- | Return unprotected params as a JSON 'Value' (always an object) -- unprotectedParams- :: (HasParams a, ProtectionIndicator p)+ :: (HasParams a, ProtectionSupport p) => a p -> Maybe Value {- ^ Object -} unprotectedParams h = case (map snd . filter (not . fst) . params) h of [] -> Nothing xs -> Just (object xs) --- | Whether a header is protected or unprotected----data Protection = Protected | Unprotected- deriving (Eq, Show) -class Eq a => ProtectionIndicator a where+-- | Class that defines the protected and (if supported) unprotected values+-- for a protection indicator data type.+--+class Eq a => ProtectionSupport a where -- | Get a value for indicating protection. getProtected :: a @@ -151,12 +155,33 @@ -- if the type does not support unprotected headers. getUnprotected :: Maybe a -instance ProtectionIndicator Protection where+type ProtectionIndicator = ProtectionSupport+{-# DEPRECATED ProtectionIndicator "renamed to 'ProtectionSupport." #-}++++-- | Use this protection type when the serialisation supports both+-- protected and unprotected headers.+--+data OptionalProtection = Protected | Unprotected+ deriving (Eq, Show)++instance ProtectionSupport OptionalProtection where getProtected = Protected getUnprotected = Just Unprotected -instance ProtectionIndicator () where- getProtected = ()+type Protection = OptionalProtection+{-# DEPRECATED Protection "renamed to 'OptionalProtection'." #-}+++-- | Use this protection type when the serialisation only supports+-- protected headers.+--+data RequiredProtection = RequiredProtection+ deriving (Eq, Show)++instance ProtectionSupport RequiredProtection where+ getProtected = RequiredProtection getUnprotected = Nothing @@ -179,10 +204,19 @@ {-# ANN param "HLint: ignore Avoid lambda" #-} -- | Getter for whether a parameter is protected-isProtected :: (ProtectionIndicator p) => Getter (HeaderParam p a) Bool+isProtected :: (ProtectionSupport p) => Getter (HeaderParam p a) Bool isProtected = protection . to (== getProtected) +-- | Convenience constructor for a protected 'HeaderParam'.+newHeaderParamProtected :: (ProtectionIndicator p) => a -> HeaderParam p a+newHeaderParamProtected = HeaderParam getProtected++-- | Convenience constructor for a protected 'HeaderParam'.+newHeaderParamUnprotected :: a -> HeaderParam OptionalProtection a+newHeaderParamUnprotected = HeaderParam Unprotected++ {- $parsing The 'parseParamsFor' function defines the parser for a header type.@@ -225,17 +259,30 @@ -- the protected or the unprotected header. -- headerOptional- :: (FromJSON a, ProtectionIndicator p)+ :: (FromJSON a, ProtectionSupport p) => T.Text -> 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'+ :: (ProtectionSupport 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@@ -262,7 +309,7 @@ -- the protected or the unprotected header. -- headerRequired- :: (FromJSON a, ProtectionIndicator p)+ :: (FromJSON a, ProtectionSupport p) => T.Text -> Maybe Object -> Maybe Object
src/Crypto/JOSE/JWA/JWE.hs view
@@ -20,7 +20,13 @@ JSON Web Encryption data types specified under JSON Web Algorithms. -}-module Crypto.JOSE.JWA.JWE where+module Crypto.JOSE.JWA.JWE+ ( Enc(..)+ , AlgWithParams(..)+ , AESGCMParameters(AESGCMParameters)+ , ECDHParameters(ECDHParameters)+ , PBES2Parameters(PBES2Parameters)+ ) where import Data.Maybe (catMaybes)
src/Crypto/JOSE/JWA/JWE/Alg.hs view
@@ -20,7 +20,9 @@ JSON Web Encryption algorithms. -}-module Crypto.JOSE.JWA.JWE.Alg where+module Crypto.JOSE.JWA.JWE.Alg+ ( Alg(..)+ ) where import qualified Crypto.JOSE.TH
src/Crypto/JOSE/JWA/JWK.hs view
@@ -12,14 +12,10 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-} {-| @@ -32,12 +28,14 @@ -- * Parameters for Elliptic Curve Keys , Crv(..)- , ECKeyParameters+ , ECKeyParameters(ECKeyParameters) , ecCrv, ecX, ecY, ecD , curve , point , ecPrivateKey , ecParametersFromX509+ , ecParametersFromX509Priv+ , genEC -- * Parameters for RSA Keys , RSAPrivateKeyOthElem(..)@@ -59,6 +57,7 @@ -- * Parameters for CFRG EC keys (RFC 8037) , OKPKeyParameters(..) , OKPCrv(..)+ , genOKP -- * Key generation , KeyMaterialGenParam(..)@@ -72,13 +71,11 @@ , module Crypto.Random ) where -import Control.Applicative import Control.Monad (guard) import Control.Monad.Except (MonadError) import Data.Bifunctor import Data.Foldable (toList) import Data.Maybe (isJust)-import Data.Monoid ((<>)) import Control.Lens hiding ((.=), elements) import Control.Monad.Error.Lens (throwing, throwing_)@@ -93,7 +90,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 +102,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 +133,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 +164,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,12 +186,13 @@ Types.insertToObject "d" rsaD $ maybe (Object mempty) toJSON rsaOptionalParameters -instance Arbitrary RSAPrivateKeyParameters where- arbitrary = RSAPrivateKeyParameters <$> arbitrary <*> arbitrary ---- | Parameters for Elliptic Curve Keys+-- | Parameters for Elliptic Curve Keys. --+-- @+-- ECKeyParameters crv x y (Just d)+-- @+-- data ECKeyParameters = ECKeyParameters { _ecCrv :: Crv , _ecX :: Types.SizedBase64Integer@@ -249,16 +232,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 +281,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,25 +299,58 @@ 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 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)+-- | See also 'Crypto.JOSE.JWK.fromX509PubKey' and+-- 'Crypto.JOSE.JWK.fromX509Certificate'.+--+ecParametersFromX509 :: (MonadError e m, AsError e) => X509.PubKeyEC -> m ECKeyParameters+ecParametersFromX509 k = do+ curveName <-+ maybe (throwing _KeyMismatch "Unknown curve") pure+ $ X509.EC.ecPubKeyCurveName k+ crv <-+ maybe (throwing _KeyMismatch "Unsupported curve") pure+ $ preview fromCurveName curveName+ pt <-+ maybe (throwing _KeyMismatch "Invalid EC point") pure+ $ X509.EC.unserializePoint (ECC.getCurveByName curveName) (X509.pubkeyEC_pub k) (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 --- | Parameters for RSA Keys+-- | See also 'Crypto.JOSE.JWK.fromX509PrivKey'. --+ecParametersFromX509Priv :: (MonadError e m, AsError e) => X509.PrivKeyEC -> m ECKeyParameters+ecParametersFromX509Priv k = do+ curveName <-+ maybe (throwing _KeyMismatch "Unknown curve") pure+ $ X509.EC.ecPrivKeyCurveName k+ crv <-+ maybe (throwing _KeyMismatch "Unsupported curve") pure+ $ preview fromCurveName curveName+ let d = privkeyEC_priv k+ (x, y) <- case ECC.generateQ (ECC.getCurveByName curveName) d of+ 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 (Just $ Types.makeSizedBase64Integer d)+++-- | Parameters for RSA Keys.+--+-- @+-- RSAKeyParameters modulus exponent (Just privateParams)+-- @+-- data RSAKeyParameters = RSAKeyParameters { _rsaN :: Types.Base64Integer , _rsaE :: Types.Base64Integer@@ -370,12 +378,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 +477,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 +493,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 +514,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 +528,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 +551,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 +565,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 +618,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 +635,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 +657,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 +674,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 +690,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
@@ -20,7 +20,9 @@ JSON Web Signature algorithms. -}-module Crypto.JOSE.JWA.JWS where+module Crypto.JOSE.JWA.JWS+ ( Alg(..)+ ) where import qualified Crypto.JOSE.TH @@ -37,6 +39,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
@@ -12,10 +12,7 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} module Crypto.JOSE.JWE (@@ -27,9 +24,8 @@ import Control.Applicative ((<|>)) import Data.Bifunctor (bimap) 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 +49,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 @@ -82,7 +79,7 @@ } deriving (Eq, Show) -newJWEHeader :: ProtectionIndicator p => AlgWithParams -> Enc -> JWEHeader p+newJWEHeader :: (ProtectionSupport p) => AlgWithParams -> Enc -> JWEHeader p newJWEHeader alg enc = JWEHeader (Just alg) (HeaderParam getProtected enc) z z z z z z z z z z z where z = Nothing@@ -92,10 +89,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 +107,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@@ -134,7 +131,7 @@ <*> o .:? "encrypted_key" parseRecipient- :: (HasParams a, ProtectionIndicator p)+ :: (HasParams a, ProtectionSupport p) => Maybe Object -> Maybe Object -> Value -> Parser (JWERecipient a p) parseRecipient hp hu = withObject "JWE Recipient" $ \o -> do hr <- o .:? "header"@@ -153,7 +150,7 @@ , _jweRecipients :: [JWERecipient a p] } -instance (HasParams a, ProtectionIndicator p) => FromJSON (JWE a p) where+instance (HasParams a, ProtectionSupport p) => FromJSON (JWE a p) where parseJSON = withObject "JWE JSON Serialization" $ \o -> do hpB64 <- o .:? "protected" hp <- maybe@@ -261,12 +258,14 @@ CryptoFailed _ -> return $ Left AlgorithmNotImplemented -- FIXME CryptoPassed (e :: e) -> do iv <- getRandomBytes 16- let Just iv' = makeIV iv- let m' = pad (PKCS7 $ blockSize e) m- let c = cbcEncrypt e iv' m'- let hmacInput = B.concat [aad, iv, c, aadLen]- let tag = B.take kLen $ BA.pack $ BA.unpack (hmac mKey hmacInput :: HMAC h)- return $ Right (iv, c, tag)+ case makeIV iv of+ Nothing -> pure $ Left (CryptoError CryptoError_IvSizeInvalid)+ Just iv' -> do+ let m' = pad (PKCS7 $ blockSize e) m+ let c = cbcEncrypt e iv' m'+ let hmacInput = B.concat [aad, iv, c, aadLen]+ let tag = BA.convert $ BA.takeView (hmac mKey hmacInput :: HMAC h) kLen+ pure $ Right (iv, c, tag) _gcmEnc :: forall e m. (BlockCipher e, MonadRandom m)
src/Crypto/JOSE/JWK.hs view
@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014, 2015, 2016, 2017 Fraser Tweedale+-- Copyright (C) 2013-2023 Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -12,12 +12,11 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} {-| @@ -32,10 +31,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 @ @@ -68,8 +67,11 @@ -- * Converting from other key formats , fromKeyMaterial , fromRSA+ , fromRSAPublic , fromOctets , fromX509Certificate+ , fromX509PubKey+ , fromX509PrivKey -- * JWK Thumbprint , thumbprint@@ -81,6 +83,8 @@ , JWKSet(..) -- Miscellaneous+ , checkJWK+ , negotiateJWSAlg , bestJWSAlg , module Crypto.JOSE.JWA.JWK@@ -89,17 +93,22 @@ import Control.Applicative import Control.Monad ((>=>)) import Data.Function (on)+import Data.List (find) import Data.Maybe (catMaybes)-import Data.Monoid ((<>)) import Data.Word (Word8) 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.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 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 +117,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 +205,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 +224,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 +235,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 @@ -253,12 +249,7 @@ fromRSAPublic :: RSA.PublicKey -> JWK fromRSAPublic = fromKeyMaterial . RSAKeyMaterial . toRSAPublicKeyParameters --- | Convert an EC public key into a JWK----fromECPublic :: X509.PubKeyEC -> Maybe JWK-fromECPublic = fmap (fromKeyMaterial . ECKeyMaterial) . ecParametersFromX509 - -- | Convert octet string into a JWK -- fromOctets :: Cons s s Word8 Word8 => s -> JWK@@ -268,28 +259,61 @@ {-# INLINE fromOctets #-} +-- | Convert from a 'X509.PubKey' (such as can be read via the+-- /crypton-x509-store/ package). Supports RSA, ECDSA, Ed25519,+-- Ed448, X25519 and X448 keys.+--+fromX509PubKey :: (AsError e, MonadError e m) => X509.PubKey -> m JWK+fromX509PubKey = \case+ X509.PubKeyRSA k -> pure (fromRSAPublic k)+ X509.PubKeyEC k -> fromECPublic k+ X509.PubKeyX25519 k -> fromOKP $ X25519Key k Nothing+ X509.PubKeyX448 k -> fromOKP $ X448Key k Nothing+ X509.PubKeyEd25519 k -> fromOKP $ Ed25519Key k Nothing+ X509.PubKeyEd448 k -> fromOKP $ Ed448Key k Nothing+ _ -> throwing _KeyMismatch "X.509 key type not supported"+ where+ fromECPublic = fmap (fromKeyMaterial . ECKeyMaterial) . ecParametersFromX509+ fromOKP = pure . fromKeyMaterial . OKPKeyMaterial++-- | Convert from a 'X509.PrivKey' (such as can be read via the+-- /crypton-x509-store/ package). Supports RSA, ECDSA, Ed25519,+-- Ed448, X25519 and X448 keys.+--+fromX509PrivKey :: (AsError e, MonadError e m) => X509.PrivKey -> m JWK+fromX509PrivKey = \case+ X509.PrivKeyRSA k -> pure (fromRSA k)+ X509.PrivKeyEC k -> fromEC k+ X509.PrivKeyX25519 k -> fromOKP $ X25519Key (Curve25519.toPublic k) (Just k)+ X509.PrivKeyX448 k -> fromOKP $ X448Key (Curve448.toPublic k) (Just k)+ X509.PrivKeyEd25519 k -> fromOKP $ Ed25519Key (Ed25519.toPublic k) (Just k)+ X509.PrivKeyEd448 k -> fromOKP $ Ed448Key (Ed448.toPublic k) (Just k)+ _ -> throwing _KeyMismatch "X.509 key type not supported"+ where+ fromEC = fmap (fromKeyMaterial . ECKeyMaterial) . ecParametersFromX509Priv+ fromOKP = pure . fromKeyMaterial . OKPKeyMaterial++ -- | Convert an X.509 certificate into a JWK. ----- Only RSA keys are supported. Other key types will throw--- 'KeyMismatch'.+-- Supports RSA, ECDSA (curves defined for use in JOSE), and Edwards+-- curves (Ed25519, Ed448, X25519, X448). -- -- 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- k <- case (X509.certPubKey . X509.signedObject . X509.getSigned) cert of- X509.PubKeyRSA k -> pure (fromRSAPublic k)- X509.PubKeyEC k -> fromECPublic k- _ -> Nothing+fromX509Certificate cert = do+ k <- fromX509PubKey . X509.certPubKey . X509.signedObject $ X509.getSigned cert 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@@ -298,7 +322,7 @@ -- | RFC 7517 §5. JWK Set Format ---newtype JWKSet = JWKSet [JWK] deriving (Eq, Show)+newtype JWKSet = JWKSet [JWK] deriving (Eq, Show, Semigroup, Monoid) instance FromJSON JWKSet where parseJSON = withObject "JWKSet" (\o -> JWKSet <$> o .: "keys")@@ -307,32 +331,95 @@ 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. --+-- See also 'negotiateJWSAlg'.+--+-- @+-- bestJWSAlg k = negotiateJWSAlg k Nothing+-- @+-- bestJWSAlg :: (MonadError e m, AsError e) => JWK -> m JWA.JWS.Alg-bestJWSAlg jwk = case view jwkMaterial jwk 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+bestJWSAlg jwk = chooseJWSAlg jwk Nothing++-- | Choose the cryptographically strongest JWS algorithm for a+-- given key, restricted to a given set of algorithms. This+-- function supports negotiation use cases where verifier's+-- supported algorithms are advertised or known.+--+-- Throws an error if the key is too small or cannot be used for+-- signing, or if there is no overlap between the allowed algorithms+-- and the algorithms supported by the key type.+--+-- RSASSA-PSS algorithms are preferred over RSASSA-PKCS1-v1_5.+--+-- The JWK "alg" parameter is ignored.+--+negotiateJWSAlg+ :: (MonadError e m, AsError e)+ => JWK+ -> NonEmpty JWA.JWS.Alg+ -> m JWA.JWS.Alg+negotiateJWSAlg jwk = chooseJWSAlg jwk . Just++-- | General implementation used by 'bestJWSAlg' and 'negotiateJWSAlg'.+--+chooseJWSAlg+ :: (MonadError e m, AsError e)+ => JWK+ -> Maybe (NonEmpty JWA.JWS.Alg)+ -> m JWA.JWS.Alg+chooseJWSAlg jwk allowed = case view jwkMaterial jwk of+ ECKeyMaterial k -> case view ecCrv k of+ P_256 | ok JWA.JWS.ES256 -> pure JWA.JWS.ES256+ P_384 | ok JWA.JWS.ES384 -> pure JWA.JWS.ES384+ P_521 | ok JWA.JWS.ES512 -> pure JWA.JWS.ES512+ Secp256k1 | ok JWA.JWS.ES256K -> pure JWA.JWS.ES256K+ _ -> negoFail+ RSAKeyMaterial k+ | n < 2 ^ (2040 :: Integer) -> throwing_ _KeySizeTooSmall+ | otherwise -> maybe negoFail pure (find ok rsaAlgs)+ where Types.Base64Integer n = view rsaN k- in- if n >= 2 ^ (2040 :: Integer)- then pure JWA.JWS.PS512- else throwing_ _KeySizeTooSmall+ rsaAlgs =+ [ JWA.JWS.PS512 , JWA.JWS.PS384 , JWA.JWS.PS256+ , JWA.JWS.RS512 , JWA.JWS.RS384 , JWA.JWS.RS256 ] 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- | otherwise -> throwing_ _KeySizeTooSmall- OKPKeyMaterial (Ed25519Key _ _) -> pure JWA.JWS.EdDSA- OKPKeyMaterial _ -> throwing _KeyMismatch "Cannot sign with OKP ECDH key"+ | B.length k >= 512 `div` 8, ok JWA.JWS.HS512 -> pure JWA.JWS.HS512+ | B.length k >= 384 `div` 8, ok JWA.JWS.HS384 -> pure JWA.JWS.HS384+ | B.length k >= 256 `div` 8, ok JWA.JWS.HS256 -> pure JWA.JWS.HS256+ | B.length k >= 256 `div` 8 -> negoFail+ | otherwise -> throwing_ _KeySizeTooSmall+ OKPKeyMaterial k -> case k of+ (X25519Key _ _) -> throwing _KeyMismatch "Cannot sign with X25519 key"+ (X448Key _ _) -> throwing _KeyMismatch "Cannot sign with X448 key"+ (Ed25519Key _ _) | ok JWA.JWS.EdDSA -> pure JWA.JWS.EdDSA+ (Ed448Key _ _) | ok JWA.JWS.EdDSA -> pure JWA.JWS.EdDSA+ _ -> negoFail+ where+ ok alg = maybe True (alg `elem`) allowed+ negoFail = throwing _AlgorithmMismatch "Algorithm negotation failed" -- | Compute the JWK Thumbprint of a JWK@@ -362,7 +449,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/JWK/Store.hs view
@@ -12,9 +12,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}- {-| Key stores. Instances are provided for 'JWK' and 'JWKSet'. These
src/Crypto/JOSE/JWS.hs view
@@ -20,23 +20,23 @@ <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 @ -} -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Crypto.JOSE.JWS@@ -52,6 +52,7 @@ -- * JWS creation , newJWSHeader+ , newJWSHeaderProtected , makeJWSHeader , signJWS @@ -68,6 +69,9 @@ , HasAlgorithms(..) , HasValidationPolicy(..) + -- * Access payload without verification+ , unsafeGetPayload+ -- * Signature data , signatures , Signature@@ -86,16 +90,16 @@ ) where import Control.Applicative ((<|>))+import Control.Monad (unless) import Data.Foldable (toList) import Data.Maybe (catMaybes, fromMaybe)-import Data.Monoid ((<>)) import Data.List.NonEmpty (NonEmpty) import Data.Word (Word8) 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' -}@@ -233,12 +239,17 @@ -- | Construct a minimal header with the given algorithm and--- protection indicator for the /alg/ header.+-- protection value for the @"alg"@ header. -- newJWSHeader :: (p, Alg) -> JWSHeader p newJWSHeader a = JWSHeader (uncurry HeaderParam a) z z z z z z z z z z where z = Nothing +-- | Construct a minimal JWS header with the given @"alg"@ header+-- value, to be carried as a protected header.+newJWSHeaderProtected :: (ProtectionSupport p) => Alg -> JWSHeader p+newJWSHeaderProtected a = newJWSHeader (getProtected, a)+ -- | Make a JWS header for the given signing key. -- -- Uses 'bestJWSAlg' to choose the algorithm.@@ -249,7 +260,7 @@ -- May return 'KeySizeTooSmall' or 'KeyMismatch'. -- makeJWSHeader- :: forall e m p. (MonadError e m, AsError e, ProtectionIndicator p)+ :: forall e m p. (MonadError e m, AsError e, ProtectionSupport p) => JWK -> m (JWSHeader p) makeJWSHeader k = do@@ -296,7 +307,7 @@ instance (Eq (a p)) => Eq (Signature p a) where Signature _ h s == Signature _ h' s' = h == h' && s == s' -instance (HasParams a, ProtectionIndicator p) => FromJSON (Signature p a) where+instance (HasParams a, ProtectionSupport p) => FromJSON (Signature p a) where parseJSON = withObject "signature" (\o -> Signature <$> (Just <$> (o .: "protected" <|> pure "")) -- raw protected header <*> do@@ -313,7 +324,7 @@ <*> o .: "signature" ) -instance (HasParams a, ProtectionIndicator p) => ToJSON (Signature p a) where+instance (HasParams a, ProtectionSupport p) => ToJSON (Signature p a) where toJSON s@(Signature _ h sig) = let pro = case rawProtectedHeader s of@@ -329,10 +340,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 +356,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)@@ -358,11 +369,10 @@ ] --- | JSON Web Signature data type. The payload can only be--- accessed by verifying the JWS.+-- | JSON Web Signature data type. -- -- Parameterised by the signature container type, the header--- 'ProtectionIndicator' type, and the header record type.+-- 'ProtectionSupport' type, and the header record type. -- -- Use 'encode' and 'decode' to convert a JWS to or from JSON. -- When encoding a @'JWS' []@ with exactly one signature, the@@ -375,28 +385,33 @@ -- 'encodeCompact'). -- -- Use 'signJWS' to create a signed/MACed JWS.------ Use 'verifyJWS' to verify a JWS and extract the payload.++-- Use 'verifyJWS', 'verifyJWS'' or 'verifyJWSWithPayload' to verify+-- a JWS and extract the payload. --+-- Applications generally should not access a payload without+-- first verifying it. If you have an exceptional use case, you+-- can use 'unsafeGetPayload' to access the payload.+ data JWS t p a = JWS Types.Base64Octets (t (Signature p a)) -- | A JWS that allows multiple signatures, and cannot use -- the /compact serialisation/. Headers may be 'Protected' -- or 'Unprotected'. ---type GeneralJWS = JWS [] Protection+type GeneralJWS = JWS [] OptionalProtection -- | A JWS with one signature, which uses the -- /flattened serialisation/. Headers may be 'Protected' -- or 'Unprotected'. ---type FlattenedJWS = JWS Identity Protection+type FlattenedJWS = JWS Identity OptionalProtection -- | A JWS with one signature which only allows protected -- parameters. Can use the /flattened serialisation/ or -- the /compact serialisation/. ---type CompactJWS = JWS Identity ()+type CompactJWS = JWS Identity RequiredProtection instance (Eq (t (Signature p a))) => Eq (JWS t p a) where JWS p sigs == JWS p' sigs' = p == p' && sigs == sigs'@@ -407,30 +422,44 @@ signatures :: Foldable t => Fold (JWS t p a) (Signature p a) signatures = folding (\(JWS _ sigs) -> sigs) -instance (HasParams a, ProtectionIndicator p) => FromJSON (JWS [] p a) where+instance (HasParams a, ProtectionSupport p) => FromJSON (JWS [] p a) where parseJSON v = withObject "JWS JSON serialization" (\o -> JWS <$> o .: "payload" <*> o .: "signatures") v <|> fmap (\(JWS p (Identity s)) -> JWS p [s]) (parseJSON v) -instance (HasParams a, ProtectionIndicator p) => FromJSON (JWS Identity p a) where+instance (HasParams a, ProtectionSupport p) => FromJSON (JWS Identity p a) where parseJSON = withObject "Flattened JWS JSON serialization" $ \o -> if M.member "signatures" o then fail "\"signatures\" member MUST NOT be present" else (\p s -> JWS p (pure s)) <$> o .: "payload" <*> parseJSON (Object o) -instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS [] p a) where+instance (HasParams a, ProtectionSupport p) => ToJSON (JWS [] p a) where toJSON (JWS p [s]) = Types.insertToObject "payload" p (toJSON s) toJSON (JWS p ss) = object ["payload" .= p, "signatures" .= ss] -instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS Identity p a) where+instance (HasParams a, ProtectionSupport p) => ToJSON (JWS Identity p a) where toJSON (JWS p (Identity s)) = Types.insertToObject "payload" p (toJSON s) +-- | Get the payload __without verifying it__. Do not use this+-- function unless you have a compelling reason.+--+-- Most applications should use 'verifyJWSWithPayload', 'verifyJWS'+-- or 'verifyJWS'' to verify the JWS and access the payload.+--+unsafeGetPayload+ :: (Cons s s Word8 Word8, AsEmpty s)+ => (s -> m payload) -- ^ Function to decode payload+ -> JWS t p a -- ^ JWS+ -> m payload+unsafeGetPayload dec (JWS (Types.Base64Octets s) _) = views recons dec s++ signingInput- :: (HasParams a, ProtectionIndicator p)+ :: (HasParams a, ProtectionSupport p) => Signature p a -> Types.Base64Octets -> B.ByteString@@ -444,7 +473,7 @@ -- Application code should never need to use this. It is exposed -- for testing purposes. rawProtectedHeader- :: (HasParams a, ProtectionIndicator p)+ :: (HasParams a, ProtectionSupport p) => Signature p a -> B.ByteString rawProtectedHeader (Signature raw h _) = maybe (view recons $ protectedParamsEncoded h) T.encodeUtf8 raw@@ -454,13 +483,13 @@ -- The operation is defined only when there is exactly one -- signature and returns Nothing otherwise ---instance HasParams a => ToCompact (JWS Identity () a) where+instance (HasParams a) => ToCompact (JWS Identity RequiredProtection a) where toCompact (JWS p (Identity s@(Signature _ _ (Types.Base64Octets sig)))) = [ view recons $ signingInput s p , review Types.base64url sig ] -instance HasParams a => FromCompact (JWS Identity () a) where+instance (HasParams a) => FromCompact (JWS Identity RequiredProtection a) where fromCompact xs = case xs of [h, p, s] -> do (h', p', s') <- (,,) <$> t 0 h <*> t 1 p <*> t 2 s@@ -483,7 +512,7 @@ :: ( Cons s s Word8 Word8 , HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m , Traversable t- , ProtectionIndicator p+ , ProtectionSupport p ) => s -- ^ Payload -> t (a p, JWK) -- ^ Traversable of header, key pairs@@ -495,7 +524,7 @@ mkSignature :: ( HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m- , ProtectionIndicator p+ , ProtectionSupport p ) => B.ByteString -> a p -> JWK -> m (Signature p a) mkSignature p h k =@@ -567,6 +596,7 @@ , ES256, ES384, ES512 , PS256, PS384, PS512 , EdDSA+ , ES256K ] ) AllValidated @@ -579,7 +609,7 @@ , VerificationKeyStore m (h p) s k , Cons s s Word8 Word8, AsEmpty s , Foldable t- , ProtectionIndicator p+ , ProtectionSupport p ) => k -- ^ key or key store -> JWS t p h -- ^ JWS@@ -603,7 +633,7 @@ , VerificationKeyStore m (h p) s k , Cons s s Word8 Word8, AsEmpty s , Foldable t- , ProtectionIndicator p+ , ProtectionSupport p ) => a -- ^ validation settings -> k -- ^ key or key store@@ -612,20 +642,24 @@ verifyJWS = verifyJWSWithPayload pure {-# INLINE verifyJWS #-} +-- | Verify a JWS, with explicit payload decoding. This variant+-- enables the key store to use information in the payload to locate+-- verification key(s).+-- verifyJWSWithPayload :: ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m , HasJWSHeader h, HasParams h , VerificationKeyStore m (h p) payload k , Cons s s Word8 Word8, AsEmpty s , Foldable t- , ProtectionIndicator p+ , ProtectionSupport p ) => (s -> m payload) -- ^ payload decoder -> a -- ^ validation settings -> k -- ^ key or key store -> JWS t p h -- ^ JWS -> m payload-verifyJWSWithPayload dec conf k (JWS p@(Types.Base64Octets p') sigs) =+verifyJWSWithPayload dec conf k jws@(JWS p sigs) = let algs :: S.Set Alg algs = conf ^. algorithms@@ -639,17 +673,19 @@ validate payload sig = do keys <- getVerificationKeys (view header sig) payload k- if null keys- then throwing_ _NoUsableKeys- else pure $ any ((== Right True) . verifySig p sig) keys+ case (keys, view (header . alg . param) sig) of+ -- special case for alg "none"+ ([], None) -> pure $ verifySig p sig undefined == Right True+ ([], _) -> throwing_ _NoUsableKeys+ _ -> pure $ any ((== Right True) . verifySig p sig) keys in do- payload <- (dec . view recons) p'+ payload <- unsafeGetPayload dec jws results <- traverse (validate payload) $ filter shouldValidateSig $ toList sigs payload <$ applyPolicy policy results {-# INLINE verifyJWSWithPayload #-} verifySig- :: (HasJWSHeader a, HasParams a, ProtectionIndicator p)+ :: (HasJWSHeader a, HasParams a, ProtectionSupport p) => Types.Base64Octets -> Signature p a -> JWK
src/Crypto/JOSE/TH.hs view
@@ -12,7 +12,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-|@@ -44,7 +43,7 @@ conize = mkName . capitalize . sanitize guardPred :: String -> ExpQ-guardPred s = [e| $(varE $ mkName "s") == s |]+guardPred s = [e| $(varE $ mkName "s") == $(lift s) |] guardExp :: String -> ExpQ guardExp s = [e| pure $(conE $ conize s) |]@@ -58,7 +57,7 @@ -- | Expression for an end guard. Arg describes type it was expecting. -- endGuardExp :: String -> ExpQ-endGuardExp s = [e| fail ("unrecognised value; expected: " ++ s) |]+endGuardExp s = [e| fail ("unrecognised value; expected: " ++ $(lift s)) |] -- | Build a catch-all guard that fails. String describes what is expected. --@@ -76,7 +75,7 @@ toJSONClause :: String -> ClauseQ-toJSONClause s = clause [conP (conize s) []] (normalB [| s |]) []+toJSONClause s = clause [conP (conize s) []] (normalB [| $(lift s) |]) [] toJSONFun :: [String] -> DecQ toJSONFun vs = funD 'toJSON (map toJSONClause vs)@@ -100,11 +99,7 @@ let derive = map mkName ["Eq", "Ord", "Show"] in-#if ! MIN_VERSION_template_haskell(2,12,0)- dataD (cxt []) (mkName s) [] Nothing (map conQ vs) (mapM conT derive)-#else dataD (cxt []) (mkName s) [] Nothing (map conQ vs) [return (DerivClause Nothing (map ConT derive))]-#endif , instanceD (cxt []) (aesonInstance s ''FromJSON) [parseJSONFun vs] , instanceD (cxt []) (aesonInstance s ''ToJSON) [toJSONFun vs] ]
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/Internal.hs view
@@ -12,9 +12,7 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-} {-|
− 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
@@ -12,9 +12,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-}@@ -30,51 +27,27 @@ JWTs use the JWS /compact serialisation/. See "Crypto.JOSE.Compact" for details. -@-mkClaims :: IO 'ClaimsSet'-mkClaims = do- t <- 'currentTime'- pure $ 'emptyClaimsSet'- & 'claimIss' ?~ "alice"- & 'claimAud' ?~ 'Audience' ["bob"]- & 'claimIat' ?~ 'NumericDate' t--doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT')-doJwtSign jwk claims = runExceptT $ do- alg \<- 'bestJWSAlg' jwk- 'signClaims' jwk ('newJWSHeader' ((), alg)) claims--doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet')-doJwtVerify jwk jwt = runExceptT $ do- let config = 'defaultJWTValidationSettings' (== "bob")- '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 (- -- * Creating a JWT- signClaims- , SignedJWT+ -- * Overview / HOWTO+ -- ** Basic usage+ -- $basic - -- * Validating a JWT and extracting claims+ -- ** Supporting additional claims via subtypes #subtypes#+ -- $subtypes++ -- * API+ -- ** Creating a JWT+ SignedJWT+ , SignedJWTWithHeader+ , signJWT+ , signClaims++ -- ** Validating a JWT and extracting claims , defaultJWTValidationSettings , verifyClaims- , verifyClaimsAt+ , verifyJWT , HasAllowedSkew(..) , HasAudiencePredicate(..) , HasIssuerPredicate(..)@@ -82,25 +55,29 @@ , JWTValidationSettings , HasJWTValidationSettings(..) - -- * Claims Set+ -- *** Specifying the verification time+ , WrappedUTCTime(..)+ , verifyClaimsAt+ , verifyJWTAt++ -- ** Extracting claims without verification+ , unsafeGetJWTPayload+ , unsafeGetJWTClaimsSet++ -- ** Claims Set , ClaimsSet- , claimAud- , claimExp- , claimIat- , claimIss- , claimJti- , claimNbf- , claimSub- , unregisteredClaims- , addClaim , emptyClaimsSet+ , HasClaimsSet(..) , validateClaimsSet+ -- *** Unregistered claims (__deprecated__)+ , addClaim+ , unregisteredClaims - -- * JWT errors+ -- ** JWT errors , JWTError(..) , AsJWTError(..) - -- * Miscellaneous+ -- ** Miscellaneous types , Audience(..) , StringOrURI , stringOrUri@@ -108,6 +85,7 @@ , uri , NumericDate(..) + -- ** Re-exports , module Crypto.JOSE ) where@@ -119,7 +97,6 @@ import Data.Functor.Identity import Data.Maybe import qualified Data.String-import Data.Semigroup ((<>)) import Control.Lens ( makeClassy, makeClassyPrisms, makePrisms,@@ -142,7 +119,81 @@ import Crypto.JOSE import Crypto.JOSE.Types +{- $basic +@+import Crypto.JWT++mkClaims :: IO 'ClaimsSet'+mkClaims = do+ t <- 'currentTime'+ pure $ 'emptyClaimsSet'+ & 'claimIss' ?~ "alice"+ & 'claimAud' ?~ 'Audience' ["bob"]+ & 'claimIat' ?~ 'NumericDate' t++doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT')+doJwtSign jwk claims = 'runJOSE' $ do+ alg \<- 'bestJWSAlg' jwk+ 'signClaims' jwk ('newJWSHeaderProtected' alg) claims++doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet')+doJwtVerify jwk jwt = 'runJOSE' $ do+ let config = 'defaultJWTValidationSettings' (== "bob")+ '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 = 'runJOSE' $ do+ let+ k' = 'fromOctets' k -- turn raw secret into symmetric JWK+ audCheck = const True -- should be a proper audience check+ jwt <- 'decodeCompact' s -- decode JWT+ 'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' (jwt :: 'SignedJWT')+@++-}++{- $subtypes++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').++-}++ data JWTError = JWSError Error -- ^ A JOSE error occurred while processing the JWT@@ -170,7 +221,7 @@ -- contains a @:@ but does not parse as a 'URI'. Use 'stringOrUri' -- directly in this situation. ---data StringOrURI = Arbitrary T.Text | OrURI URI deriving (Eq, Show)+data StringOrURI = Arbitrary T.Text | OrURI URI deriving (Eq, Show, Ord) -- | Non-total. A string with a @':'@ in it MUST parse as a URI instance Data.String.IsString StringOrURI where@@ -241,9 +292,13 @@ -- | 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 defined in+-- 'HasClaimsSet' to set relevant claims. --+-- For applications that use additional claims beyond those defined+-- by RFC 7519, define a [subtype](#g:subtypes) and instance 'HasClaimsSet'.+-- data ClaimsSet = ClaimsSet { _claimIss :: Maybe StringOrURI , _claimSub :: Maybe StringOrURI@@ -256,83 +311,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 [subtype](#g:subtypes) to define additional claims" #-} -- | 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 "use a [subtype](#g:subtypes) to define additional claims" #-} registeredClaims :: S.Set T.Text registeredClaims = S.fromDistinctAscList@@ -347,11 +437,7 @@ filterUnregistered :: M.Map T.Text Value -> M.Map T.Text Value filterUnregistered m =-#if MIN_VERSION_containers(0,5,8) m `M.withoutKeys` registeredClaims-#else- m `M.difference` M.fromSet (const ()) registeredClaims-#endif toKeyMap :: M.Map T.Text Value -> KeyMap.KeyMap Value toKeyMap = KeyMap.fromMap . M.mapKeysMonotonic Key.fromText@@ -448,9 +534,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 ::@@ -529,54 +615,136 @@ unless (view issuerPredicate conf iss) (throwing_ _JWTNotInIssuer) ) . preview (claimIss . _Just) --- | A digitally signed or MACed JWT+-- | A digitally signed or MAC'd JWT, with the JWS header type fixed+-- at 'JWSHeader'. ---type SignedJWT = CompactJWS JWSHeader+type SignedJWT = SignedJWTWithHeader JWSHeader +-- | A digitally signed or MAC'd JWT, with caller-specified JWS+-- header type. For information about defining custom header types+-- see /Defining additional header parameters/ in "Crypto.JOSE.JWS".+--+type SignedJWTWithHeader h = CompactJWS h newtype WrappedUTCTime = WrappedUTCTime { getUTCTime :: UTCTime } +-- | @'monotonicTime' = pure 0@. /jose/ doesn't use this so we fake it instance Monad m => MonadTime (ReaderT WrappedUTCTime m) where currentTime = asks getUTCTime+ monotonicTime = pure 0 +-- | Get the JWT payload __without verifying it__. Do not use this+-- function unless you have a compelling reason.+--+-- Most applications should use 'verifyJWT' or one of its variants+-- to verify the JWT and access the claims.+--+-- See also 'unsafeGetJWTClaimsSet' which is the same as this+-- function with the payload type specialised to 'ClaimsSet'.+--+unsafeGetJWTPayload+ :: ( FromJSON payload, AsJWTError e, MonadError e m )+ => SignedJWT -> m payload+unsafeGetJWTPayload = unsafeGetPayload f+ where+ f = either (throwing _JWTClaimsSetDecodeError) pure . eitherDecode +-- | Variant of 'unsafeGetJWTPayload' specialised to 'ClaimsSet'+unsafeGetJWTClaimsSet+ :: ( AsJWTError e, MonadError e m )+ => SignedJWT -> m ClaimsSet+unsafeGetJWTClaimsSet = unsafeGetJWTPayload++ -- | 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+ , HasJWSHeader h, HasParams h , AsError e, AsJWTError e, MonadError e m- , VerificationKeyStore m (JWSHeader ()) ClaimsSet k+ , VerificationKeyStore m (h RequiredProtection) payload k+ , HasClaimsSet payload, FromJSON payload ) => a+ -- ^ Validation settings -> k- -> SignedJWT- -> m ClaimsSet-verifyClaims conf k jws =+ -- ^ Key store+ -> SignedJWTWithHeader h+ -- ^ JWT. Simple use cases may find the 'SignedJWT' type synonym useful for+ -- fixing the type of @h@.+ -> 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+ , HasJWSHeader h, HasParams h+ , AsError e, AsJWTError e, MonadError e m+ , VerificationKeyStore m (h RequiredProtection) ClaimsSet k+ )+ => a+ -- ^ Validation settings+ -> k+ -- ^ Key store+ -> SignedJWTWithHeader h+ -- ^ JWT. Simple use cases may find the 'SignedJWT' type synonym useful for+ -- fixing the type of @h@.+ -> 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+ , HasJWSHeader h, HasParams h+ , AsError e, AsJWTError e, MonadError e m+ , VerificationKeyStore (ReaderT WrappedUTCTime m) (h RequiredProtection) payload k+ , HasClaimsSet payload, FromJSON payload+ )+ => a+ -- ^ Validation settings+ -> k+ -- ^ Key store+ -> UTCTime+ -- ^ Validation time+ -> SignedJWTWithHeader h+ -- ^ JWT. Simple use cases may find the 'SignedJWT' type synonym useful for+ -- fixing the type of @h@.+ -> 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 ::@@ -584,22 +752,61 @@ , HasIssuerPredicate a , HasCheckIssuedAt a , HasValidationSettings a+ , HasJWSHeader h, HasParams h , AsError e, AsJWTError e, MonadError e m- , VerificationKeyStore (ReaderT WrappedUTCTime m) (JWSHeader ()) ClaimsSet k+ , VerificationKeyStore (ReaderT WrappedUTCTime m) (h RequiredProtection) ClaimsSet k ) => a+ -- ^ Validation settings -> k+ -- ^ Key store -> UTCTime- -> SignedJWT+ -- ^ Validation time+ -> SignedJWTWithHeader h+ -- ^ JWT. Simple use cases may find the 'SignedJWT' type synonym useful for+ -- fixing the type of @h@. -> 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+ , HasJWSHeader h, HasParams h+ , ToJSON payload )+ => JWK+ -- ^ Signing key+ -> h RequiredProtection+ -- ^ JWS Header. Commonly this will be 'JWSHeader'. If your application+ -- uses additional header fields, see /Defining additional header parameters/+ -- in "Crypto.JOSE.JWS".+ -> payload+ -- ^ The payload ('ClaimsSet' or a subtype).+ -> m (SignedJWTWithHeader h)+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)+ :: ( MonadRandom m, MonadError e m, AsError e+ , HasJWSHeader h, HasParams h ) => JWK- -> JWSHeader ()+ -- ^ Signing key+ -> h RequiredProtection+ -- ^ JWS Header. Commonly this will be 'JWSHeader'. If your application+ -- uses additional header fields, see /Defining additional header parameters/+ -- in "Crypto.JOSE.JWS". -> ClaimsSet- -> m SignedJWT-signClaims k h c = signJWS (encode c) (Identity (h, k))+ -- ^ Payload+ -> m (SignedJWTWithHeader h)+signClaims = signJWT
test/AESKW.hs view
@@ -12,43 +12,51 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -module AESKW where+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-} +module AESKW+ ( aeskwProperties+ ) where+ import qualified Data.ByteString as B import Crypto.Cipher.AES 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/Examples.hs view
@@ -1,8 +1,10 @@--- | Miscellaneous end-to-end examples. {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}-module Examples where +-- | Miscellaneous end-to-end examples.+module Examples+ ( spec+ ) where+ import Control.Lens (_Right, (&), (?~), (.~)) import Control.Lens.Extras (is) import qualified Data.ByteString.Char8 as BC8@@ -39,7 +41,7 @@ (do es256jwk <- errorOrJWK jwt <- decodeCompact es256token- verifyClaimsAt valSettings es256jwk now jwt) `shouldBe`+ verifyClaimsAt valSettings es256jwk now (jwt :: SignedJWT)) `shouldBe` Right expectedClaims _ -> pure ()
test/JWK.hs view
@@ -12,11 +12,12 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# LANGUAGE OverloadedStrings #-} -module JWK where--import Data.Monoid ((<>))+module JWK+ ( spec+ ) where import Control.Lens (_Left, _Right, review, view) import Control.Lens.Extras (is)
test/JWS.hs view
@@ -14,18 +14,19 @@ {-# LANGUAGE OverloadedStrings #-} -module JWS where+module JWS+ ( spec+ ) where import Data.Maybe-import Data.Monoid ((<>)) 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+import qualified Data.Set as S import Test.Hspec import Crypto.JOSE.Compact@@ -108,7 +109,7 @@ -- protected header: {"kid":""} s = "{\"protected\":\"eyJraWQiOiIifQ\",\"header\":{\"alg\":\"none\",\"kid\":\"\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection JWSHeader))+ (eitherDecode s :: Either String (Signature OptionalProtection JWSHeader)) `shouldSatisfy` is _Left it "rejects reserved crit parameters" $@@ -116,7 +117,7 @@ -- protected header: {"crit":["kid"],"kid":""} s = "{\"protected\":\"eyJjcml0IjpbImtpZCJdLCJraWQiOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection JWSHeader))+ (eitherDecode s :: Either String (Signature OptionalProtection JWSHeader)) `shouldSatisfy` is _Left it "rejects unknown crit parameters" $@@ -124,7 +125,7 @@ -- protected header: {"crit":["foo"],"foo":""} s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdLCJmb28iOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection JWSHeader))+ (eitherDecode s :: Either String (Signature OptionalProtection JWSHeader)) `shouldSatisfy` is _Left it "accepts known crit parameter in protected header" $@@ -132,7 +133,7 @@ -- protected header: {"crit":["foo"],"foo":""} s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdLCJmb28iOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection JWSHeader'))+ (eitherDecode s :: Either String (Signature OptionalProtection JWSHeader')) `shouldSatisfy` is _Right it "accepts known crit parameter in unprotected header" $@@ -140,7 +141,7 @@ -- protected header: {"crit":["foo"]} s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdfQ\",\"header\":{\"alg\":\"none\",\"foo\":\"\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection JWSHeader'))+ (eitherDecode s :: Either String (Signature OptionalProtection JWSHeader')) `shouldSatisfy` is _Right it "rejects known crit parameter that does not appear in JOSE header" $@@ -148,14 +149,14 @@ -- protected header: {"crit":["foo"]} s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdfQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection JWSHeader'))+ (eitherDecode s :: Either String (Signature OptionalProtection JWSHeader')) `shouldSatisfy` is _Left it "rejects unprotected crit parameters" $ let s = "{\"header\":{\"alg\":\"none\",\"crit\":[\"foo\"],\"foo\":\"\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection JWSHeader'))+ (eitherDecode s :: Either String (Signature OptionalProtection JWSHeader')) `shouldSatisfy` is _Left it "rejects empty crit parameters" $@@ -163,37 +164,37 @@ -- protected header: {"crit":[]} s = "{\"protected\":\"eyJjcml0IjpbXX0\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection JWSHeader'))+ (eitherDecode s :: Either String (Signature OptionalProtection JWSHeader')) `shouldSatisfy` is _Left it "parses required protected header when present in protected header" $ let -- protected header: {"crit":["nonce"],"nonce":"bm9uY2U"} s = "{\"protected\":\"eyJjcml0IjpbIm5vbmNlIl0sIm5vbmNlIjoiYm05dVkyVSJ9\""- <>",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"+ <> ",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection ACMEHeader))+ (eitherDecode s :: Either String (Signature OptionalProtection ACMEHeader)) `shouldSatisfy` is _Right it "rejects required protected header when present in unprotected header" $ let s = "{\"header\":{\"alg\":\"none\"},\"nonce\":\"bm9uY2U\",\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection ACMEHeader))+ (eitherDecode s :: Either String (Signature OptionalProtection ACMEHeader)) `shouldSatisfy` is _Left - it "accepts unprotected \"alg\" param with 'Protection' protection indicator" $+ it "accepts unprotected \"alg\" param with 'OptionalProtection' protection indicator" $ let s = "{\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature Protection JWSHeader))+ (eitherDecode s :: Either String (Signature OptionalProtection JWSHeader)) `shouldSatisfy` is _Right - it "rejects unprotected \"alg\" param with '()' protection indicator" $+ it "rejects unprotected \"alg\" param with 'RequiredProtection' protection indicator" $ let s = "{\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in- (eitherDecode s :: Either String (Signature () JWSHeader))+ (eitherDecode s :: Either String (Signature RequiredProtection JWSHeader)) `shouldSatisfy` is _Left @@ -203,10 +204,7 @@ \ \"exp\":1300819380,\r\n\ \ \"http://example.com/is_root\":true}" -examplePayload :: Types.Base64Octets-examplePayload = Types.Base64Octets examplePayloadBytes - appendixA1Spec :: Spec appendixA1Spec = describe "RFC 7515 A.1. Example JWS using HMAC SHA-256" $ do -- can't make aeson encode JSON to exact representation used in@@ -221,8 +219,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" $@@ -238,8 +235,8 @@ compactJWS = signingInput' <> ".dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk" jws = decodeCompact compactJWS :: Either Error (CompactJWS JWSHeader) alg_ = JWA.JWS.HS256- h = newJWSHeader ((), alg_)- & typ .~ Just (HeaderParam () "JWT")+ h = newJWSHeaderProtected alg_+ & typ .~ Just (newHeaderParamProtected "JWT") mac = view recons [116, 24, 223, 180, 151, 153, 224, 37, 79, 250, 96, 125, 216, 173, 187, 186, 22, 212, 37, 77, 105, 214, 191, 240, 91, 88, 5, 88, 83,@@ -275,7 +272,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,8 +280,8 @@ `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))))+ fst (withDRG drg (runJOSE $+ signJWS signingInput' (Identity (newJWSHeaderProtected JWA.JWS.RS256, jwkRSA1024)))) `shouldBe` (Left KeySizeTooSmall :: Either Error (CompactJWS JWSHeader)) where@@ -365,15 +362,20 @@ it "decodes the correct JWS" $ decodeCompact exampleJWS `shouldBe` jws + it "can be verified with an empty key set" $+ (jws >>= verifyJWS conf (JWKSet []) :: Either Error BS.ByteString)+ `shouldSatisfy` is _Right+ where- jws = fst $ withDRG drg $ runExceptT $- signJWS examplePayloadBytes (Identity (newJWSHeader ((), JWA.JWS.None), undefined))+ jws = fst $ withDRG drg $ runJOSE $+ signJWS examplePayloadBytes (Identity (newJWSHeaderProtected JWA.JWS.None, undefined)) :: Either Error (CompactJWS JWSHeader) exampleJWS = "eyJhbGciOiJub25lIn0\ \.\ \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\ \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ\ \."+ conf = set algorithms (S.singleton None) defaultValidationSettings appendixA6Spec :: Spec@@ -514,7 +516,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
@@ -12,20 +12,21 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -module JWT where+module JWT+ ( spec+ ) where 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,39 @@ 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 (newJWSHeaderProtected 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+ 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 (newJWSHeaderProtected 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@@ -149,62 +198,64 @@ describe "with a Not Before claim" $ do let- claimsSet = emptyClaimsSet & claimNbf .~ intDate "2016-07-05 17:37:22"+ claims = emptyClaimsSet & claimNbf .~ intDate "2016-07-05 17:37:22" describe "when the current time is prior to the Not Before claim" $ do let now = utcTime "2016-07-05 17:37:20" -- 2s before nbf it "cannot be validated" $- runReaderT (validateClaimsSet conf claimsSet) now+ runReaderT (validateClaimsSet conf claims) now `shouldBe` Left JWTNotYetValid it "cannot be validated if nonzero skew tolerance < delta" $ let conf' = set allowedSkew 1 conf- in runReaderT (validateClaimsSet conf' claimsSet) now+ in runReaderT (validateClaimsSet conf' claims) now `shouldBe` Left JWTNotYetValid it "can be validated if nonzero skew tolerance = delta" $ let conf' = set allowedSkew 2 conf- in runReaderT (validateClaimsSet conf' claimsSet) now- `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+ in runReaderT (validateClaimsSet conf' claims) now+ `shouldBe` (Right claims :: Either JWTError ClaimsSet) it "can be validated if nonzero skew tolerance > delta" $ let conf' = set allowedSkew 3 conf- in runReaderT (validateClaimsSet conf' claimsSet) now- `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+ in runReaderT (validateClaimsSet conf' claims) now+ `shouldBe` (Right claims :: Either JWTError ClaimsSet) it "can be validated if negative skew tolerance = -delta" $ let conf' = set allowedSkew (-2) conf- in runReaderT (validateClaimsSet conf' claimsSet) now- `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+ in runReaderT (validateClaimsSet conf' claims) now+ `shouldBe` (Right claims :: Either JWTError ClaimsSet) describe "when the current time is exactly equal to the Not Before claim" $ it "can be validated" $- runReaderT (validateClaimsSet conf claimsSet) (utcTime "2016-07-05 17:37:22")- `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+ runReaderT (validateClaimsSet conf claims) (utcTime "2016-07-05 17:37:22")+ `shouldBe` (Right claims :: Either JWTError ClaimsSet) describe "when the current time is after the Not Before claim" $ it "can be validated" $- runReaderT (validateClaimsSet conf claimsSet) (utcTime "2017-01-01 00:00:00")- `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+ runReaderT (validateClaimsSet conf claims) (utcTime "2017-01-01 00:00:00")+ `shouldBe` (Right claims :: Either JWTError ClaimsSet) describe "with Expiration Time and Not Before claims" $ do let- claimsSet = emptyClaimsSet & claimExp .~ intDate "2011-03-22 18:43:00"- & claimNbf .~ intDate "2011-03-20 17:37:22"+ claims =+ emptyClaimsSet+ & claimExp .~ intDate "2011-03-22 18:43:00"+ & claimNbf .~ intDate "2011-03-20 17:37:22" describe "when the current time is prior to the Not Before claim" $ it "cannot be validated" $- runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-18 00:00:00")+ runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-18 00:00:00") `shouldBe` Left JWTNotYetValid describe "when the current time is exactly equal to the Not Before claim" $ it "can be validated" $- runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-20 17:37:22")- `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+ runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-20 17:37:22")+ `shouldBe` (Right claims :: Either JWTError ClaimsSet) describe "when the current time is between the Not Before and Expiration Time claims" $ it "can be validated" $- runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-21 18:00:00")- `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)+ runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-21 18:00:00")+ `shouldBe` (Right claims :: Either JWTError ClaimsSet) describe "when the current time is exactly the Expiration Time" $ it "cannot be validated" $- runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-22 18:43:00")+ runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-22 18:43:00") `shouldBe` Left JWTExpired describe "when the current time is after the Expiration Time claim" $ it "cannot be validated" $- runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-24 00:00:00")+ runReaderT (validateClaimsSet conf claims) (utcTime "2011-03-24 00:00:00") `shouldBe` Left JWTExpired describe "with an Audience claim" $ do@@ -270,6 +321,28 @@ 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 @SignedJWT exampleJWT >>= verifyClaims settings k) now+ `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)+ runReaderT (decodeCompact @SignedJWT exampleJWT >>= verifyJWT settings k) now+ `shouldBe` (Right super :: Either JWTError Super)+ describe "RFC 7519 §6.1. Example Unsecured JWT" $ do let exampleJWT =@@ -278,7 +351,7 @@ <> "eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt" <> "cGxlLmNvbS9pc19yb290Ijp0cnVlfQ" <> "."- jwt = decodeCompact exampleJWT+ jwt = decodeCompact @SignedJWT exampleJWT k = fromJust $ decode "{\"kty\":\"oct\",\"k\":\"\"}" :: JWK describe "when the current time is prior to the Expiration Time" $@@ -293,7 +366,7 @@ describe "when signature is invalid and token is expired" $ it "fails on sig validation (claim validation not reached)" $ do- let jwt' = decodeCompact (exampleJWT <> "badsig")+ let jwt' = decodeCompact @SignedJWT (exampleJWT <> "badsig") (runReaderT (jwt' >>= verifyClaims conf k) (utcTime "2012-01-01 00:00:00") :: Either JWTError ClaimsSet) `shouldSatisfy` is (_Left . _JWSInvalidSignature)
test/Perf.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {- @@ -12,12 +11,11 @@ Related: https://github.com/frasertweedale/hs-jose/pull/103 -}-module Main where import Control.Lens ((^?), _Just) import Control.Monad.Except (ExceptT, runExceptT) import Crypto.JOSE.JWK.Store (VerificationKeyStore (getVerificationKeys))-import Crypto.JWT (CompactJWS, HasX5c (x5c), JWSHeader, JWTError, decodeCompact, fromX509Certificate, param, verifyJWS')+import Crypto.JWT (CompactJWS, HasX5c (x5c), JWSHeader, JWTError, RequiredProtection, decodeCompact, fromX509Certificate, param, verifyJWS') import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.List.NonEmpty (NonEmpty ((:|)))@@ -26,7 +24,7 @@ data Store = Store -instance VerificationKeyStore (ExceptT JWTError IO) (JWSHeader ()) B.ByteString Store where+instance VerificationKeyStore (ExceptT JWTError IO) (JWSHeader RequiredProtection) B.ByteString Store where getVerificationKeys header _ _ = do let Just (x :| _) = header ^? x5c . _Just . param res <- fromX509Certificate x
test/Properties.hs view
@@ -12,70 +12,190 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -module Properties where+module Properties+ ( properties+ ) where -import Control.Monad.Except (runExceptT)+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
@@ -14,12 +14,13 @@ {-# LANGUAGE OverloadedStrings #-} -module Types where+module Types+ ( spec+ ) where 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 +28,6 @@ spec :: Spec spec = do base64OctetsSpec- uriSpec base64IntegerSpec sizedBase64IntegerSpec base64X509Spec@@ -40,17 +40,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