jose 0.10.0.1 → 0.13
raw patch · 22 files changed
Files
- CHANGELOG.md +100/−0
- example/JWS.hs +1/−1
- example/KeyDB.hs +0/−5
- example/Main.hs +1/−3
- jose.cabal +29/−41
- src/Crypto/JOSE/AESKW.hs +0/−2
- src/Crypto/JOSE/Error.hs +0/−3
- src/Crypto/JOSE/Header.hs +59/−25
- src/Crypto/JOSE/JWA/JWK.hs +46/−12
- src/Crypto/JOSE/JWE.hs +3/−7
- src/Crypto/JOSE/JWK.hs +111/−36
- src/Crypto/JOSE/JWK/Store.hs +0/−3
- src/Crypto/JOSE/JWS.hs +64/−35
- src/Crypto/JOSE/TH.hs +0/−5
- src/Crypto/JOSE/Types/Internal.hs +0/−2
- src/Crypto/JWT.hs +87/−36
- test/Examples.hs +1/−2
- test/JWK.hs +0/−2
- test/JWS.hs +24/−19
- test/JWT.hs +6/−8
- test/Perf.hs +2/−4
- test/Properties.hs +0/−1
CHANGELOG.md view
@@ -1,3 +1,101 @@+## 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`@@ -39,6 +137,8 @@ [#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
example/JWS.hs view
@@ -39,7 +39,7 @@ payload <- L.readFile payloadFilename result <- runJOSE $ do h <- makeJWSHeader k- signJWS payload [(h :: JWSHeader Protection, k)]+ signJWS payload [(h :: JWSHeader OptionalProtection, k)] case result of Left e -> print (e :: Error) >> exitFailure Right jws -> L.putStr (encode jws)
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) @@ -76,7 +74,7 @@ let aud' = fromJust $ preview stringOrUri aud conf = defaultJWTValidationSettings (== aud')- go k = runJOSE $ decodeCompact jwtData >>= verifyClaims conf k+ go k = runJOSE $ decodeCompact @SignedJWT jwtData >>= verifyClaims conf k jwkDir <- isDirectory <$> getFileStatus jwkFilename result <-
jose.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: jose-version: 0.10.0.1+version: 0.13 synopsis: JSON Object Signing and Encryption (JOSE) and JSON Web Token (JWT) library description:@@ -24,59 +24,47 @@ license: Apache-2.0 license-file: LICENSE extra-source-files:+ test/data/fido.jwt+extra-doc-files: CHANGELOG.md README.md- test/data/fido.jwt 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 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.7 || ==9.6.3 || == 9.8.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+ default-language: GHC2021+ default-extensions: LambdaCase ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Werror=missing-methods- if impl(ghc >= 8.0)- ghc-options:- -Wcompat- -Wnoncanonical-monad-instances- -Wredundant-constraints- if impl(ghc >= 8.2)- ghc-options:- -fhide-source-paths- if impl(ghc >= 8.4)- ghc-options:- -Wmissing-export-lists- -Wpartial-fields- if impl(ghc >= 8.10)- ghc-options:- -Wunused-packages- if impl(ghc >= 9.0)- ghc-options:- -Winvalid-haddock- -Werror=unicode-bidirectional-format-characters- if impl(ghc >= 9.2)- ghc-options:- -Wimplicit-lift- -Woperator-whitespace- -Wredundant-bang-patterns- if impl(ghc >= 9.4)- ghc-options:- -Wredundant-strictness-flags+ -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+ base >= 4.18 && < 5 , bytestring >= 0.10 && < 0.13 , lens >= 4.16 , mtl >= 2.2.1@@ -110,15 +98,15 @@ , aeson >= 2.0.1.0 && < 3 , base64-bytestring >= 1.2.1.0 && < 1.3 , concise >= 0.1- , containers >= 0.5- , cryptonite >= 0.24- , 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- , x509 >= 1.4+ , crypton-x509 >= 1.7.6 hs-source-dirs: src @@ -144,10 +132,10 @@ , aeson , base64-bytestring , containers- , cryptonite+ , crypton , time , network-uri- , x509+ , crypton-x509 , pem , concise
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;
src/Crypto/JOSE/Error.hs view
@@ -12,8 +12,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-|@@ -41,7 +39,6 @@ ) where -import Data.Semigroup ((<>)) import Numeric.Natural import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)
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@@ -66,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)@@ -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,7 +259,7 @@ -- the protected or the unprotected header. -- headerOptional- :: (FromJSON a, ProtectionIndicator p)+ :: (FromJSON a, ProtectionSupport p) => T.Text -> Maybe Object -> Maybe Object@@ -237,7 +271,7 @@ -- but with an explicit argument for the parser. -- headerOptional'- :: (ProtectionIndicator p)+ :: (ProtectionSupport p) => (Value -> Parser a) -> T.Text -> Maybe Object@@ -275,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/JWK.hs view
@@ -12,11 +12,9 @@ -- 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 #-} {-|@@ -30,12 +28,13 @@ -- * Parameters for Elliptic Curve Keys , Crv(..)- , ECKeyParameters+ , ECKeyParameters(ECKeyParameters) , ecCrv, ecX, ecY, ecD , curve , point , ecPrivateKey , ecParametersFromX509+ , ecParametersFromX509Priv , genEC -- * Parameters for RSA Keys@@ -77,7 +76,6 @@ 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_)@@ -189,8 +187,12 @@ $ maybe (Object mempty) toJSON rsaOptionalParameters --- | Parameters for Elliptic Curve Keys+-- | Parameters for Elliptic Curve Keys. --+-- @+-- ECKeyParameters crv x y (Just d)+-- @+-- data ECKeyParameters = ECKeyParameters { _ecCrv :: Crv , _ecX :: Types.SizedBase64Integer@@ -303,19 +305,51 @@ ecPrivateKey (ECKeyParameters _ _ _ (Just (Types.SizedBase64Integer _ d))) = pure d ecPrivateKey _ = throwing _KeyMismatch "Not an EC private key" +-- | See also 'Crypto.JOSE.JWK.fromX509PubKey' and+-- 'Crypto.JOSE.JWK.fromX509Certificate'.+-- ecParametersFromX509 :: (MonadError e m, AsError e) => X509.PubKeyEC -> m ECKeyParameters-ecParametersFromX509 pubKeyEC = do- ecCurve <- maybe (throwing _KeyMismatch "Invalid EC point") pure $ X509.EC.ecPubKeyCurve pubKeyEC- curveName <- maybe (throwing _KeyMismatch "Unknown curve") pure $ X509.EC.ecPubKeyCurveName pubKeyEC- crv <- maybe (throwing _KeyMismatch "Unsupported curve TODO ") pure $ preview fromCurveName curveName- pt <- maybe (throwing _KeyMismatch "Invalid EC point") pure $ X509.EC.unserializePoint ecCurve (X509.pubkeyEC_pub pubKeyEC)+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 -> throwing _KeyMismatch "Cannot use point at infinity"+ 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
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,7 +24,6 @@ import Control.Applicative ((<|>)) import Data.Bifunctor (bimap) import Data.Maybe (catMaybes, fromMaybe)-import Data.Monoid ((<>)) import Control.Lens (view, views) import Data.Aeson@@ -83,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@@ -135,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"@@ -154,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
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,10 @@ -- 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 #-} {-|@@ -69,8 +67,11 @@ -- * Converting from other key formats , fromKeyMaterial , fromRSA+ , fromRSAPublic , fromOctets , fromX509Certificate+ , fromX509PubKey+ , fromX509PrivKey -- * JWK Thumbprint , thumbprint@@ -83,6 +84,7 @@ -- Miscellaneous , checkJWK+ , negotiateJWSAlg , bestJWSAlg , module Crypto.JOSE.JWA.JWK@@ -91,8 +93,8 @@ 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 ((.=))@@ -100,6 +102,10 @@ 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')@@ -243,12 +249,7 @@ fromRSAPublic :: RSA.PublicKey -> JWK fromRSAPublic = fromKeyMaterial . RSAKeyMaterial . toRSAPublicKeyParameters --- | Convert an EC public key into a JWK----fromECPublic :: (AsError e, MonadError e m) => X509.PubKeyEC -> m JWK-fromECPublic = fmap (fromKeyMaterial . ECKeyMaterial) . ecParametersFromX509 - -- | Convert octet string into a JWK -- fromOctets :: Cons s s Word8 Word8 => s -> JWK@@ -258,10 +259,45 @@ {-# 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. ----- Supports RSA and ECDSA (when the curve is supported). Other key types--- will throw 'AlgorithmNotImplemented'.+-- 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. --@@ -269,10 +305,7 @@ :: (AsError e, MonadError e m) => X509.SignedCertificate -> m JWK fromX509Certificate cert = do- k <- case (X509.certPubKey . X509.signedObject . X509.getSigned) cert of- X509.PubKeyRSA k -> pure (fromRSAPublic k)- X509.PubKeyEC k -> fromECPublic k- _ -> throwing _KeyMismatch "X.509 key type not supported"+ k <- fromX509PubKey . X509.certPubKey . X509.signedObject $ X509.getSigned cert pure $ k & set jwkX5cRaw (Just (pure cert)) fromX509CertificateMaybe :: X509.SignedCertificate -> Maybe JWK@@ -289,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")@@ -318,33 +351,75 @@ -- | 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- Secp256k1 -> JWA.JWS.ES256K- 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+ | 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- (Ed25519Key _ _) -> pure JWA.JWS.EdDSA- (Ed448Key _ _) -> pure JWA.JWS.EdDSA- (X25519Key _ _) -> throwing _KeyMismatch "Cannot sign with X25519 key"- (X448Key _ _) -> throwing _KeyMismatch "Cannot sign with X448 key"+ (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
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
@@ -34,12 +34,9 @@ -} -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Crypto.JOSE.JWS@@ -55,6 +52,7 @@ -- * JWS creation , newJWSHeader+ , newJWSHeaderProtected , makeJWSHeader , signJWS @@ -71,6 +69,9 @@ , HasAlgorithms(..) , HasValidationPolicy(..) + -- * Access payload without verification+ , unsafeGetPayload+ -- * Signature data , signatures , Signature@@ -92,7 +93,6 @@ 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) @@ -239,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.@@ -255,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@@ -302,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@@ -319,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@@ -364,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@@ -381,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'@@ -413,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@@ -450,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@@ -460,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@@ -489,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@@ -501,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 =@@ -586,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@@ -610,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@@ -619,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@@ -646,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 #-} {-|@@ -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/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/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 #-}@@ -43,8 +40,9 @@ -- * API -- ** Creating a JWT SignedJWT- , signClaims+ , SignedJWTWithHeader , signJWT+ , signClaims -- ** Validating a JWT and extracting claims , defaultJWTValidationSettings@@ -62,6 +60,10 @@ , verifyClaimsAt , verifyJWTAt + -- ** Extracting claims without verification+ , unsafeGetJWTPayload+ , unsafeGetJWTClaimsSet+ -- ** Claims Set , ClaimsSet , emptyClaimsSet@@ -95,7 +97,6 @@ import Data.Functor.Identity import Data.Maybe import qualified Data.String-import Data.Semigroup ((<>)) import Control.Lens ( makeClassy, makeClassyPrisms, makePrisms,@@ -134,7 +135,7 @@ doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT') doJwtSign jwk claims = 'runJOSE' $ do alg \<- 'bestJWSAlg' jwk- 'signClaims' jwk ('newJWSHeader' ((), alg)) claims+ 'signClaims' jwk ('newJWSHeaderProtected' alg) claims doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet') doJwtVerify jwk jwt = 'runJOSE' $ do@@ -152,8 +153,8 @@ 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+ jwt <- 'decodeCompact' s -- decode JWT+ 'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' (jwt :: 'SignedJWT') @ -}@@ -220,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@@ -436,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@@ -618,31 +615,51 @@ 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 } -#if MIN_VERSION_monad_time(0,4,0) -- | @'monotonicTime' = pure 0@. /jose/ doesn't use this so we fake it-#endif instance Monad m => MonadTime (ReaderT WrappedUTCTime m) where currentTime = asks getUTCTime-#if MIN_VERSION_monad_time(0,4,0) monotonicTime = pure 0-#endif +-- | 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. 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.@@ -657,13 +674,18 @@ , HasIssuerPredicate a , HasCheckIssuedAt a , HasValidationSettings a+ , HasJWSHeader h, HasParams h , AsError e, AsJWTError e, MonadError e m- , VerificationKeyStore m (JWSHeader ()) payload k+ , VerificationKeyStore m (h RequiredProtection) payload k , HasClaimsSet payload, FromJSON payload ) => a+ -- ^ Validation settings -> k- -> SignedJWT+ -- ^ 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@@ -680,12 +702,17 @@ , 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) ClaimsSet k ) => a+ -- ^ Validation settings -> k- -> SignedJWT+ -- ^ 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 @@ -699,14 +726,20 @@ , HasIssuerPredicate a , HasCheckIssuedAt a , HasValidationSettings a+ , HasJWSHeader h, HasParams h , AsError e, AsJWTError e, MonadError e m- , VerificationKeyStore (ReaderT WrappedUTCTime m) (JWSHeader ()) payload k+ , VerificationKeyStore (ReaderT WrappedUTCTime m) (h RequiredProtection) payload k , HasClaimsSet payload, FromJSON payload ) => 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 payload verifyJWTAt a k t jwt = runReaderT (verifyJWT a k jwt) (WrappedUTCTime t) @@ -719,13 +752,19 @@ , 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 = verifyJWTAt @@ -739,11 +778,17 @@ -- signJWT :: ( MonadRandom m, MonadError e m, AsError e+ , HasJWSHeader h, HasParams h , ToJSON payload ) => 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". -> payload- -> m SignedJWT+ -- ^ 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@@ -753,9 +798,15 @@ -- ("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+ -- ^ Payload+ -> m (SignedJWTWithHeader h) signClaims = signJWT
test/Examples.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-} -- | Miscellaneous end-to-end examples. module Examples@@ -42,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
@@ -19,8 +19,6 @@ ( spec ) where -import Data.Monoid ((<>))- import Control.Lens (_Left, _Right, review, view) import Control.Lens.Extras (is) import Data.Aeson
test/JWS.hs view
@@ -19,7 +19,6 @@ ) where import Data.Maybe-import Data.Monoid ((<>)) import Control.Lens hiding ((.=)) import Control.Lens.Extras (is)@@ -27,6 +26,7 @@ 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@@ -109,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" $@@ -117,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" $@@ -125,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" $@@ -133,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" $@@ -141,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" $@@ -149,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" $@@ -164,7 +164,7 @@ -- 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" $@@ -173,28 +173,28 @@ s = "{\"protected\":\"eyJjcml0IjpbIm5vbmNlIl0sIm5vbmNlIjoiYm05dVkyVSJ9\"" <> ",\"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 @@ -235,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,@@ -281,7 +281,7 @@ it "prohibits signing with 1024-bit key" $ fst (withDRG drg (runJOSE $- signJWS signingInput' (Identity (newJWSHeader ((), JWA.JWS.RS256), jwkRSA1024))))+ signJWS signingInput' (Identity (newJWSHeaderProtected JWA.JWS.RS256, jwkRSA1024)))) `shouldBe` (Left KeySizeTooSmall :: Either Error (CompactJWS JWSHeader)) where@@ -362,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 $ runJOSE $- signJWS examplePayloadBytes (Identity (newJWSHeader ((), JWA.JWS.None), undefined))+ 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
test/JWT.hs view
@@ -12,7 +12,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module JWT@@ -20,7 +19,6 @@ ) where import Data.Maybe-import Data.Monoid ((<>)) import qualified Data.ByteString.Lazy as L import Control.Lens@@ -101,7 +99,7 @@ valConf = defaultJWTValidationSettings (const True) k <- genJWK $ RSAGenParam 256 res <- runJOSE $ do- token <- signClaims k (newJWSHeader ((), RS512)) claims+ token <- signClaims k (newJWSHeaderProtected RS512) claims token' <- decodeCompact . encodeCompact $ token liftIO $ token' `shouldBe` token claims' <- verifyClaims valConf k token'@@ -114,7 +112,7 @@ now = utcTime "2010-01-01 00:00:00" k <- genJWK $ RSAGenParam 256 res <- runJOSE $ do- token <- signJWT k (newJWSHeader ((), RS512)) super+ token <- signJWT k (newJWSHeaderProtected RS512) super token' <- decodeCompact . encodeCompact $ token liftIO $ token' `shouldBe` token claims <- runReaderT (verifyJWT valConf k token') now@@ -340,9 +338,9 @@ 192,205,154,245,103,208,128,163] now = utcTime "2010-01-01 00:00:00" settings = defaultJWTValidationSettings (const True)- runReaderT (decodeCompact exampleJWT >>= verifyClaims settings k) now+ runReaderT (decodeCompact @SignedJWT exampleJWT >>= verifyClaims settings k) now `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)- runReaderT (decodeCompact exampleJWT >>= verifyJWT settings k) now+ runReaderT (decodeCompact @SignedJWT exampleJWT >>= verifyJWT settings k) now `shouldBe` (Right super :: Either JWTError Super) describe "RFC 7519 §6.1. Example Unsecured JWT" $ do@@ -353,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" $@@ -368,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,6 +1,4 @@ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {- @@ -17,7 +15,7 @@ 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
@@ -21,7 +21,6 @@ ( properties ) where -import Control.Applicative (liftA2) import Control.Monad.IO.Class import Control.Lens ((&), set, view)