diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,9 +4,14 @@ Encryption](https://datatracker.ietf.org/wg/jose/) and [JSON Web Token](https://tools.ietf.org/html/rfc7519). -Encryption (JWE) is not supported but signing is supported. All key -types and algorithms are supported, however, EC signing is currently -vulnerable to timing attacks therefore its use is **strongly -discouraged** (EC validation is safe). +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). + +The **ECDSA implementation is vulnerable to timing attacks** and +should therefore only be used for verification. + +JWK Thumbprint (RFC 7638) is supported (requires *aeson* >= 0.10). Contributions are welcome. diff --git a/example/JWS.hs b/example/JWS.hs new file mode 100644 --- /dev/null +++ b/example/JWS.hs @@ -0,0 +1,44 @@ +module JWS where + +import System.Exit (exitFailure) + +import Control.Monad.Except (runExceptT) +import Data.Aeson (decode, encode) +import qualified Data.ByteString.Lazy as L + +import Crypto.JOSE.JWS + +-- | Create a JWS. Args are: +-- +-- 1. filename of JWK +-- 2. filename of payload +-- +-- Output is a signed JWS (JSON serialisation). +-- +doJwsSign :: [String] -> IO () +doJwsSign [jwkFilename, payloadFilename] = do + Just jwk <- decode <$> L.readFile jwkFilename + payload <- L.readFile payloadFilename + result <- runExceptT $ do + alg <- bestJWSAlg jwk + signJWS payload [(newJWSHeader (Protected, alg), jwk)] + case result of + Left e -> print (e :: Error) >> exitFailure + Right jws -> L.putStr (encode jws) + + +-- | Verify a JWS and output the payload if valid. Args are: +-- +-- 1. filename of JWK +-- 2. filename of JWS +-- +-- Exit code indicates validity. +-- +doJwsVerify :: [String] -> IO () +doJwsVerify [jwkFilename, jwsFilename] = do + Just jwk <- decode <$> L.readFile jwkFilename + Just jws <- decode <$> L.readFile jwsFilename + result <- runExceptT $ verifyJWS' (jwk :: JWK) (jws :: GeneralJWS JWSHeader) + case result of + Left e -> print (e :: Error) >> exitFailure + Right s -> L.putStr s diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -1,28 +1,33 @@ {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE CPP #-} +import Data.Maybe (fromJust) import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) +import System.Exit (exitFailure) import qualified Data.ByteString.Lazy as L import Data.Aeson (decode, encode) +import Data.Text.Strict.Lens (utf8) import Control.Monad.Except (runExceptT) -import Crypto.JOSE.JWK (KeyMaterialGenParam(..), Crv(..), genJWK, bestJWSAlg) +import Control.Lens (preview, re, review, set, view) + import Crypto.JWT - ( createJWSJWT, validateJWSJWT - , defaultJWTValidationSettings, JWTError) -import Crypto.JOSE.Compact (decodeCompact, encodeCompact) -import Crypto.JOSE.JWS (Protection(Protected), newJWSHeader) -import Crypto.JOSE.Error (Error) +import JWS (doJwsSign, doJwsVerify) main :: IO () main = do args <- getArgs case head args of "jwk-gen" -> doGen (tail args) + "jws-sign" -> doJwsSign (tail args) + "jws-verify" -> doJwsVerify (tail args) "jwt-sign" -> doJwtSign (tail args) "jwt-verify" -> doJwtVerify (tail args) +#if MIN_VERSION_aeson(0,10,0) + "jwk-thumbprint" -> doThumbprint (tail args) +#endif doGen :: [String] -> IO () doGen [kty] = do @@ -31,8 +36,17 @@ "oct" -> OctGenParam 32 "rsa" -> RSAGenParam 256 "ec" -> ECGenParam P_256 + "eddsa" -> OKPGenParam Ed25519 jwk <- genJWK param - L.putStr (encode jwk) +#if MIN_VERSION_aeson(0,10,0) + let + h = view thumbprint jwk :: Digest SHA256 + kid = view (re (base64url . digest) . utf8) h + jwk' = set jwkKid (Just kid) jwk +#else + let jwk' = jwk +#endif + L.putStr (encode jwk') -- | Mint a JWT. Args are: -- @@ -47,27 +61,45 @@ Just claims <- decode <$> L.readFile claimsFilename result <- runExceptT $ do alg <- bestJWSAlg jwk - let header = newJWSHeader (Protected, alg) - createJWSJWT jwk header claims >>= encodeCompact + signClaims jwk (newJWSHeader ((), alg)) claims case result of Left e -> print (e :: Error) >> exitFailure - Right jwtData -> L.putStr jwtData + Right jwt -> L.putStr (encodeCompact jwt) -- | Validate a JWT. Args are: -- -- 1. filename of JWK --- 2. filename of a claims object +-- 2. filename of a JWT +-- 3. audience -- --- Exit code indicates validity. +-- Extraneous trailing args are ignored. -- +-- If JWT is valid, output JSON claims and exit 0, +-- otherwise exit nonzero. +-- doJwtVerify :: [String] -> IO () -doJwtVerify [jwkFilename, jwtFilename] = do +doJwtVerify [jwkFilename, jwtFilename, aud] = do + let + aud' = fromJust $ preview stringOrUri aud + conf = defaultJWTValidationSettings (== aud') Just jwk <- decode <$> L.readFile jwkFilename jwtData <- L.readFile jwtFilename - result <- runExceptT ( - decodeCompact jwtData - >>= validateJWSJWT defaultJWTValidationSettings jwk) + result <- runExceptT + (decodeCompact jwtData >>= verifyClaims conf (jwk :: JWK)) case result of Left e -> print (e :: JWTError) >> exitFailure - Right _ -> exitSuccess + Right claims -> L.putStr $ encode claims + + +#if MIN_VERSION_aeson(0,10,0) +-- | Print a base64url-encoded SHA-256 JWK Thumbprint. Args are: +-- +-- 1. filename of JWK +-- +doThumbprint :: [String] -> IO () +doThumbprint (jwkFilename : _) = do + Just jwk <- decode <$> L.readFile jwkFilename + let h = view thumbprint jwk :: Digest SHA256 + L.putStr $ review (base64url . digest) h +#endif diff --git a/jose.cabal b/jose.cabal --- a/jose.cabal +++ b/jose.cabal @@ -1,5 +1,5 @@ name: jose -version: 0.5.0.5 +version: 0.6.0.0 synopsis: Javascript Object Signing and Encryption and JSON Web Token library description: @@ -8,17 +8,15 @@ (JOSE) and JSON Web Token (JWT; RFC 7519) formats. . The JSON Web Signature (JWS; RFC 7515) implementation is complete. - JSON Web Encryption (JWE; RFC 7516) is not yet implemented. . - All JWS algorithms (HMAC, ECDSA, RSASSA-PKCS-v1_5 and RSASSA-PSS) - are implemented, however, the ECDSA implementation is is - vulnerable to timing attacks and should therefore only be used for - JWS verification. + EdDSA signatures (RFC 8037) are supported (Ed25519 only). . - The 'Crypto.JOSE.Legacy' module is provided for working with the - Mozilla Persona (formerly BrowserID) key format. Only RSA keys - are supported - DSA keys cannot be used and must be handled as - opaque objects. + JWK Thumbprint (RFC 7638) is supported (requires /aeson/ >= 0.10). + . + JSON Web Encryption (JWE; RFC 7516) is not yet implemented. + . + The __ECDSA implementation is vulnerable to timing attacks__ and + should only be used for verification. homepage: https://github.com/frasertweedale/hs-jose bug-reports: https://github.com/frasertweedale/hs-jose/issues @@ -28,12 +26,10 @@ README.md author: Fraser Tweedale maintainer: frase@frase.id.au -copyright: Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale +copyright: Copyright (C) 2013, 2014, 2015, 2016, 2017 Fraser Tweedale category: Cryptography build-type: Simple cabal-version: >= 1.8 -tested-with: - GHC==7.10.3, GHC==8.0.1, GHC==8.0.2, GHC==8.2.1 library exposed-modules: @@ -43,34 +39,32 @@ Crypto.JOSE.Header Crypto.JOSE.JWE Crypto.JOSE.JWK + Crypto.JOSE.JWK.Store Crypto.JOSE.JWS - Crypto.JOSE.Legacy Crypto.JOSE.Types Crypto.JWT - - other-modules: Crypto.JOSE.AESKW Crypto.JOSE.JWA.JWK Crypto.JOSE.JWA.JWS Crypto.JOSE.JWA.JWE Crypto.JOSE.JWA.JWE.Alg - Crypto.JOSE.JWS.Internal + + other-modules: Crypto.JOSE.TH Crypto.JOSE.Types.Internal Crypto.JOSE.Types.Orphans build-depends: - base >= 4.8 && < 5 + base == 4.* , attoparsec , base64-bytestring == 1.0.* - , byteable == 0.1.* + , concise >= 0.1 , containers >= 0.5 , cryptonite >= 0.7 , lens >= 4.3 , memory >= 0.7 , monad-time >= 0.1 , mtl >= 2 - , semigroups >= 0.15 , template-haskell >= 2.4 , safe >= 0.3 , aeson >= 0.8.0.1 @@ -84,7 +78,14 @@ , x509 >= 1.4 , vector - ghc-options: -Wall + if impl(ghc < 7.10) + build-depends: + bifunctors >= 4.0 + if impl(ghc < 8) + build-depends: + semigroups >= 0.15 + + ghc-options: -Wall -O2 hs-source-dirs: src source-repository head @@ -93,7 +94,7 @@ test-suite tests type: exitcode-stdio-1.0 - hs-source-dirs: src, test + hs-source-dirs: test main-is: Test.hs other-modules: AESKW @@ -107,14 +108,12 @@ base , attoparsec , base64-bytestring - , byteable , containers , cryptonite , lens , memory , monad-time , mtl - , semigroups , template-haskell , safe , aeson @@ -126,6 +125,9 @@ , vector , x509 + , concise + , jose + , tasty , tasty-hspec , tasty-quickcheck @@ -133,10 +135,19 @@ , QuickCheck , quickcheck-instances + if impl(ghc < 7.10) + build-depends: + bifunctors >= 4.0 + if impl(ghc < 8) + build-depends: + semigroups >= 0.15 + executable example hs-source-dirs: example - main-is: Main.hs ghc-options: -Wall + main-is: Main.hs + other-modules: + JWS build-depends: base , aeson diff --git a/src/Crypto/JOSE.hs b/src/Crypto/JOSE.hs --- a/src/Crypto/JOSE.hs +++ b/src/Crypto/JOSE.hs @@ -22,12 +22,15 @@ module Crypto.JOSE.Compact , module Crypto.JOSE.Error , module Crypto.JOSE.JWK + , module Crypto.JOSE.JWK.Store , module Crypto.JOSE.JWS ) where import Crypto.JOSE.Compact import Crypto.JOSE.Error import Crypto.JOSE.JWK +import Crypto.JOSE.JWK.Store import Crypto.JOSE.JWS +import Crypto.JOSE.Types (base64url) {-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-} diff --git a/src/Crypto/JOSE/Compact.hs b/src/Crypto/JOSE/Compact.hs --- a/src/Crypto/JOSE/Compact.hs +++ b/src/Crypto/JOSE/Compact.hs @@ -43,9 +43,9 @@ -- | Data that can be converted to a compact representation. -- class ToCompact a where - toCompact :: (AsError e, MonadError e m) => a -> m [L.ByteString] + toCompact :: a -> [L.ByteString] -- | Encode data to a compact representation. -- -encodeCompact :: (ToCompact a, AsError e, MonadError e m) => a -> m L.ByteString -encodeCompact = fmap (L.intercalate ".") . toCompact +encodeCompact :: (ToCompact a) => a -> L.ByteString +encodeCompact = (L.intercalate ".") . toCompact diff --git a/src/Crypto/JOSE/Error.hs b/src/Crypto/JOSE/Error.hs --- a/src/Crypto/JOSE/Error.hs +++ b/src/Crypto/JOSE/Error.hs @@ -44,7 +44,6 @@ | OtherPrimesNotSupported -- ^ RSA private key with >2 primes not supported | RSAError RSA.Error -- ^ RSA encryption, decryption or signing error | CryptoError CryptoError -- ^ Various cryptonite library error cases - | CompactEncodeError String -- ^ Cannot produce compact representation of data | CompactDecodeError String -- ^ Cannot decode compact representation | JSONDecodeError String -- ^ JSON (Aeson) decoding error | JWSCritUnprotected @@ -54,6 +53,7 @@ -- ^ 'AllValidated' policy active, and invalid signature encountered | JWSNoSignatures -- ^ 'AllValidated' policy active, and there were no signatures on object + -- that matched the allowed algorithms deriving (Eq, Show) makeClassyPrisms ''Error diff --git a/src/Crypto/JOSE/Header.hs b/src/Crypto/JOSE/Header.hs --- a/src/Crypto/JOSE/Header.hs +++ b/src/Crypto/JOSE/Header.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2016 Fraser Tweedale +-- Copyright (C) 2016, 2017 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,6 +12,7 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-| @@ -21,25 +22,51 @@ -} module Crypto.JOSE.Header ( - HasParams(..) - , parseParams - , protectedParamsEncoded - , unprotectedParams - - , parseCrit - + -- * Defining header data types + HeaderParam(..) + , ProtectionIndicator(..) , Protection(..) - , HeaderParam(..) , protection + , isProtected , param + + -- * Defining header parsers + -- $parsing + , HasParams(..) , headerRequired + , headerRequiredProtected , headerOptional , headerOptionalProtected + + -- * Parsing headers + , parseParams + , parseCrit + + -- * Encoding headers + , protectedParamsEncoded + , unprotectedParams + + + -- * Header fields shared by JWS and JWE + , HasAlg(..) + , HasJku(..) + , HasJwk(..) + , HasKid(..) + , HasX5u(..) + , HasX5c(..) + , HasX5t(..) + , HasX5tS256(..) + , HasTyp(..) + , HasCty(..) + , HasCrit(..) ) where +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid ((<>)) import Data.Proxy (Proxy(..)) +import Control.Lens (Lens', Getter, to) import Data.Aeson (FromJSON(..), Object, Value, encode, object) import Data.Aeson.Types (Pair, Parser) import qualified Data.ByteString.Base64.URL.Lazy as B64UL @@ -47,64 +74,162 @@ import qualified Data.HashMap.Strict as M import qualified Data.Text as T +import qualified Crypto.JOSE.JWA.JWS as JWA.JWS +import Crypto.JOSE.JWK (JWK) import Crypto.JOSE.Types.Orphans () import Crypto.JOSE.Types.Internal (unpad) +import qualified Crypto.JOSE.Types as Types -class HasParams a where - params :: a -> [(Protection, Pair)] +-- | A thing with parameters. +-- +class HasParams (a :: * -> *) where + -- | Return a list of parameters, + -- each paired with whether it is protected or not. + params :: ProtectionIndicator p => a p -> [(Bool, Pair)] + -- | List of "known extensions", i.e. keys that may appear in the + -- "crit" header parameter. extensions :: Proxy a -> [T.Text] extensions = const [] - parseParamsFor :: HasParams b => Proxy b -> Maybe Object -> Maybe Object -> Parser a + parseParamsFor + :: (HasParams b, ProtectionIndicator p) + => Proxy b -> Maybe Object -> Maybe Object -> Parser (a p) -parseParams :: forall a. HasParams a => Maybe Object -> Maybe Object -> Parser a +-- | Parse a pair of objects (protected and unprotected header) +-- +-- This internally invokes 'parseParamsFor' applied to a proxy for +-- the target type. (This allows the parsing of the "crit" parameter +-- to access "known extensions" understood by the target type.) +-- +parseParams + :: forall a p. (HasParams a, ProtectionIndicator p) + => Maybe Object -- ^ protected header + -> Maybe Object -- ^ unprotected header + -> Parser (a p) parseParams = parseParamsFor (Proxy :: Proxy a) -protectedParams :: HasParams a => a -> Maybe Value {- ^ Object -} +protectedParams + :: (HasParams a, ProtectionIndicator p) + => a p -> Maybe Value {- ^ Object -} protectedParams h = - case (map snd . filter ((== Protected) . fst) . params) h of + case (map snd . filter fst . params) h of [] -> Nothing xs -> Just (object xs) -protectedParamsEncoded :: HasParams a => a -> L.ByteString +-- | Return the encoded protected parameters +-- +protectedParamsEncoded + :: (HasParams a, ProtectionIndicator p) + => a p -> L.ByteString protectedParamsEncoded = maybe mempty (unpad . B64UL.encode . encode) . protectedParams -unprotectedParams :: HasParams a => a -> Maybe Value {- ^ Object -} +-- | Return unprotected params as a JSON 'Value' (always an object) +-- +unprotectedParams + :: (HasParams a, ProtectionIndicator p) + => a p -> Maybe Value {- ^ Object -} unprotectedParams h = - case (map snd . filter ((== Unprotected) . fst) . params) h of + 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) -data HeaderParam a = HeaderParam Protection a +class Eq a => ProtectionIndicator a where + -- | Get a value for indicating protection. + getProtected :: a + + -- | Get a 'Just' a value for indicating no protection, or 'Nothing' + -- if the type does not support unprotected headers. + getUnprotected :: Maybe a + +instance ProtectionIndicator Protection where + getProtected = Protected + getUnprotected = Just Unprotected + +instance ProtectionIndicator () where + getProtected = () + getUnprotected = Nothing + + +-- | A header value, along with a protection indicator. +-- +data HeaderParam p a = HeaderParam p a deriving (Eq, Show) -protection :: HeaderParam a -> Protection -protection (HeaderParam b _) = b +-- | Lens for the 'Protection' of a 'HeaderParam' +protection :: Lens' (HeaderParam p a) p +protection f (HeaderParam p v) = fmap (\p' -> HeaderParam p' v) (f p) -param :: HeaderParam a -> a -param (HeaderParam _ a) = a +-- | Lens for a 'HeaderParam' value +param :: Lens' (HeaderParam p a) a +param f (HeaderParam p v) = fmap (\v' -> HeaderParam p v') (f v) +-- | Getter for whether a parameter is protected +isProtected :: (ProtectionIndicator p) => Getter (HeaderParam p a) Bool +isProtected = protection . to (== getProtected) + +{- $parsing + +The 'parseParamsFor' function defines the parser for a header type. + +@ +'parseParamsFor' + :: ('HasParams' a, HasParams b) + => Proxy b -> Maybe Object -> Maybe Object -> 'Parser' a +@ + +It is defined over two objects: the /protected header/ and the +/unprotected header/. The following functions are provided for +parsing header parameters: + +['headerOptional'] + An optional parameter that may be protected or unprotected. +['headerRequired'] + A required parameter that may be protected or unprotected. +['headerOptionalProtected'] + An optional parameter that, if present, MUST be carried in the protected header. +['headerRequiredProtected'] + A required parameter that, if present, MUST be carried in the protected header. + +Duplicate headers are forbidden. The above functions all perform +duplicate header detection. If you do not use them, be sure to +perform this detection yourself! + +An example parser: + +@ +instance HasParams ACMEHeader where + 'parseParamsFor' proxy hp hu = ACMEHeader + \<$> 'parseParamsFor' proxy hp hu + \<*> 'headerRequiredProtected' "nonce" hp hu +@ + +-} + -- | Parse an optional parameter that may be carried in either -- the protected or the unprotected header. -- headerOptional - :: FromJSON a + :: (FromJSON a, ProtectionIndicator p) => T.Text -> Maybe Object -> Maybe Object - -> Parser (Maybe (HeaderParam a)) + -> Parser (Maybe (HeaderParam p a)) headerOptional k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of (Just _, Just _) -> fail $ "duplicate header " ++ show k - (Just v, Nothing) -> Just . HeaderParam Protected <$> parseJSON v - (Nothing, Just v) -> Just . HeaderParam Unprotected <$> parseJSON v + (Just v, Nothing) -> Just . HeaderParam getProtected <$> parseJSON v + (Nothing, Just v) -> maybe + (fail "unprotected header not supported") + (\p -> Just . HeaderParam p <$> parseJSON v) + getUnprotected (Nothing, Nothing) -> pure Nothing -- | Parse an optional parameter that, if present, MUST be carried @@ -117,6 +242,7 @@ -> Maybe Object -> Parser (Maybe a) headerOptionalProtected k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of + (Just _, Just _) -> fail $ "duplicate header " ++ show k (_, Just _) -> fail $ "header must be protected: " ++ show k (Just v, _) -> Just <$> parseJSON v _ -> pure Nothing @@ -125,18 +251,36 @@ -- the protected or the unprotected header. -- headerRequired - :: FromJSON a + :: (FromJSON a, ProtectionIndicator p) => T.Text -> Maybe Object -> Maybe Object - -> Parser (HeaderParam a) + -> Parser (HeaderParam p a) headerRequired k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of (Just _, Just _) -> fail $ "duplicate header " ++ show k - (Just v, Nothing) -> HeaderParam Protected <$> parseJSON v - (Nothing, Just v) -> HeaderParam Unprotected <$> parseJSON v + (Just v, Nothing) -> HeaderParam getProtected <$> parseJSON v + (Nothing, Just v) -> maybe + (fail "unprotected header not supported") + (\p -> HeaderParam p <$> parseJSON v) + getUnprotected (Nothing, Nothing) -> fail $ "missing required header " ++ show k +-- | Parse a required parameter that MUST be carried +-- in the protected header. +-- +headerRequiredProtected + :: FromJSON a + => T.Text + -> Maybe Object + -> Maybe Object + -> Parser a +headerRequiredProtected k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of + (Just _, Just _) -> fail $ "duplicate header " ++ show k + (_, Just _) -> fail $ "header must be protected: " <> show k + (Just v, _) -> parseJSON v + _ -> fail $ "missing required protected header: " <> show k + critObjectParser :: (Foldable t0, Foldable t1, Monad m) => t0 T.Text -> t1 T.Text -> Object -> T.Text -> m T.Text @@ -146,12 +290,54 @@ | not (s `M.member` o) = fail "crit key is not present in headers" | otherwise = pure s +-- | Parse a "crit" header param +-- +-- Fails if: +-- +-- * any reserved header appears in "crit" header +-- * any value in "crit" is not a recognised extension +-- * any value in "crit" does not have a corresponding key in the object +-- parseCrit :: (Foldable t0, Foldable t1, Traversable t2, Traversable t3, Monad m) - => t0 T.Text - -> t1 T.Text - -> Object - -> t2 (t3 T.Text) + => t0 T.Text -- ^ reserved header parameters + -> t1 T.Text -- ^ recognised extensions + -> Object -- ^ full header (union of protected and unprotected headers) + -> t2 (t3 T.Text) -- ^ crit header -> m (t2 (t3 T.Text)) parseCrit reserved exts o = mapM (mapM (critObjectParser reserved exts o)) -- TODO fail on duplicate strings + + +class HasAlg a where + alg :: Lens' (a p) (HeaderParam p JWA.JWS.Alg) + +class HasJku a where + jku :: Lens' (a p) (Maybe (HeaderParam p Types.URI)) + +class HasJwk a where + jwk :: Lens' (a p) (Maybe (HeaderParam p JWK)) + +class HasKid a where + kid :: Lens' (a p) (Maybe (HeaderParam p String)) + +class HasX5u a where + x5u :: Lens' (a p) (Maybe (HeaderParam p Types.URI)) + +class HasX5c a where + x5c :: Lens' (a p) (Maybe (HeaderParam p (NonEmpty Types.Base64X509))) + +class HasX5t a where + x5t :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA1)) + +class HasX5tS256 a where + x5tS256 :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA256)) + +class HasTyp a where + typ :: Lens' (a p) (Maybe (HeaderParam p String)) + +class HasCty a where + cty :: Lens' (a p) (Maybe (HeaderParam p String)) + +class HasCrit a where + crit :: Lens' (a p) (Maybe (NonEmpty T.Text)) diff --git a/src/Crypto/JOSE/JWA/JWE.hs b/src/Crypto/JOSE/JWA/JWE.hs --- a/src/Crypto/JOSE/JWA/JWE.hs +++ b/src/Crypto/JOSE/JWA/JWE.hs @@ -34,8 +34,7 @@ import Data.Aeson --- --- JWA §4. Cryptographic Algorithms for Encryption +-- | RFC 7518 §4. Cryptographic Algorithms for Key Management -- data AlgWithParams = RSA1_5 @@ -107,7 +106,7 @@ toJSON (PBES2_HS512_A256KW params) = algWithParamsObject params "PBES2-HS512+A256KW" --- | JWA §4.7.1. Header Parameters Used for ECDH Key Agreement +-- | RFC 7518 §4.6.1. Header Parameters Used for ECDH Key Agreement -- data ECDHParameters = ECDHParameters { _epk :: JWK -- ^ Ephemeral Public Key ; a JWK PUBLIC key @@ -129,7 +128,7 @@ ] --- | JWA §4.8.1. Header Parameters Used for AES GCM Key Encryption +-- | RFC 7518 §4.7.1. Header Parameters Used for AES GCM Key Encryption -- data AESGCMParameters = AESGCMParameters { _iv :: Base64Octets -- ^ Initialization Vector (must be 96 bits?) @@ -145,7 +144,7 @@ toJSON (AESGCMParameters iv tag) = object ["iv" .= iv, "tag" .= tag] --- | JWA §4.9.1. Header Parameters Used for PBES2 Key Encryption +-- | RFC 7518 §4.8.1. Header Parameters Used for PBES2 Key Encryption -- data PBES2Parameters = PBES2Parameters { _p2s :: Base64Octets -- ^ PBKDF2 salt input @@ -161,7 +160,7 @@ toJSON (PBES2Parameters p2s p2c) = object ["p2s" .= p2s, "p2c" .= p2c] --- | JWA §4.2. "enc" (Encryption Method) Header Parameters Values for JWE +-- | RFC 7518 §5 Cryptographic Algorithms for Content Encryption -- $(deriveJOSEType "Enc" [ "A128CBC-HS256" -- AES HMAC SHA authenticated encryption Required diff --git a/src/Crypto/JOSE/JWA/JWE/Alg.hs b/src/Crypto/JOSE/JWA/JWE/Alg.hs --- a/src/Crypto/JOSE/JWA/JWE/Alg.hs +++ b/src/Crypto/JOSE/JWA/JWE/Alg.hs @@ -25,7 +25,7 @@ import qualified Crypto.JOSE.TH --- | JWA §4.1. "alg" (Algorithm) Header Parameter Values for JWE +-- | RFC 7518 §4.1. "alg" (Algorithm) Header Parameter Values for JWE -- -- This section is shuffled off into its own module to avoid -- circular import via Crypto.JOSE.JWK, which needs Alg. diff --git a/src/Crypto/JOSE/JWA/JWK.hs b/src/Crypto/JOSE/JWA/JWK.hs --- a/src/Crypto/JOSE/JWA/JWK.hs +++ b/src/Crypto/JOSE/JWA/JWK.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale +-- Copyright (C) 2013, 2014, 2015, 2016, 2017 Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -13,6 +13,7 @@ -- limitations under the License. {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -29,11 +30,6 @@ -- * Type classes AsPublicKey(..) - -- * \"kty\" (Key Type) Parameter Values - , EC(..) - , RSA(..) - , Oct(..) - -- * Parameters for Elliptic Curve Keys , Crv(..) , ECKeyParameters(..) @@ -45,7 +41,6 @@ , RSAKeyParameters(RSAKeyParameters) , toRSAKeyParameters , rsaE - , rsaKty , rsaN , rsaPrivateKeyParameters , rsaPublicKey @@ -54,6 +49,10 @@ -- * Parameters for Symmetric Keys , OctKeyParameters(..) + -- * Parameters for CFRG EC keys (RFC 8037) + , OKPKeyParameters(..) + , OKPCrv(..) + -- * Key generation , KeyMaterialGenParam(..) , KeyMaterial(..) @@ -67,12 +66,15 @@ ) where import Control.Applicative +import Control.Monad (guard) import Control.Monad.Except (MonadError(throwError)) import Data.Bifunctor -import Data.Maybe +import Data.Foldable (toList) +import Data.Maybe (fromMaybe, isJust) import Data.Monoid ((<>)) import Control.Lens hiding ((.=), elements) +import Crypto.Error (onCryptoFailure) import Crypto.Hash import Crypto.MAC.HMAC import qualified Crypto.PubKey.ECC.ECDSA as ECDSA @@ -81,13 +83,16 @@ import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15 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.Curve25519 as Curve25519 import Crypto.Random import Data.Aeson import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.HashMap.Strict as M -import Data.List.NonEmpty -import Test.QuickCheck (Arbitrary(..), arbitrarySizedNatural, elements, oneof) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Text as T +import Test.QuickCheck (Arbitrary(..), arbitrarySizedNatural, elements, oneof, vectorOf) import Crypto.JOSE.Error import qualified Crypto.JOSE.JWA.JWS as JWA.JWS @@ -97,20 +102,12 @@ import Crypto.JOSE.Types.Orphans () --- | Elliptic Curve key type (Recommeded+) -$(Crypto.JOSE.TH.deriveJOSEType "EC" ["EC"]) --- | RSA key type (Required) -$(Crypto.JOSE.TH.deriveJOSEType "RSA" ["RSA"]) --- | Octet sequence (symmetric key) key type (Required) -$(Crypto.JOSE.TH.deriveJOSEType "Oct" ["oct"]) - - -- | \"crv\" (Curve) Parameter -- $(Crypto.JOSE.TH.deriveJOSEType "Crv" ["P-256", "P-384", "P-521"]) instance Arbitrary Crv where - arbitrary = oneof $ pure <$> [P_256, P_384, P_521] + arbitrary = elements [P_256, P_384, P_521] -- | \"oth\" (Other Primes Info) Parameter @@ -202,9 +199,7 @@ -- | Parameters for Elliptic Curve Keys -- data ECKeyParameters = ECKeyParameters - { - ecKty :: EC - , ecCrv :: Crv + { ecCrv :: Crv , ecX :: Types.SizedBase64Integer , ecY :: Types.SizedBase64Integer , ecD :: Maybe Types.SizedBase64Integer @@ -213,10 +208,10 @@ instance FromJSON ECKeyParameters where parseJSON = withObject "EC" $ \o -> do + o .: "kty" >>= guard . (== ("EC" :: T.Text)) crv <- o .: "crv" ECKeyParameters - <$> o .: "kty" - <*> pure crv + <$> pure crv <*> (o .: "x" >>= Types.checkSize (ecCoordBytes crv)) <*> (o .: "y" >>= Types.checkSize (ecCoordBytes crv)) <*> (o .:? "d" >>= \case @@ -225,17 +220,17 @@ instance ToJSON ECKeyParameters where toJSON (ECKeyParameters {..}) = object $ - [ "kty" .= ecKty + [ "kty" .= ("EC" :: T.Text) , "crv" .= ecCrv , "x" .= ecX , "y" .= ecY - ] ++ fmap ("d" .=) (maybeToList ecD) + ] ++ fmap ("d" .=) (toList ecD) instance Arbitrary ECKeyParameters where arbitrary = do crv <- arbitrary let w = ecCoordBytes crv - ECKeyParameters EC crv + ECKeyParameters crv <$> Types.genSizedBase64IntegerOf w <*> Types.genSizedBase64IntegerOf w <*> oneof @@ -266,8 +261,8 @@ -> ECKeyParameters -> msg -> B.ByteString - -> Either Error Bool -verifyEC h k m s = Right $ ECDSA.verify h pubkey sig m + -> Bool +verifyEC h k m s = ECDSA.verify h pubkey sig m where pubkey = ECDSA.PublicKey (curve $ ecCrv k) (point k) sig = uncurry ECDSA.Signature @@ -297,8 +292,7 @@ -- | Parameters for RSA Keys -- data RSAKeyParameters = RSAKeyParameters - { _rsaKty :: RSA - , _rsaN :: Types.SizedBase64Integer + { _rsaN :: Types.SizedBase64Integer , _rsaE :: Types.Base64Integer , _rsaPrivateKeyParameters :: Maybe RSAPrivateKeyParameters } @@ -306,10 +300,10 @@ makeLenses ''RSAKeyParameters instance FromJSON RSAKeyParameters where - parseJSON = withObject "RSA" $ \o -> + parseJSON = withObject "RSA" $ \o -> do + o .: "kty" >>= guard . (== ("RSA" :: T.Text)) RSAKeyParameters - <$> o .: "kty" - <*> o .: "n" + <$> o .: "n" <*> o .: "e" <*> if M.member "d" o then Just <$> parseJSON (Object o) @@ -317,13 +311,13 @@ instance ToJSON RSAKeyParameters where toJSON RSAKeyParameters {..} = object $ - ("kty" .= _rsaKty) + ("kty" .= ("RSA" :: T.Text)) : ("n" .= _rsaN) : ("e" .= _rsaE) : maybe [] (Types.objectPairs . toJSON) _rsaPrivateKeyParameters instance Arbitrary RSAKeyParameters where - arbitrary = RSAKeyParameters RSA + arbitrary = RSAKeyParameters <$> arbitrary <*> arbitrary <*> arbitrary @@ -334,7 +328,7 @@ toRSAKeyParameters :: RSA.PrivateKey -> RSAKeyParameters toRSAKeyParameters (RSA.PrivateKey (RSA.PublicKey s n e) d p q dp dq qi) = let i = Types.Base64Integer - in RSAKeyParameters RSA + in RSAKeyParameters ( Types.SizedBase64Integer s n ) ( i e ) ( Just (RSAPrivateKeyParameters (i d) @@ -358,8 +352,8 @@ -> RSAKeyParameters -> B.ByteString -> B.ByteString - -> Either Error Bool -verifyPKCS15 h k m = Right . PKCS15.verify (Just h) (rsaPublicKey k) m + -> Bool +verifyPKCS15 h k = PKCS15.verify (Just h) (rsaPublicKey k) signPSS :: (HashAlgorithm h, MonadRandom m, MonadError e m, AsError e) @@ -378,17 +372,16 @@ -> RSAKeyParameters -> B.ByteString -> B.ByteString - -> Either Error Bool -verifyPSS h k m = Right . - PSS.verify (PSS.defaultPSSParams h) (rsaPublicKey k) m + -> Bool +verifyPSS h k = PSS.verify (PSS.defaultPSSParams h) (rsaPublicKey k) rsaPrivateKey :: RSAKeyParameters -> Either Error RSA.PrivateKey -rsaPrivateKey (RSAKeyParameters _ +rsaPrivateKey (RSAKeyParameters (Types.SizedBase64Integer size n) (Types.Base64Integer e) (Just (RSAPrivateKeyParameters (Types.Base64Integer d) opt))) | isJust (opt >>= rsaOth) = Left OtherPrimesNotSupported - | n < 2 ^ (2040 :: Integer) = Left KeySizeTooSmall + | size < 2048 `div` 8 = Left KeySizeTooSmall | otherwise = Right $ RSA.PrivateKey (RSA.PublicKey size n e) d (opt' rsaP) (opt' rsaQ) (opt' rsaDp) (opt' rsaDq) (opt' rsaQi) @@ -399,28 +392,31 @@ rsaPrivateKey _ = Left $ KeyMismatch "not an RSA private key" rsaPublicKey :: RSAKeyParameters -> RSA.PublicKey -rsaPublicKey (RSAKeyParameters _ +rsaPublicKey (RSAKeyParameters (Types.SizedBase64Integer size n) (Types.Base64Integer e) _) = RSA.PublicKey size n e -- | Symmetric key parameters data. -- -data OctKeyParameters = OctKeyParameters - { octKty :: Oct - , octK :: Types.Base64Octets +newtype OctKeyParameters = OctKeyParameters + { octK :: Types.Base64Octets } deriving (Eq, Show) instance FromJSON OctKeyParameters where - parseJSON = withObject "symmetric key" $ \o -> - OctKeyParameters <$> o .: "kty" <*> o .: "k" + parseJSON = withObject "symmetric key" $ \o -> do + o .: "kty" >>= guard . (== ("oct" :: T.Text)) + OctKeyParameters <$> o .: "k" instance ToJSON OctKeyParameters where - toJSON OctKeyParameters {..} = object ["kty" .= octKty, "k" .= octK] + toJSON OctKeyParameters {..} = object + [ "kty" .= ("oct" :: T.Text) + , "k" .= octK + ] instance Arbitrary OctKeyParameters where - arbitrary = OctKeyParameters Oct <$> arbitrary + arbitrary = OctKeyParameters <$> arbitrary signOct :: forall h e m. (HashAlgorithm h, MonadError e m, AsError e) @@ -428,35 +424,128 @@ -> OctKeyParameters -> B.ByteString -> m B.ByteString -signOct h (OctKeyParameters _ (Types.Base64Octets k)) m = +signOct h (OctKeyParameters (Types.Base64Octets k)) m = if B.length k < hashDigestSize h then throwError (review _KeySizeTooSmall ()) else pure $ B.pack $ BA.unpack (hmac k m :: HMAC h) +-- "OKP" (CFRG Octet Key Pair) keys (RFC 8037) +-- +data OKPKeyParameters + = Ed25519Key Ed25519.PublicKey (Maybe Ed25519.SecretKey) + | X25519Key Curve25519.PublicKey (Maybe Curve25519.SecretKey) + deriving (Eq) + +instance Show OKPKeyParameters where + show = \case + Ed25519Key pk sk -> "Ed25519 " <> showKeys pk sk + X25519Key pk sk -> "X25519 " <> showKeys pk sk + where + showKeys pk sk = show pk <> " " <> show (("SECRET" :: String) <$ sk) + +instance FromJSON OKPKeyParameters where + parseJSON = withObject "OKP" $ \o -> do + o .: "kty" >>= guard . (== ("OKP" :: T.Text)) + crv <- o .: "crv" + 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" + _ -> fail "unrecognised OKP key subtype" + where + bs (Types.Base64Octets k) = k + handleError = onCryptoFailure (fail . show) pure + parseOKPKey con mkPub mkSec o = con + <$> (o .: "x" >>= handleError . mkPub . bs) + <*> (o .:? "d" >>= traverse (handleError . mkSec . bs)) + +instance ToJSON OKPKeyParameters where + toJSON x = object $ + "kty" .= ("OKP" :: T.Text) : case x of + Ed25519Key pk sk -> "crv" .= ("Ed25519" :: T.Text) : params pk sk + X25519Key pk sk -> "crv" .= ("X25519" :: 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 + 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) + +signEdDSA + :: (MonadError e m, AsError e) + => OKPKeyParameters + -> B.ByteString + -> m B.ByteString +signEdDSA (Ed25519Key pk (Just sk)) m = pure . BA.convert $ Ed25519.sign sk pk m +signEdDSA (Ed25519Key _ Nothing) _ = throwError (review _KeyMismatch "not a private key") +signEdDSA _ _ = throwError (review _KeyMismatch "not an EdDSA key") + +verifyEdDSA + :: (BA.ByteArrayAccess msg, BA.ByteArrayAccess sig, MonadError e m, AsError e) + => OKPKeyParameters -> msg -> sig -> m Bool +verifyEdDSA (Ed25519Key pk _) m s = + onCryptoFailure + (throwError . review _CryptoError) + (pure . Ed25519.verify pk m) + (Ed25519.signature s) +verifyEdDSA _ _ _ = throwError (review _AlgorithmMismatch "not an EdDSA key") + + -- | Key material sum type. -- data KeyMaterial = ECKeyMaterial ECKeyParameters | RSAKeyMaterial RSAKeyParameters | OctKeyMaterial OctKeyParameters + | OKPKeyMaterial OKPKeyParameters deriving (Eq, Show) showKeyType :: KeyMaterial -> String showKeyType (ECKeyMaterial (ECKeyParameters { ecCrv = crv })) = "ECDSA (" ++ show crv ++ ")" showKeyType (RSAKeyMaterial _) = "RSA" showKeyType (OctKeyMaterial _) = "symmetric" +showKeyType (OKPKeyMaterial _) = "OKP" instance FromJSON KeyMaterial where parseJSON = withObject "KeyMaterial" $ \o -> ECKeyMaterial <$> parseJSON (Object o) <|> RSAKeyMaterial <$> parseJSON (Object o) <|> OctKeyMaterial <$> parseJSON (Object o) + <|> OKPKeyMaterial <$> parseJSON (Object o) instance ToJSON KeyMaterial where toJSON (ECKeyMaterial p) = object $ Types.objectPairs (toJSON p) toJSON (RSAKeyMaterial p) = object $ Types.objectPairs (toJSON p) toJSON (OctKeyMaterial p) = object $ Types.objectPairs (toJSON p) + toJSON (OKPKeyMaterial p) = object $ Types.objectPairs (toJSON p) -- | Keygen parameters. -- @@ -467,6 +556,8 @@ -- ^ Generate an RSA key with specified size in /bytes/. | OctGenParam Int -- ^ Generate a symmetric key with specified size in /bytes/. + | OKPGenParam OKPCrv + -- ^ Generate an EdDSA or Edwards ECDH key with specified curve. deriving (Eq, Show) instance Arbitrary KeyMaterialGenParam where @@ -474,6 +565,7 @@ [ ECGenParam <$> arbitrary , RSAGenParam <$> elements ((`div` 8) <$> [2048, 3072, 4096]) , OctGenParam <$> liftA2 (+) arbitrarySizedNatural (elements [32, 48, 64]) + , OKPGenParam <$> arbitrary ] genKeyMaterial :: MonadRandom m => KeyMaterialGenParam -> m KeyMaterial @@ -484,11 +576,12 @@ (ECDSA.PublicKey _ p, ECDSA.PrivateKey _ d) <- ECC.generate (curve crv) case p of ECC.Point x y -> return $ ECKeyMaterial $ - ECKeyParameters EC crv (xyValue x) (xyValue y) (Just (dValue d)) + ECKeyParameters crv (xyValue x) (xyValue y) (Just (dValue d)) ECC.PointO -> genKeyMaterial (ECGenParam crv) -- JWK cannot represent point at infinity; recurse genKeyMaterial (RSAGenParam size) = RSAKeyMaterial <$> genRSA size genKeyMaterial (OctGenParam n) = - OctKeyMaterial . OctKeyParameters Oct . Types.Base64Octets <$> getRandomBytes n + OctKeyMaterial . OctKeyParameters . Types.Base64Octets <$> getRandomBytes n +genKeyMaterial (OKPGenParam crv) = OKPKeyMaterial <$> genOKP crv sign :: (MonadRandom m, MonadError e m, AsError e) @@ -509,55 +602,65 @@ sign JWA.JWS.HS256 (OctKeyMaterial k) = signOct SHA256 k sign JWA.JWS.HS384 (OctKeyMaterial k) = signOct SHA384 k sign JWA.JWS.HS512 (OctKeyMaterial k) = signOct SHA512 k +sign JWA.JWS.EdDSA (OKPKeyMaterial k) = signEdDSA k sign h k = \_ -> throwError (review _AlgorithmMismatch (show h <> "cannot be used with " <> showKeyType k <> " key")) verify - :: JWA.JWS.Alg + :: (MonadError e m, AsError e) + => JWA.JWS.Alg -> KeyMaterial -> B.ByteString -> B.ByteString - -> Either Error Bool -verify JWA.JWS.None _ = \_ s -> Right $ s == "" -verify JWA.JWS.ES256 (ECKeyMaterial k) = verifyEC SHA256 k -verify JWA.JWS.ES384 (ECKeyMaterial k) = verifyEC SHA384 k -verify JWA.JWS.ES512 (ECKeyMaterial k) = verifyEC SHA512 k -verify JWA.JWS.RS256 (RSAKeyMaterial k) = verifyPKCS15 SHA256 k -verify JWA.JWS.RS384 (RSAKeyMaterial k) = verifyPKCS15 SHA384 k -verify JWA.JWS.RS512 (RSAKeyMaterial k) = verifyPKCS15 SHA512 k -verify JWA.JWS.PS256 (RSAKeyMaterial k) = verifyPSS SHA256 k -verify JWA.JWS.PS384 (RSAKeyMaterial k) = verifyPSS SHA384 k -verify JWA.JWS.PS512 (RSAKeyMaterial k) = verifyPSS SHA512 k + -> 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.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 +verify JWA.JWS.PS256 (RSAKeyMaterial k) = fmap pure . verifyPSS SHA256 k +verify JWA.JWS.PS384 (RSAKeyMaterial k) = fmap pure . verifyPSS SHA384 k +verify JWA.JWS.PS512 (RSAKeyMaterial k) = fmap pure . verifyPSS SHA512 k verify JWA.JWS.HS256 (OctKeyMaterial k) = \m s -> BA.constEq s <$> signOct SHA256 k m verify JWA.JWS.HS384 (OctKeyMaterial k) = \m s -> BA.constEq s <$> signOct SHA384 k m verify JWA.JWS.HS512 (OctKeyMaterial k) = \m s -> BA.constEq s <$> signOct SHA512 k m -verify h k = \_ -> return $ Left $ AlgorithmMismatch - $ show h ++ "cannot be used with " ++ showKeyType k ++ " key" +verify JWA.JWS.EdDSA (OKPKeyMaterial k) = verifyEdDSA k +verify h k = \_ _ -> throwError $ review _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 - asPublicKey :: Prism' k k + -- | Get the public key + asPublicKey :: Getter k (Maybe k) -instance AsPublicKey OctKeyParameters where - asPublicKey = prism' id (const Nothing) - instance AsPublicKey RSAKeyParameters where - asPublicKey = prism' id (Just . set rsaPrivateKeyParameters Nothing) + asPublicKey = to (Just . set rsaPrivateKeyParameters Nothing) instance AsPublicKey ECKeyParameters where - asPublicKey = prism' id (\k -> Just k { ecD = Nothing }) + asPublicKey = to (\k -> Just k { ecD = Nothing }) +instance AsPublicKey OKPKeyParameters where + asPublicKey = to $ \case + Ed25519Key pk _ -> Just (Ed25519Key pk Nothing) + X25519Key pk _ -> Just (X25519Key pk Nothing) + instance AsPublicKey KeyMaterial where - asPublicKey = prism' id (\x -> case x of - OctKeyMaterial k -> OctKeyMaterial <$> k ^? asPublicKey - RSAKeyMaterial k -> RSAKeyMaterial <$> k ^? asPublicKey - ECKeyMaterial k -> ECKeyMaterial <$> k ^? asPublicKey + asPublicKey = to (\x -> case x of + OctKeyMaterial _ -> Nothing + RSAKeyMaterial k -> RSAKeyMaterial <$> view asPublicKey k + ECKeyMaterial k -> ECKeyMaterial <$> view asPublicKey k + OKPKeyMaterial k -> OKPKeyMaterial <$> view asPublicKey k ) diff --git a/src/Crypto/JOSE/JWA/JWS.hs b/src/Crypto/JOSE/JWA/JWS.hs --- a/src/Crypto/JOSE/JWA/JWS.hs +++ b/src/Crypto/JOSE/JWA/JWS.hs @@ -25,7 +25,7 @@ import qualified Crypto.JOSE.TH --- | JWA §3.1. "alg" (Algorithm) Header Parameters for JWS +-- | RFC 7518 §3.1. "alg" (Algorithm) Header Parameters Values for JWS -- $(Crypto.JOSE.TH.deriveJOSEType "Alg" [ "HS256" -- HMAC SHA ; REQUIRED @@ -41,4 +41,5 @@ , "PS384" -- RSASSA-PSS SHA ; OPTIONAL , "PS512" -- RSSSSA-PSS SHA ; OPTIONAL , "none" -- "none" No signature or MAC ; Optional + , "EdDSA" -- EdDSA (RFC 8037) ]) diff --git a/src/Crypto/JOSE/JWE.hs b/src/Crypto/JOSE/JWE.hs --- a/src/Crypto/JOSE/JWE.hs +++ b/src/Crypto/JOSE/JWE.hs @@ -29,6 +29,7 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) +import Control.Lens (view) import Data.Aeson import Data.Aeson.Types import qualified Data.ByteArray as BA @@ -64,26 +65,26 @@ deriving (Eq, Show) -data JWEHeader = JWEHeader +data JWEHeader p = JWEHeader { _jweAlg :: Maybe AlgWithParams - , _jweEnc :: HeaderParam Enc + , _jweEnc :: HeaderParam p Enc , _jweZip :: Maybe String -- protected header only "DEF" (DEFLATE) defined - , _jweJku :: Maybe (HeaderParam Types.URI) - , _jweJwk :: Maybe (HeaderParam JWK) - , _jweKid :: Maybe (HeaderParam String) - , _jweX5u :: Maybe (HeaderParam Types.URI) - , _jweX5c :: Maybe (HeaderParam (NonEmpty Types.Base64X509)) - , _jweX5t :: Maybe (HeaderParam Types.Base64SHA1) - , _jweX5tS256 :: Maybe (HeaderParam Types.Base64SHA256) - , _jweTyp :: Maybe (HeaderParam String) -- ^ Content Type (of object) - , _jweCty :: Maybe (HeaderParam String) -- ^ Content Type (of payload) + , _jweJku :: Maybe (HeaderParam p Types.URI) + , _jweJwk :: Maybe (HeaderParam p JWK) + , _jweKid :: Maybe (HeaderParam p String) + , _jweX5u :: Maybe (HeaderParam p Types.URI) + , _jweX5c :: Maybe (HeaderParam p (NonEmpty Types.Base64X509)) + , _jweX5t :: Maybe (HeaderParam p Types.Base64SHA1) + , _jweX5tS256 :: Maybe (HeaderParam p Types.Base64SHA256) + , _jweTyp :: Maybe (HeaderParam p String) -- ^ Content Type (of object) + , _jweCty :: Maybe (HeaderParam p String) -- ^ Content Type (of payload) , _jweCrit :: Maybe (NonEmpty T.Text) } deriving (Eq, Show) -newJWEHeader :: AlgWithParams -> Enc -> JWEHeader +newJWEHeader :: ProtectionIndicator p => AlgWithParams -> Enc -> JWEHeader p newJWEHeader alg enc = - JWEHeader (Just alg) (HeaderParam Unprotected enc) z z z z z z z z z z z + JWEHeader (Just alg) (HeaderParam getProtected enc) z z z z z z z z z z z where z = Nothing instance HasParams JWEHeader where @@ -106,32 +107,34 @@ params (JWEHeader alg enc zip' jku jwk kid x5u x5c x5t x5tS256 typ cty crit) = catMaybes [ undefined -- TODO - , Just (protection enc, "enc" .= param enc) - , fmap (\p -> (Protected, "zip" .= p)) zip' - , fmap (\p -> (protection p, "jku" .= param p)) jku - , fmap (\p -> (protection p, "jwk" .= param p)) jwk - , fmap (\p -> (protection p, "kid" .= param p)) kid - , fmap (\p -> (protection p, "x5u" .= param p)) x5u - , fmap (\p -> (protection p, "x5c" .= param p)) x5c - , fmap (\p -> (protection p, "x5t" .= param p)) x5t - , fmap (\p -> (protection p, "x5t#S256" .= param p)) x5tS256 - , fmap (\p -> (protection p, "typ" .= param p)) typ - , fmap (\p -> (protection p, "cty" .= param p)) cty - , fmap (\p -> (Protected, "crit" .= p)) crit + , 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, "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, "x5c" .= 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 + , fmap (\p -> (view isProtected p, "typ" .= view param p)) typ + , fmap (\p -> (view isProtected p, "cty" .= view param p)) cty + , fmap (\p -> (True, "crit" .= p)) crit ] -data JWERecipient a = JWERecipient - { _jweHeader :: a +data JWERecipient a p = JWERecipient + { _jweHeader :: a p , _jweEncryptedKey :: Maybe Types.Base64Octets -- ^ JWE Encrypted Key } -instance FromJSON (JWERecipient a) where +instance FromJSON (JWERecipient a p) where parseJSON = withObject "JWE Recipient" $ \o -> JWERecipient <$> undefined -- o .:? "header" <*> o .:? "encrypted_key" -parseRecipient :: HasParams a => Maybe Object -> Maybe Object -> Value -> Parser (JWERecipient a) +parseRecipient + :: (HasParams a, ProtectionIndicator p) + => Maybe Object -> Maybe Object -> Value -> Parser (JWERecipient a p) parseRecipient hp hu = withObject "JWE Recipient" $ \o -> do hr <- o .:? "header" JWERecipient @@ -140,16 +143,16 @@ -- parseParamsFor :: HasParams b => Proxy b -> Maybe Object -> Maybe Object -> Parser a -data JWE a = JWE +data JWE a p = JWE { _protectedRaw :: (Maybe T.Text) -- ^ Encoded protected header, if available , _jweIv :: Maybe Types.Base64Octets -- ^ JWE Initialization Vector , _jweAad :: Maybe Types.Base64Octets -- ^ JWE AAD , _jweCiphertext :: Types.Base64Octets -- ^ JWE Ciphertext , _jweTag :: Maybe Types.Base64Octets -- ^ JWE Authentication Tag - , _jweRecipients :: [JWERecipient a] + , _jweRecipients :: [JWERecipient a p] } -instance HasParams a => FromJSON (JWE a) where +instance (HasParams a, ProtectionIndicator p) => FromJSON (JWE a p) where parseJSON = withObject "JWE JSON Serialization" $ \o -> do hpB64 <- o .:? "protected" hp <- maybe @@ -182,11 +185,11 @@ wrap alg@RSA_OAEP_256 (RSAKeyMaterial k) m = bimap RSAError (alg,) <$> OAEP.encrypt (OAEP.OAEPParams SHA256 (mgf1 SHA256) Nothing) (rsaPublicKey k) m wrap RSA_OAEP_256 _ _ = return $ Left $ AlgorithmMismatch "Cannot use RSA_OAEP_256 with non-RSA key" -wrap A128KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m +wrap A128KW (OctKeyMaterial (OctKeyParameters (Types.Base64Octets k))) m = return $ (A128KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES128) m -wrap A192KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m +wrap A192KW (OctKeyMaterial (OctKeyParameters (Types.Base64Octets k))) m = return $ (A192KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES192) m -wrap A256KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m +wrap A256KW (OctKeyMaterial (OctKeyParameters (Types.Base64Octets k))) m = return $ (A256KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES256) m wrap (A128GCMKW _) k m = wrapAESGCM A128GCMKW A128GCM k m wrap (A192GCMKW _) k m = wrapAESGCM A192GCMKW A192GCM k m @@ -209,7 +212,7 @@ -> KeyMaterial -> B.ByteString -> m (Either Error (AlgWithParams, B.ByteString)) -wrapAESGCM f enc (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m = +wrapAESGCM f enc (OctKeyMaterial (OctKeyParameters (Types.Base64Octets k))) m = fmap (\(iv, tag, m') -> (f (AESGCMParameters (Types.Base64Octets iv) (Types.Base64Octets tag)), m')) <$> encrypt enc k m "" wrapAESGCM _ _ _ _ = return $ Left $ AlgorithmMismatch "Cannot use AESGCMKW with non-Oct key" diff --git a/src/Crypto/JOSE/JWK.hs b/src/Crypto/JOSE/JWK.hs --- a/src/Crypto/JOSE/JWK.hs +++ b/src/Crypto/JOSE/JWK.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale +-- Copyright (C) 2013, 2014, 2015, 2016, 2017 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,6 +12,9 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -24,29 +27,60 @@ defines a JSON Web Key Set (JWK Set) JSON data structure for representing a set of JWKs. +@ +-- Generate RSA JWK and set "kid" param to +-- base64url-encoded SHA-256 thumbprint of key. +-- +doGen :: IO JWK +doGen = do + jwk <- 'genJWK' (RSAGenParam (4096 \`div` 8)) + let + h = view 'thumbprint' jwk :: Digest SHA256 + kid = view (re ('base64url' . 'digest') . utf8) h + pure $ set 'jwkKid' (Just kid) jwk +@ + -} module Crypto.JOSE.JWK ( - JWK(JWK) + -- * JWK generation + genJWK + , KeyMaterialGenParam(..) + , Crv(..) + , OKPCrv(..) + , JWK + , AsPublicKey(..) + + -- * Parts of a JWK , jwkMaterial , jwkUse - , KeyUse(..) , jwkKeyOps + , KeyOp(..) , jwkAlg + , JWKAlg(..) , jwkKid , jwkX5u , jwkX5c , jwkX5t , jwkX5tS256 - , fromKeyMaterial - , genJWK + -- * Converting from other key formats + , fromKeyMaterial , fromRSA + , fromOctets - , JWKAlg(..) +#if MIN_VERSION_aeson(0,10,0) + -- * JWK Thumbprint + , thumbprint + , digest + , Types.base64url + , module Crypto.Hash +#endif + -- * JWK Set , JWKSet(..) + -- Miscellaneous , bestJWSAlg , module Crypto.JOSE.JWA.JWK @@ -54,13 +88,21 @@ import Control.Applicative 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(throwError)) +import Crypto.Hash import qualified Crypto.PubKey.RSA as RSA import Data.Aeson +import qualified Data.ByteArray as BA import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Builder as Builder import Data.List.NonEmpty +import qualified Data.Text as T import Test.QuickCheck @@ -91,7 +133,7 @@ toJSON (JWEAlg alg) = toJSON alg --- | JWK §3.3. "key_ops" (Key Operations) Parameter +-- | RFC 7517 §4.3. "key_ops" (Key Operations) Parameter -- $(Crypto.JOSE.TH.deriveJOSEType "KeyOp" [ "sign", "verify", "encrypt", "decrypt" @@ -99,12 +141,12 @@ ]) --- | JWK §3.2. "use" (Public Key Use) Parameter +-- | RFC 7517 §4.2. "use" (Public Key Use) Parameter -- $(Crypto.JOSE.TH.deriveJOSEType "KeyUse" ["sig", "enc"]) --- | JWK §3. JSON Web Key (JWK) Format +-- | RFC 7517 §4. JSON Web Key (JWK) Format -- data JWK = JWK { @@ -112,7 +154,7 @@ , _jwkUse :: Maybe KeyUse , _jwkKeyOps :: Maybe [KeyOp] , _jwkAlg :: Maybe JWKAlg - , _jwkKid :: Maybe String + , _jwkKid :: Maybe T.Text , _jwkX5u :: Maybe Types.URI , _jwkX5c :: Maybe (NonEmpty Types.Base64X509) , _jwkX5t :: Maybe Types.Base64SHA1 @@ -146,6 +188,8 @@ ] ++ Types.objectPairs (toJSON _jwkMaterial) +-- | Generate a JWK. Apart from key parameters, no other parameters are set. +-- genJWK :: MonadRandom m => KeyMaterialGenParam -> m JWK genJWK p = fromKeyMaterial <$> genKeyMaterial p @@ -170,12 +214,19 @@ fromRSA :: RSA.PrivateKey -> JWK fromRSA = fromKeyMaterial . RSAKeyMaterial . toRSAKeyParameters +-- | Convert octet string into a JWK +-- +fromOctets :: Cons s s Word8 Word8 => s -> JWK +fromOctets = + fromKeyMaterial . OctKeyMaterial . OctKeyParameters . Types.Base64Octets + . view recons + instance AsPublicKey JWK where - asPublicKey = prism' id (jwkMaterial (preview asPublicKey)) + asPublicKey = to (jwkMaterial (view asPublicKey)) --- | JWK §4. JSON Web Key Set (JWK Set) Format +-- | RFC 7517 §5. JWK Set Format -- newtype JWKSet = JWKSet [JWK] deriving (Eq, Show) @@ -197,9 +248,9 @@ P_521 -> JWA.JWS.ES512 RSAKeyMaterial k -> let - Types.SizedBase64Integer _ n = view rsaN k + Types.SizedBase64Integer size _ = view rsaN k in - if n >= 2 ^ (2040 :: Integer) + if size >= 2048 `div` 8 then pure JWA.JWS.PS512 else throwError (review _KeySizeTooSmall ()) OctKeyMaterial (OctKeyParameters { octK = Types.Base64Octets k }) @@ -207,3 +258,38 @@ | B.length k >= 384 `div` 8 -> pure JWA.JWS.HS384 | B.length k >= 256 `div` 8 -> pure JWA.JWS.HS256 | otherwise -> throwError (review _KeySizeTooSmall ()) + OKPKeyMaterial (Ed25519Key _ _) -> pure JWA.JWS.EdDSA + OKPKeyMaterial _ -> throwError (review _KeyMismatch "Cannot sign with OKP ECDH key") + + +#if MIN_VERSION_aeson(0,10,0) +-- | Compute the JWK Thumbprint of a JWK +-- +thumbprint :: HashAlgorithm a => Getter JWK (Digest a) +thumbprint = to (hash . L.toStrict . thumbprintRepr) + +-- | Prism from ByteString to @HashAlgorithm a => Digest a@. +-- +-- Use @'re' digest@ to view the bytes of a digest +-- +digest :: HashAlgorithm a => Prism' B.ByteString (Digest a) +digest = prism' BA.convert digestFromByteString + +-- | JWK canonicalised for thumbprint computation +-- +thumbprintRepr :: JWK -> L.ByteString +thumbprintRepr k = Builder.toLazyByteString . fromEncoding . pairs $ + case view jwkMaterial k of + ECKeyMaterial ECKeyParameters {..} -> + "crv" .= ecCrv <> "kty" .= ("EC" :: T.Text) <> "x" .= ecX <> "y" .= ecY + RSAKeyMaterial k' -> + "e" .= view rsaE k' <> "kty" .= ("RSA" :: T.Text) <> "n" .= view rsaN k' + OctKeyMaterial (OctKeyParameters k') -> + "k" .= k' <> "kty" .= ("oct" :: T.Text) + OKPKeyMaterial (Ed25519Key pk _) -> okpSeries "Ed25519" pk + OKPKeyMaterial (X25519Key pk _) -> okpSeries "X25519" pk + where + b64 = Types.Base64Octets . BA.convert + okpSeries crv pk = + "crv" .= (crv :: T.Text) <> "kty" .= ("OKP" :: T.Text) <> "x" .= b64 pk +#endif diff --git a/src/Crypto/JOSE/JWK/Store.hs b/src/Crypto/JOSE/JWK/Store.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/JOSE/JWK/Store.hs @@ -0,0 +1,52 @@ +-- Copyright (C) 2013, 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. + +{-# LANGUAGE RankNTypes #-} + +{-| + +A 'JWKStore' provides JWK enumeration and lookup. + +-} +module Crypto.JOSE.JWK.Store + ( + JWKStore(..) + ) where + + +import Control.Lens (Fold, folding) + +import Crypto.JOSE.Header +import Crypto.JOSE.JWK (JWK, JWKSet(..), KeyOp) + +class JWKStore a where + -- | Enumerate keys + keys :: Fold a JWK + + -- | Look up key by JWS/JWE header + keysFor + :: ( HasAlg h, HasJku h, HasJwk h, HasKid h + , HasX5u h, HasX5c h, HasX5t h, HasX5tS256 h + , HasTyp h, HasCty h ) + => KeyOp + -> h p + -> Fold a JWK + keysFor _ _ = keys + + +instance JWKStore JWK where + keys = id + +instance JWKStore JWKSet where + keys = folding (\(JWKSet xs) -> xs) diff --git a/src/Crypto/JOSE/JWS.hs b/src/Crypto/JOSE/JWS.hs --- a/src/Crypto/JOSE/JWS.hs +++ b/src/Crypto/JOSE/JWS.hs @@ -16,37 +16,593 @@ JSON Web Signature (JWS) represents content secured with digital signatures or Message Authentication Codes (MACs) using JavaScript -Object Notation (JSON) based data structures. +Object Notation (JSON) based data structures. It is defined in +. +@ +doJwsSign :: 'JWK' -> L.ByteString -> IO (Either 'Error' ('GeneralJWS' 'JWSHeader')) +doJwsSign jwk payload = runExceptT $ do + alg \<- 'bestJWSAlg' jwk + 'signJWS' payload [('newJWSHeader' ('Protected', alg), jwk)] + +doJwsVerify :: 'JWK' -> 'GeneralJWS' 'JWSHeader' -> IO (Either 'Error' ()) +doJwsVerify jwk jws = runExceptT $ 'verifyJWS'' jwk jws +@ + -} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Crypto.JOSE.JWS ( - Alg(..) - - , HasJWSHeader(..) - , JWSHeader(..) - , newJWSHeader + -- * Overview + JWS + , GeneralJWS + , FlattenedJWS + , CompactJWS - , Signature - , header + -- ** Defining additional header parameters + -- $extending - , JWS(..) - , newJWS - , jwsPayload + -- * JWS creation + , newJWSHeader , signJWS + -- * JWS verification + , verifyJWS + , verifyJWS' + + -- ** JWS validation settings + , defaultValidationSettings + , ValidationSettings + , ValidationPolicy(..) , HasValidationSettings(..) , HasAlgorithms(..) , HasValidationPolicy(..) - , ValidationPolicy(..) - , ValidationSettings - , defaultValidationSettings - , verifyJWS + -- * Signature data + , signatures + , Signature + , header + , signature + -- * JWS headers + , Alg(..) + , HasJWSHeader(..) + , JWSHeader + + , module Crypto.JOSE.Error , module Crypto.JOSE.Header + , module Crypto.JOSE.JWK ) where +import Control.Applicative ((<|>)) +import Data.Foldable (toList) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.List.NonEmpty (NonEmpty) +import Data.Traversable (traverse) +import Data.Word (Word8) + +import Control.Lens hiding ((.=)) +import Control.Lens.Cons.Extras (recons) +import Control.Monad.Except (MonadError(throwError)) +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Crypto.JOSE.Compact +import Crypto.JOSE.Error import Crypto.JOSE.JWA.JWS -import Crypto.JOSE.JWS.Internal +import Crypto.JOSE.JWK +import Crypto.JOSE.JWK.Store import Crypto.JOSE.Header +import qualified Crypto.JOSE.Types as Types +import qualified Crypto.JOSE.Types.Internal as Types + +{- $extending + +Several specifications extend JWS with additional header parameters. +The 'JWS' type is parameterised over the header type; this library +provides the 'JWSHeader' type which encompasses all the JWS header +parameters defined in RFC 7515. To define an extended header type +declare the data type, and instances for 'HasJWSHeader' and +'HasParams'. For example: + +@ +data ACMEHeader p = ACMEHeader + { _acmeJwsHeader :: 'JWSHeader' p + , _acmeNonce :: 'Types.Base64Octets' + } + +acmeJwsHeader :: Lens' (ACMEHeader p) (JWSHeader p) +acmeJwsHeader f s\@(ACMEHeader { _acmeJwsHeader = a}) = + fmap (\\a' -> s { _acmeJwsHeader = a'}) (f a) + +acmeNonce :: Lens' (ACMEHeader p) Types.Base64Octets +acmeNonce f s\@(ACMEHeader { _acmeNonce = a}) = + fmap (\\a' -> s { _acmeNonce = a'}) (f a) + +instance HasJWSHeader ACMEHeader where + jwsHeader = acmeJwsHeader + +instance HasParams ACMEHeader where + 'parseParamsFor' proxy hp hu = ACMEHeader + \<$> 'parseParamsFor' proxy hp hu + \<*> 'headerRequiredProtected' "nonce" hp hu + params h = + (True, "nonce" .= view acmeNonce h) + : 'params' (view acmeJwsHeader h) + 'extensions' = const ["nonce"] +@ + +See also: + +- 'HasParams' +- 'headerRequired' +- 'headerRequiredProtected' +- 'headerOptional' +- 'headerOptionalProtected' + +-} + + +jwsCritInvalidNames :: [T.Text] +jwsCritInvalidNames = [ + "alg" + , "jku" + , "jwk" + , "x5u" + , "x5t" + , "x5t#S256" + , "x5c" + , "kid" + , "typ" + , "cty" + , "crit" + ] + +-- | JWS Header data type. +-- +data JWSHeader p = JWSHeader + { _jwsHeaderAlg :: HeaderParam p Alg + , _jwsHeaderJku :: Maybe (HeaderParam p Types.URI) -- ^ JWK Set URL + , _jwsHeaderJwk :: Maybe (HeaderParam p JWK) + , _jwsHeaderKid :: Maybe (HeaderParam p String) -- ^ interpretation unspecified + , _jwsHeaderX5u :: Maybe (HeaderParam p Types.URI) + , _jwsHeaderX5c :: Maybe (HeaderParam p (NonEmpty Types.Base64X509)) + , _jwsHeaderX5t :: Maybe (HeaderParam p Types.Base64SHA1) + , _jwsHeaderX5tS256 :: Maybe (HeaderParam p Types.Base64SHA256) + , _jwsHeaderTyp :: Maybe (HeaderParam p String) -- ^ Content Type (of object) + , _jwsHeaderCty :: Maybe (HeaderParam p String) -- ^ Content Type (of payload) + , _jwsHeaderCrit :: Maybe (NonEmpty T.Text) + } + deriving (Eq, Show) + +instance HasAlg JWSHeader where + alg f h@(JWSHeader { _jwsHeaderAlg = a }) = + fmap (\a' -> h { _jwsHeaderAlg = a' }) (f a) +instance HasJku JWSHeader where + jku f h@(JWSHeader { _jwsHeaderJku = a }) = + fmap (\a' -> h { _jwsHeaderJku = a' }) (f a) +instance HasJwk JWSHeader where + jwk f h@(JWSHeader { _jwsHeaderJwk = a }) = + fmap (\a' -> h { _jwsHeaderJwk = a' }) (f a) +instance HasKid JWSHeader where + kid f h@(JWSHeader { _jwsHeaderKid = a }) = + fmap (\a' -> h { _jwsHeaderKid = a' }) (f a) +instance HasX5u JWSHeader where + x5u f h@(JWSHeader { _jwsHeaderX5u = a }) = + fmap (\a' -> h { _jwsHeaderX5u = a' }) (f a) +instance HasX5c JWSHeader where + x5c f h@(JWSHeader { _jwsHeaderX5c = a }) = + fmap (\a' -> h { _jwsHeaderX5c = a' }) (f a) +instance HasX5t JWSHeader where + x5t f h@(JWSHeader { _jwsHeaderX5t = a }) = + fmap (\a' -> h { _jwsHeaderX5t = a' }) (f a) +instance HasX5tS256 JWSHeader where + x5tS256 f h@(JWSHeader { _jwsHeaderX5tS256 = a }) = + fmap (\a' -> h { _jwsHeaderX5tS256 = a' }) (f a) +instance HasTyp JWSHeader where + typ f h@(JWSHeader { _jwsHeaderTyp = a }) = + fmap (\a' -> h { _jwsHeaderTyp = a' }) (f a) +instance HasCty JWSHeader where + cty f h@(JWSHeader { _jwsHeaderCty = a }) = + fmap (\a' -> h { _jwsHeaderCty = a' }) (f a) +instance HasCrit JWSHeader where + crit f h@(JWSHeader { _jwsHeaderCrit = a }) = + fmap (\a' -> h { _jwsHeaderCrit = a' }) (f a) + +class HasJWSHeader a where + jwsHeader :: Lens' (a p) (JWSHeader p) + +instance HasJWSHeader JWSHeader where + jwsHeader = id + +instance {-# INCOHERENT #-} HasJWSHeader a => HasAlg a where + alg = jwsHeader . alg +instance {-# INCOHERENT #-} HasJWSHeader a => HasJku a where + jku = jwsHeader . jku +instance {-# INCOHERENT #-} HasJWSHeader a => HasJwk a where + jwk = jwsHeader . jwk +instance {-# INCOHERENT #-} HasJWSHeader a => HasKid a where + kid = jwsHeader . kid +instance {-# INCOHERENT #-} HasJWSHeader a => HasX5u a where + x5u = jwsHeader . x5u +instance {-# INCOHERENT #-} HasJWSHeader a => HasX5c a where + x5c = jwsHeader . x5c +instance {-# INCOHERENT #-} HasJWSHeader a => HasX5t a where + x5t = jwsHeader . x5t +instance {-# INCOHERENT #-} HasJWSHeader a => HasX5tS256 a where + x5tS256 = jwsHeader . x5tS256 +instance {-# INCOHERENT #-} HasJWSHeader a => HasTyp a where + typ = jwsHeader . typ +instance {-# INCOHERENT #-} HasJWSHeader a => HasCty a where + cty = jwsHeader . cty +instance {-# INCOHERENT #-} HasJWSHeader a => HasCrit a where + crit = jwsHeader . crit + + +-- | Construct a minimal header with the given algorithm and +-- protection indicator 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 + + +-- | Signature object containing header, and signature bytes. +-- +-- If it was decoded from a serialised JWS, it "remembers" how the +-- protected header was encoded; the remembered value is used when +-- computing the signing input and when serialising the object. +-- +-- The remembered value is not used in equality checks, i.e. two +-- decoded signatures with differently serialised by otherwise equal +-- protected headers, and equal signature bytes, are equal. +-- +data Signature p a = Signature + (Maybe T.Text) -- Encoded protected header, if available + (a p) -- Header + Types.Base64Octets -- Signature + deriving (Show) + +-- | Getter for header of a signature +header :: Getter (Signature p a) (a p) +header = to (\(Signature _ h _) -> h) + +-- | Getter for signature bytes +signature :: (Cons s s Word8 Word8, AsEmpty s) => Getter (Signature p a) s +signature = to (\(Signature _ _ (Types.Base64Octets s)) -> s) . recons + +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 + parseJSON = withObject "signature" (\o -> Signature + <$> (Just <$> (o .: "protected" <|> pure "")) -- raw protected header + <*> do + hpB64 <- o .:? "protected" + hp <- maybe + (pure Nothing) + (withText "base64url-encoded header params" + (Types.parseB64Url (maybe + (fail "protected header contains invalid JSON") + pure . decode . view recons))) + hpB64 + hu <- o .:? "header" + parseParams hp hu + <*> o .: "signature" + ) + +instance (HasParams a, ProtectionIndicator p) => ToJSON (Signature p a) where + toJSON (Signature _ h sig) = + let + pro = case protectedParamsEncoded h of + "" -> id + bs -> ("protected" .= String (T.decodeUtf8 (view recons bs)) :) + unp = case unprotectedParams h of + Nothing -> id + Just o -> ("header" .= o :) + in + object $ (pro . unp) [("signature" .= sig)] + + +instance HasParams JWSHeader where + parseParamsFor proxy hp hu = JWSHeader + <$> headerRequired "alg" hp hu + <*> headerOptional "jku" hp hu + <*> headerOptional "jwk" hp hu + <*> headerOptional "kid" hp hu + <*> headerOptional "x5u" hp hu + <*> headerOptional "x5t" hp hu + <*> headerOptional "x5t#S256" hp hu + <*> headerOptional "x5c" hp hu + <*> headerOptional "typ" hp hu + <*> headerOptional "cty" hp hu + <*> (headerOptionalProtected "crit" hp hu + >>= parseCrit jwsCritInvalidNames (extensions proxy) + (fromMaybe mempty hp <> fromMaybe mempty hu)) + 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, "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, "x5c" .= 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) + , fmap (\p -> (view isProtected p, "typ" .= view param p)) (view typ h) + , fmap (\p -> (view isProtected p, "cty" .= view param p)) (view cty h) + , fmap (\p -> (True, "crit" .= p)) (view crit h) + ] + + +-- | JSON Web Signature data type. The payload can only be +-- accessed by verifying the JWS. +-- +-- Parameterised by the signature container type, the header +-- 'ProtectionIndicator' 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 +-- /flattened JWS JSON serialisation/ syntax is used, otherwise +-- the /general JWS JSON serialisation/ is used. +-- When decoding a @'JWS' []@ either serialisation is accepted. +-- +-- @'JWS' 'Identity'@ uses the flattened JSON serialisation +-- or the /JWS compact serialisation/ (see 'decodeCompact' and +-- 'encodeCompact'). +-- +-- Use 'signJWS' to create a signed/MACed JWS. +-- +-- Use 'verifyJWS' to verify a JWS and extract 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 + +-- | A JWS with one signature, which uses the +-- /flattened serialisation/. Headers may be 'Protected' +-- or 'Unprotected'. +-- +type FlattenedJWS = JWS Identity Protection + +-- | A JWS with one signature which only allows protected +-- parameters. Can use the /flattened serialisation/ or +-- the /compact serialisation/. +-- +type CompactJWS = JWS Identity () + +instance (Eq (t (Signature p a))) => Eq (JWS t p a) where + JWS p sigs == JWS p' sigs' = p == p' && sigs == sigs' + +instance (Show (t (Signature p a))) => Show (JWS t p a) where + show (JWS p sigs) = "JWS " <> show p <> " " <> show sigs + +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 + 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 + 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 + toJSON (JWS p [s]) = object $ "payload" .= p : Types.objectPairs (toJSON s) + toJSON (JWS p ss) = object ["payload" .= p, "signatures" .= ss] + +instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS Identity p a) where + toJSON (JWS p (Identity s)) = object $ "payload" .= p : Types.objectPairs (toJSON s) + + +signingInput + :: (HasParams a, ProtectionIndicator p) + => Either T.Text (a p) + -> B.ByteString + -> B.ByteString +signingInput h p = B.intercalate "." + [ either T.encodeUtf8 (view recons . protectedParamsEncoded) h + , review Types.base64url p + ] + +-- Convert JWS to compact serialization. +-- +-- The operation is defined only when there is exactly one +-- signature and returns Nothing otherwise +-- +instance HasParams a => ToCompact (JWS Identity () a) where + toCompact (JWS (Types.Base64Octets p) (Identity (Signature raw h (Types.Base64Octets sig)))) = + [ view recons $ signingInput (maybe (Right h) Left raw) p + , review Types.base64url sig + ] + +instance HasParams a => FromCompact (JWS Identity () a) where + fromCompact xs = case xs of + [h, p, s] -> do + (h', p', s') <- (,,) <$> t h <*> t p <*> t s + let o = object [ ("payload", p'), ("protected", h'), ("signature", s') ] + case fromJSON o of + Error e -> throwError (compactErr e) + Success a -> pure a + xs' -> throwError $ compactErr $ "expected 3 parts, got " ++ show (length xs') + where + compactErr = review _CompactDecodeError + t = either (throwError . compactErr . show) (pure . String) + . T.decodeUtf8' . view recons + + +-- | Create a signed or MACed JWS with the given payload by +-- traversing a collection of @(header, key)@ pairs. +-- +signJWS + :: ( Cons s s Word8 Word8 + , HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m + , Traversable t + , ProtectionIndicator p + ) + => s -- ^ Payload + -> t ((a p), JWK) -- ^ Traversable of header, key pairs + -> m (JWS t p a) +signJWS s = + let s' = view recons s + in fmap (JWS (Types.Base64Octets s')) . traverse (uncurry (mkSignature s')) + +mkSignature + :: ( HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m + , ProtectionIndicator p + ) + => B.ByteString -> a p -> JWK -> m (Signature p a) +mkSignature p h k = + Signature Nothing h . Types.Base64Octets + <$> sign (view (alg . param) h) (k ^. jwkMaterial) (signingInput (Right h) p) + + +-- | Validation policy. +-- +data ValidationPolicy + = AnyValidated + -- ^ One successfully validated signature is sufficient + | AllValidated + -- ^ All signatures in all configured algorithms must be validated. + -- No signatures in configured algorithms is also an error. + deriving (Eq) + +-- | Validation settings: +-- +-- * The set of acceptable signature algorithms +-- * The validation policy +-- +data ValidationSettings = ValidationSettings + (S.Set Alg) + ValidationPolicy + +class HasValidationSettings a where + validationSettings :: Lens' a ValidationSettings + + validationSettingsAlgorithms :: Lens' a (S.Set Alg) + validationSettingsAlgorithms = validationSettings . go where + go f (ValidationSettings algs pol) = + (\algs' -> ValidationSettings algs' pol) <$> f algs + + validationSettingsValidationPolicy :: Lens' a ValidationPolicy + validationSettingsValidationPolicy = validationSettings . go where + go f (ValidationSettings algs pol) = + (\pol' -> ValidationSettings algs pol') <$> f pol + +instance HasValidationSettings ValidationSettings where + validationSettings = id + +class HasAlgorithms s where + algorithms :: Lens' s (S.Set Alg) +class HasValidationPolicy s where + validationPolicy :: Lens' s ValidationPolicy + +instance HasValidationSettings a => HasAlgorithms a where + algorithms = validationSettingsAlgorithms +instance HasValidationSettings a => HasValidationPolicy a where + validationPolicy = validationSettingsValidationPolicy + +-- | The default validation settings. +-- +-- - All algorithms except "none" are acceptable. +-- - All signatures must be valid (and there must be at least one signature.) +-- +defaultValidationSettings :: ValidationSettings +defaultValidationSettings = ValidationSettings + ( S.fromList + [ HS256, HS384, HS512 + , RS256, RS384, RS512 + , ES256, ES384, ES512 + , PS256, PS384, PS512 + , EdDSA + ] ) + AllValidated + +-- | Verify a JWS with the default validation settings. +-- +-- See also 'defaultValidationSettings'. +-- +verifyJWS' + :: ( AsError e, MonadError e m , HasJWSHeader h, HasParams h , JWKStore k + , Cons s s Word8 Word8, AsEmpty s + , Foldable t + , ProtectionIndicator p + ) + => k -- ^ key or key store + -> JWS t p h -- ^ JWS + -> m s +verifyJWS' = verifyJWS defaultValidationSettings + +-- | Verify a JWS. +-- +-- Signatures made with an unsupported algorithms are ignored. +-- If the validation policy is 'AnyValidated', a single successfully +-- validated signature is sufficient. If the validation policy is +-- 'AllValidated' then all remaining signatures (there must be at least one) +-- must be valid. +-- +-- Returns the payload if successfully verified. +-- +verifyJWS + :: ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m + , HasJWSHeader h, HasParams h + , JWKStore k + , Cons s s Word8 Word8, AsEmpty s + , Foldable t + , ProtectionIndicator p + ) + => a -- ^ validation settings + -> k -- ^ key or key store + -> JWS t p h -- ^ JWS + -> m s +verifyJWS conf k (JWS p@(Types.Base64Octets p') sigs) = + let + algs :: S.Set Alg + algs = conf ^. algorithms + policy :: ValidationPolicy + policy = conf ^. validationPolicy + shouldValidateSig = (`elem` algs) . view (header . alg . param) + out = view recons p' + applyPolicy AnyValidated xs = + if or xs then pure out else throwError (review _JWSNoValidSignatures ()) + applyPolicy AllValidated [] = throwError (review _JWSNoSignatures ()) + applyPolicy AllValidated xs = + if and xs then pure out else throwError (review _JWSInvalidSignature ()) + validate s = + let h = view header s + in anyOf (keysFor Verify h) ((== Right True) . verifySig p s) k + in + applyPolicy policy $ map validate $ filter shouldValidateSig $ toList sigs + +verifySig + :: (HasJWSHeader a, HasParams a, ProtectionIndicator p) + => Types.Base64Octets + -> Signature p a + -> JWK + -> Either Error Bool +verifySig (Types.Base64Octets m) (Signature raw h (Types.Base64Octets s)) k = + verify (view (alg . param) h) (view jwkMaterial k) tbs s + where + tbs = signingInput (maybe (Right h) Left raw) m diff --git a/src/Crypto/JOSE/JWS/Internal.hs b/src/Crypto/JOSE/JWS/Internal.hs deleted file mode 100644 --- a/src/Crypto/JOSE/JWS/Internal.hs +++ /dev/null @@ -1,332 +0,0 @@ --- Copyright (C) 2013, 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. - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_HADDOCK hide #-} - -module Crypto.JOSE.JWS.Internal where - -import Control.Applicative ((<|>)) -import Data.Foldable (toList) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) - -import Control.Lens hiding ((.=)) -import Control.Monad.Except (MonadError(throwError)) -import Data.Aeson -import Data.Byteable -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.HashMap.Strict as M -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import Crypto.JOSE.Compact -import Crypto.JOSE.Error -import qualified Crypto.JOSE.JWA.JWS as JWA.JWS -import Crypto.JOSE.JWK -import Crypto.JOSE.Header -import qualified Crypto.JOSE.Types as Types -import qualified Crypto.JOSE.Types.Internal as Types - - -jwsCritInvalidNames :: [T.Text] -jwsCritInvalidNames = [ - "alg" - , "jku" - , "jwk" - , "x5u" - , "x5t" - , "x5t#S256" - , "x5c" - , "kid" - , "typ" - , "cty" - , "crit" - ] - --- | JWS Header data type. --- -data JWSHeader = JWSHeader - { _jwsHeaderAlg :: HeaderParam JWA.JWS.Alg - , _jwsHeaderJku :: Maybe (HeaderParam Types.URI) -- ^ JWK Set URL - , _jwsHeaderJwk :: Maybe (HeaderParam JWK) - , _jwsHeaderKid :: Maybe (HeaderParam String) -- ^ interpretation unspecified - , _jwsHeaderX5u :: Maybe (HeaderParam Types.URI) - , _jwsHeaderX5c :: Maybe (HeaderParam (NonEmpty Types.Base64X509)) - , _jwsHeaderX5t :: Maybe (HeaderParam Types.Base64SHA1) - , _jwsHeaderX5tS256 :: Maybe (HeaderParam Types.Base64SHA256) - , _jwsHeaderTyp :: Maybe (HeaderParam String) -- ^ Content Type (of object) - , _jwsHeaderCty :: Maybe (HeaderParam String) -- ^ Content Type (of payload) - , _jwsHeaderCrit :: Maybe (NonEmpty T.Text) - } - deriving (Eq, Show) -makeClassy ''JWSHeader - --- | Construct a minimal header with the given algorithm --- -newJWSHeader :: (Protection, JWA.JWS.Alg) -> JWSHeader -newJWSHeader alg = JWSHeader (uncurry HeaderParam alg) z z z z z z z z z z - where z = Nothing - - -data Signature a = Signature - { _protectedRaw :: (Maybe T.Text) -- ^ Encoded protected header, if available - , _header :: a -- ^ Header - , _signature :: Types.Base64Octets -- ^ Signature - } - deriving (Show) -makeLenses ''Signature - -instance (Eq a, HasParams a) => Eq (Signature a) where - Signature r h s == Signature r' h' s' = - h == h' && s == s' && f r r' - where - f Nothing Nothing = True - f (Just t) (Just t') = t == t' - f Nothing (Just t') = BSL.toStrict (protectedParamsEncoded h) == T.encodeUtf8 t' - f (Just t) Nothing = T.encodeUtf8 t == BSL.toStrict (protectedParamsEncoded h') - -instance HasParams a => FromJSON (Signature a) where - parseJSON = withObject "signature" (\o -> Signature - <$> (Just <$> (o .: "protected" <|> pure "")) -- raw protected header - <*> do - hpB64 <- o .:? "protected" - hp <- maybe - (pure Nothing) - (withText "base64url-encoded header params" - (Types.parseB64Url (maybe - (fail "protected header contains invalid JSON") - pure . decode . BSL.fromStrict))) - hpB64 - hu <- o .:? "header" - parseParams hp hu - <*> o .: "signature" - ) - -instance HasParams a => ToJSON (Signature a) where - toJSON (Signature _ h sig) = - let - pro = case protectedParamsEncoded h of - "" -> id - bs -> ("protected" .= String (T.decodeUtf8 (BSL.toStrict bs)) :) - unp = case unprotectedParams h of - Nothing -> id - Just o -> ("header" .= o :) - in - object $ (pro . unp) [("signature" .= sig)] - - -instance HasParams JWSHeader where - parseParamsFor proxy hp hu = JWSHeader - <$> headerRequired "alg" hp hu - <*> headerOptional "jku" hp hu - <*> headerOptional "jwk" hp hu - <*> headerOptional "kid" hp hu - <*> headerOptional "x5u" hp hu - <*> headerOptional "x5t" hp hu - <*> headerOptional "x5t#S256" hp hu - <*> headerOptional "x5c" hp hu - <*> headerOptional "typ" hp hu - <*> headerOptional "cty" hp hu - <*> (headerOptionalProtected "crit" hp hu - >>= parseCrit jwsCritInvalidNames (extensions proxy) - (fromMaybe mempty hp <> fromMaybe mempty hu)) - params (JWSHeader alg jku jwk kid x5u x5c x5t x5tS256 typ cty crit) = - catMaybes - [ Just (protection alg, "alg" .= param alg) - , fmap (\p -> (protection p, "jku" .= param p)) jku - , fmap (\p -> (protection p, "jwk" .= param p)) jwk - , fmap (\p -> (protection p, "kid" .= param p)) kid - , fmap (\p -> (protection p, "x5u" .= param p)) x5u - , fmap (\p -> (protection p, "x5c" .= param p)) x5c - , fmap (\p -> (protection p, "x5t" .= param p)) x5t - , fmap (\p -> (protection p, "x5t#S256" .= param p)) x5tS256 - , fmap (\p -> (protection p, "typ" .= param p)) typ - , fmap (\p -> (protection p, "cty" .= param p)) cty - , fmap (\p -> (Protected, "crit" .= p)) crit - ] - - --- | JSON Web Signature data type. Consists of a payload and a --- (possibly empty) list of signatures. --- --- Parameterised by the header type. --- -data JWS a = JWS Types.Base64Octets [Signature a] - deriving (Eq, Show) - -instance HasParams a => FromJSON (JWS a) where - parseJSON v = - withObject "JWS JSON serialization" (\o -> JWS - <$> o .: "payload" - <*> o .: "signatures") v - <|> withObject "Flattened JWS JSON serialization" (\o -> - if M.member "signatures" o - then fail "\"signatures\" member MUST NOT be present" - else (\p s -> JWS p [s]) <$> o .: "payload" <*> parseJSON v) v - -instance HasParams a => ToJSON (JWS a) where - toJSON (JWS p ss) = object ["payload" .= p, "signatures" .= ss] - --- | Construct a new (unsigned) JWS --- -newJWS :: BS.ByteString -> JWS a -newJWS msg = JWS (Types.Base64Octets msg) [] - --- | Payload of a JWS, as a lazy bytestring. --- -jwsPayload :: JWS a -> BSL.ByteString -jwsPayload (JWS (Types.Base64Octets s) _) = BSL.fromStrict s - -signingInput - :: HasParams a - => Either T.Text a - -> Types.Base64Octets - -> BS.ByteString -signingInput h p = BS.intercalate "." - [ either T.encodeUtf8 (BSL.toStrict . protectedParamsEncoded) h - , toBytes p - ] - --- Convert JWS to compact serialization. --- --- The operation is defined only when there is exactly one --- signature and returns Nothing otherwise --- -instance HasParams a => ToCompact (JWS a) where - toCompact (JWS p [Signature raw h sig]) = - case unprotectedParams h of - Nothing -> pure - [ BSL.fromStrict $ signingInput (maybe (Right h) Left raw) p - , BSL.fromStrict $ toBytes sig - ] - Just _ -> throwError $ review _CompactEncodeError $ - "cannot encode a compact JWS with unprotected headers" - toCompact (JWS _ sigs) = throwError $ review _CompactEncodeError $ - "cannot compact serialize JWS with " ++ show (length sigs) ++ " sigs" - -instance HasParams a => FromCompact (JWS a) where - fromCompact xs = case xs of - [h, p, s] -> do - (h', p', s') <- (,,) <$> t h <*> t p <*> t s - let o = object [ ("payload", p'), ("protected", h'), ("signature", s') ] - case fromJSON o of - Error e -> throwError (compactErr e) - Success a -> pure a - xs' -> throwError $ compactErr $ "expected 3 parts, got " ++ show (length xs') - where - compactErr = review _CompactDecodeError - t = either (throwError . compactErr . show) (pure . String) - . T.decodeUtf8' . BSL.toStrict - - --- §5.1. Message Signing or MACing - --- | Create a new signature on a JWS. --- -signJWS - :: (HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m) - => JWS a -- ^ JWS to sign - -> a -- ^ Header for signature - -> JWK -- ^ Key with which to sign - -> m (JWS a) -- ^ JWS with new signature appended -signJWS (JWS p sigs) h k = - (\sig -> JWS p (Signature Nothing h (Types.Base64Octets sig):sigs)) - <$> sign (param (view jwsHeaderAlg h)) (k ^. jwkMaterial) (signingInput (Right h) p) - - --- | Validation policy. --- -data ValidationPolicy - = AnyValidated - -- ^ One successfully validated signature is sufficient - | AllValidated - -- ^ All signatures in all configured algorithms must be validated. - -- No signatures in configured algorithms is also an error. - deriving (Eq) - -data ValidationSettings = ValidationSettings - { _validationSettingsAlgorithms :: S.Set JWA.JWS.Alg - , _validationSettingsValidationPolicy :: ValidationPolicy - } -makeClassy ''ValidationSettings - -class HasAlgorithms s where - algorithms :: Lens' s (S.Set JWA.JWS.Alg) -class HasValidationPolicy s where - validationPolicy :: Lens' s ValidationPolicy - -instance HasValidationSettings a => HasAlgorithms a where - algorithms = validationSettingsAlgorithms -instance HasValidationSettings a => HasValidationPolicy a where - validationPolicy = validationSettingsValidationPolicy - -defaultValidationSettings :: ValidationSettings -defaultValidationSettings = ValidationSettings - ( S.fromList - [ JWA.JWS.HS256, JWA.JWS.HS384, JWA.JWS.HS512 - , JWA.JWS.RS256, JWA.JWS.RS384, JWA.JWS.RS512 - , JWA.JWS.ES256, JWA.JWS.ES384, JWA.JWS.ES512 - , JWA.JWS.PS256, JWA.JWS.PS384, JWA.JWS.PS512 - ] ) - AllValidated - - --- | Verify a JWS. --- --- Signatures made with an unsupported algorithms are ignored. --- If the validation policy is 'AnyValidated', a single successfully --- validated signature is sufficient. If the validation policy is --- 'AllValidated' then all remaining signatures (there must be at least one) --- must be valid. --- -verifyJWS - :: ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m - , HasJWSHeader h, HasParams h) - => a - -> JWK - -> JWS h - -> m () -verifyJWS conf k (JWS p sigs) = - let - algs :: S.Set JWA.JWS.Alg - algs = conf ^. algorithms - policy :: ValidationPolicy - policy = conf ^. validationPolicy - shouldValidateSig = (`elem` algs) . param . view (header . jwsHeaderAlg) - applyPolicy AnyValidated xs = - if or xs then pure () else throwError (review _JWSNoValidSignatures ()) - applyPolicy AllValidated [] = throwError (review _JWSNoSignatures ()) - applyPolicy AllValidated xs = - if and xs then pure () else throwError (review _JWSInvalidSignature ()) - validate = (== Right True) . verifySig k p - in - applyPolicy policy $ map validate $ filter shouldValidateSig $ toList sigs - -verifySig - :: (HasJWSHeader a, HasParams a) - => JWK - -> Types.Base64Octets - -> Signature a - -> Either Error Bool -verifySig k m (Signature raw h (Types.Base64Octets s)) = - verify (param (view jwsHeaderAlg h)) (view jwkMaterial k) tbs s - where - tbs = signingInput (maybe (Right h) Left raw) m diff --git a/src/Crypto/JOSE/Legacy.hs b/src/Crypto/JOSE/Legacy.hs deleted file mode 100644 --- a/src/Crypto/JOSE/Legacy.hs +++ /dev/null @@ -1,117 +0,0 @@ --- Copyright (C) 2013, 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. - -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{-| - -Types to deal with the legacy JSON Web Key formats used with -Mozilla Persona. - --} -module Crypto.JOSE.Legacy - ( - JWK'(..) - , genJWK' - , toJWK - , RSKeyParameters() - ) where - -import Control.Lens hiding ((.=)) -import Crypto.Number.Basic (log2) -import Data.Aeson -import Data.Aeson.Types -import qualified Data.Text as T -import Safe (readMay) - -import Crypto.JOSE.JWA.JWK -import Crypto.JOSE.JWK -import qualified Crypto.JOSE.Types.Internal as Types -import Crypto.JOSE.Types -import Crypto.JOSE.TH - - -newtype StringifiedInteger = StringifiedInteger Integer -makePrisms ''StringifiedInteger - -instance FromJSON StringifiedInteger where - parseJSON = withText "StringifiedInteger" $ - maybe (fail "not an stringy integer") (pure . StringifiedInteger) - . readMay - . T.unpack - -instance ToJSON StringifiedInteger where - toJSON (StringifiedInteger n) = toJSON $ show n - -b64Iso :: Iso' StringifiedInteger Base64Integer -b64Iso = _StringifiedInteger . from _Base64Integer - -sizedB64Iso :: Iso' StringifiedInteger SizedBase64Integer -sizedB64Iso = iso - ((\n -> SizedBase64Integer (size n) n) . view _StringifiedInteger) - (\(SizedBase64Integer _ n) -> StringifiedInteger n) - where - size n = - let (bytes, bits) = (log2 n + 1) `divMod` 8 - in bytes + signum bits - - -$(Crypto.JOSE.TH.deriveJOSEType "RS" ["RS"]) - - -newtype RSKeyParameters = RSKeyParameters RSAKeyParameters - deriving (Eq, Show) -makePrisms ''RSKeyParameters - -instance FromJSON RSKeyParameters where - parseJSON = withObject "RS" $ \o -> fmap RSKeyParameters $ RSAKeyParameters - <$> ((o .: "algorithm" :: Parser RS) *> pure RSA) - <*> (view sizedB64Iso <$> o .: "n") - <*> (view b64Iso <$> o .: "e") - <*> (fmap ((`RSAPrivateKeyParameters` Nothing) . view b64Iso) <$> (o .:? "d")) - -instance ToJSON RSKeyParameters where - toJSON (RSKeyParameters k) - = object $ - [ "algorithm" .= RS - , "n" .= (k ^. rsaN . from sizedB64Iso) - , "e" .= (k ^. rsaE . from b64Iso) - ] - ++ maybe [] (\p -> ["d" .= (rsaD p ^. from b64Iso)]) - (k ^. rsaPrivateKeyParameters) - - --- | Legacy JSON Web Key data type. --- -newtype JWK' = JWK' RSKeyParameters - deriving (Eq, Show) -makePrisms ''JWK' - -instance FromJSON JWK' where - parseJSON = withObject "JWK'" $ \o -> JWK' <$> parseJSON (Object o) - -instance ToJSON JWK' where - toJSON (JWK' k) = object $ Types.objectPairs (toJSON k) - -instance AsPublicKey JWK' where - asPublicKey = prism' id (_JWK' (_RSKeyParameters (preview asPublicKey))) - -genJWK' :: MonadRandom m => Int -> m JWK' -genJWK' size = JWK' . RSKeyParameters <$> genRSA size - -toJWK :: JWK' -> JWK -toJWK (JWK' (RSKeyParameters k)) = fromKeyMaterial $ RSAKeyMaterial k diff --git a/src/Crypto/JOSE/TH.hs b/src/Crypto/JOSE/TH.hs --- a/src/Crypto/JOSE/TH.hs +++ b/src/Crypto/JOSE/TH.hs @@ -102,10 +102,8 @@ in #if ! MIN_VERSION_template_haskell(2,11,0) dataD (cxt []) (mkName s) [] (map conQ vs) derive -#elif ! 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))] + dataD (cxt []) (mkName s) [] Nothing (map conQ vs) (mapM conT derive) #endif , instanceD (cxt []) (aesonInstance s ''FromJSON) [parseJSONFun vs] , instanceD (cxt []) (aesonInstance s ''ToJSON) [toJSONFun vs] diff --git a/src/Crypto/JOSE/Types.hs b/src/Crypto/JOSE/Types.hs --- a/src/Crypto/JOSE/Types.hs +++ b/src/Crypto/JOSE/Types.hs @@ -32,14 +32,13 @@ , Base64SHA256(..) , Base64X509(..) , URI + , base64url ) where import Control.Lens import Data.Aeson import Data.Aeson.Types (Parser) -import Data.Byteable import qualified Data.ByteString as B -import qualified Data.ByteString.Base64.URL as B64U import Data.X509 import Network.URI (URI) import Test.QuickCheck @@ -113,9 +112,6 @@ -- newtype Base64Octets = Base64Octets B.ByteString deriving (Eq, Show) - -instance Byteable Base64Octets where - toBytes (Base64Octets s) = unpad $ B64U.encode s instance FromJSON Base64Octets where parseJSON = withText "Base64Octets" $ parseB64Url (pure . Base64Octets) diff --git a/src/Crypto/JOSE/Types/Internal.hs b/src/Crypto/JOSE/Types/Internal.hs --- a/src/Crypto/JOSE/Types/Internal.hs +++ b/src/Crypto/JOSE/Types/Internal.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2013, 2014 Fraser Tweedale +-- Copyright (C) 2013, 2014, 2017 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,6 +12,8 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-| @@ -19,14 +21,29 @@ Internal utility functions for encoding/decoding JOSE types. -} -module Crypto.JOSE.Types.Internal where +module Crypto.JOSE.Types.Internal + ( + objectPairs + , encodeB64 + , parseB64 + , encodeB64Url + , parseB64Url + , pad + , unpad + , bsToInteger + , integerToBS + , sizedIntegerToBS + , base64url + ) where +import Data.Bifunctor (first) import Data.Char (ord) import Data.Monoid ((<>)) import Data.Tuple (swap) import Data.Word (Word8) import Control.Lens +import Control.Lens.Cons.Extras import Data.Aeson.Types import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L @@ -111,15 +128,35 @@ unpadL = L.reverse . L.dropWhile (== 61) . L.reverse {-# RULES "unpad/unpadL" unpad = unpadL #-} + +-- | Prism for encoding / decoding base64url. +-- +-- To encode, @'review' base64url@. +-- To decode, @'preview' base64url@. +-- +-- Works with any combinations of strict/lazy @ByteString@. +-- +base64url :: + ( AsEmpty s1, AsEmpty s2 + , Cons s1 s1 Word8 Word8 + , Cons s2 s2 Word8 Word8 + ) => Prism' s1 s2 +base64url = reconsIso . padder . b64u . reconsIso + where + padder = iso pad unpad + b64u = prism B64U.encode (\s -> first (const s) (B64U.decode s)) + reconsIso = iso (view recons) (view recons) + + -- | Produce a parser of base64url encoded text from a bytestring parser. -- parseB64Url :: (B.ByteString -> Parser a) -> T.Text -> Parser a -parseB64Url f = either fail f . B64U.decode . pad . E.encodeUtf8 +parseB64Url f = maybe (fail "Not valid base64url") f . preview base64url . E.encodeUtf8 -- | Convert a bytestring to a base64url encoded JSON 'String' -- encodeB64Url :: B.ByteString -> Value -encodeB64Url = String . E.decodeUtf8 . unpad . B64U.encode +encodeB64Url = String . E.decodeUtf8 . review base64url -- | Convert an unsigned big endian octet sequence to the integer -- it represents. diff --git a/src/Crypto/JWT.hs b/src/Crypto/JWT.hs --- a/src/Crypto/JWT.hs +++ b/src/Crypto/JWT.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale +-- Copyright (C) 2013, 2014, 2015, 2016, 2017 Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -13,6 +13,7 @@ -- limitations under the License. {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -20,28 +21,53 @@ {-| -JSON Web Token implementation. +JSON Web Token implementation (RFC 7519). A JWT is a JWS +with a payload of /claims/ to be transferred between two +parties. +JWTs use the JWS /compact serialisation/. +See "Crypto.JOSE.Compact" for details. + +@ +mkClaims :: IO 'ClaimsSet' +mkClaims = do + t <- 'currentTime' + pure $ 'emptyClaimsSet' + & 'claimIss' .~ Just ("alice") + & 'claimAud' .~ Just ('Audience' ["bob"]) + & 'claimIat' .~ Just ('NumericDate' t) + +doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT') +doJwtSign jwk claims = runExceptT $ do + alg \<- 'bestJWSAlg' jwk + 'signClaims' jwk ('newJWSHeader' ('Protected', alg)) claims + +doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet') +doJwtVerify jwk jwt = runExceptT $ do + let config = 'defaultJWTValidationSettings' (== "bob") + 'verifyClaims' config jwk jwt +@ + -} module Crypto.JWT ( - JWT(..) - , JWTCrypto(..) - , JWTError(..) - , AsJWTError(..) + -- * Creating a JWT + signClaims + , JWT + , SignedJWT - , JWTValidationSettings + -- * Validating a JWT and extracting claims , defaultJWTValidationSettings - , HasJWTValidationSettings(..) + , verifyClaims , HasAllowedSkew(..) , HasAudiencePredicate(..) , HasIssuerPredicate(..) , HasCheckIssuedAt(..) - - , createJWSJWT - , validateJWSJWT + , JWTValidationSettings + , HasJWTValidationSettings(..) - , ClaimsSet(..) -- TODO hide fields + -- * Claims Set + , ClaimsSet , claimAud , claimExp , claimIat @@ -54,15 +80,20 @@ , emptyClaimsSet , validateClaimsSet - , Audience(..) + -- * JWT errors + , JWTError(..) + , AsJWTError(..) + -- * Miscellaneous + , Audience(..) , StringOrURI - , fromString - , fromURI - , getString - , getURI - + , stringOrUri + , string + , uri , NumericDate(..) + + , module Crypto.JOSE + ) where import Control.Applicative @@ -71,15 +102,18 @@ #if ! MIN_VERSION_monad_time(0,2,0) import Control.Monad.Time.Instances () #endif +import Data.Foldable (traverse_) +import Data.Functor.Identity import Data.Maybe +import Data.List (unfoldr) import qualified Data.String import Control.Lens ( - makeClassy, makeClassyPrisms, makeLenses, makePrisms, - Lens', _Just, over, preview, review, view) + makeClassy, makeClassyPrisms, makePrisms, + Lens', _Just, over, preview, review, view, + Prism', prism', Cons, cons, uncons, iso, Iso') import Control.Monad.Except (MonadError(throwError)) import Data.Aeson -import qualified Data.ByteString.Lazy as BSL import qualified Data.HashMap.Strict as M import qualified Data.Text as T import Data.Time (NominalDiffTime, UTCTime, addUTCTime) @@ -92,6 +126,9 @@ data JWTError = JWSError Error + -- ^ A JOSE error occurred while processing the JWT + | JWTClaimsSetDecodeError String + -- ^ The JWT payload is not a JWT Claims Set | JWTExpired | JWTNotYetValid | JWTNotInIssuer @@ -104,47 +141,48 @@ _Error = _JWSError --- §2. Terminology +-- RFC 7519 §2. Terminology -- | A JSON string value, with the additional requirement that while --- arbitrary string values MAY be used, any value containing a /:/ +-- arbitrary string values MAY be used, any value containing a @:@ -- character MUST be a URI. -- -data StringOrURI = Arbitrary T.Text | OrURI URI deriving (Eq, Show) +-- __Note__: the 'IsString' instance will fail if the string +-- contains a @:@ but does not parse as a 'URI'. Use 'stringOrUri' +-- directly in this situation. +-- +data StringOrURI = Arbitrary String | OrURI URI deriving (Eq, Show) instance Data.String.IsString StringOrURI where - fromString = Arbitrary . T.pack + fromString = fromJust . preview stringOrUri --- | Construct a 'StringOrURI' from text --- -fromString :: T.Text -> StringOrURI -fromString s = maybe (Arbitrary s) OrURI $ parseURI $ T.unpack s +consString :: (Cons s s Char Char, Monoid s) => Iso' s String +consString = iso (unfoldr uncons) (foldr cons mempty) --- | Construct a 'StringOrURI' from a URI --- -fromURI :: URI -> StringOrURI -fromURI = OrURI +stringOrUri :: (Cons s s Char Char, Monoid s) => Prism' s StringOrURI +stringOrUri = consString . prism' rev fwd + where + rev (Arbitrary s) = s + rev (OrURI x) = show x + fwd s = if ':' `elem` s then OrURI <$> parseURI s else pure (Arbitrary s) --- | Get the -getString :: StringOrURI -> Maybe T.Text -getString (Arbitrary a) = Just a -getString (OrURI _) = Nothing +string :: Prism' StringOrURI String +string = prism' Arbitrary f where + f (Arbitrary s) = Just s + f _ = Nothing --- | Get the uri from a 'StringOrURI' --- -getURI :: StringOrURI -> Maybe URI -getURI (Arbitrary _) = Nothing -getURI (OrURI a) = Just a +uri :: Prism' StringOrURI URI +uri = prism' OrURI f where + f (OrURI s) = Just s + f _ = Nothing instance FromJSON StringOrURI where - parseJSON = withText "StringOrURI" (\s -> - if T.any (== ':') s - then OrURI <$> parseJSON (String s) - else pure $ Arbitrary s) + parseJSON = withText "StringOrURI" + (maybe (fail "failed to parse StringOrURI") pure . preview stringOrUri) instance ToJSON StringOrURI where toJSON (Arbitrary s) = toJSON s - toJSON (OrURI uri) = toJSON $ show uri + toJSON (OrURI x) = toJSON $ show x -- | A JSON numeric value representing the number of seconds from @@ -168,6 +206,9 @@ -- /aud/ value MAY be a single case-sensitive string containing a -- 'StringOrURI' value. -- +-- The 'ToJSON' instance formats an 'Audience' with one value as a +-- string (some non-compliant implementations require this.) +-- newtype Audience = Audience [StringOrURI] deriving (Eq, Show) makePrisms ''Audience @@ -180,58 +221,91 @@ -- | The JWT Claims Set represents a JSON object whose members are --- the claims conveyed by the JWT. +-- the registered claims defined by RFC 7519. Unrecognised +-- claims are gathered into the 'unregisteredClaims' map. -- data ClaimsSet = ClaimsSet { _claimIss :: Maybe StringOrURI - -- ^ The issuer claim identifies the principal that issued the - -- JWT. The processing of this claim is generally application - -- specific. , _claimSub :: Maybe StringOrURI - -- ^ 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. , _claimAud :: Maybe Audience - -- ^ 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. , _claimExp :: Maybe NumericDate - -- ^ 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. , _claimNbf :: Maybe NumericDate - -- ^ 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. , _claimIat :: Maybe NumericDate - -- ^ 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. , _claimJti :: Maybe T.Text - -- ^ 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. , _unregisteredClaims :: M.HashMap T.Text Value - -- ^ Claim Names can be defined at will by those using JWTs. } deriving (Eq, Show) -makeLenses ''ClaimsSet +-- | 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) + +-- | 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 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 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 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 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 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) + +-- | Claim Names can be defined at will by those using JWTs. +unregisteredClaims :: Lens' ClaimsSet (M.HashMap T.Text Value) +unregisteredClaims f h@(ClaimsSet { _unregisteredClaims = a}) = + fmap (\a' -> h { _unregisteredClaims = a' }) (f a) + + -- | Return an empty claims set. -- emptyClaimsSet :: ClaimsSet @@ -281,12 +355,19 @@ instance HasValidationSettings JWTValidationSettings where validationSettings = jwtValidationSettingsValidationSettings +-- | Maximum allowed skew when validating the /nbf/, /exp/ and /iat/ claims. class HasAllowedSkew s where allowedSkew :: Lens' s NominalDiffTime + +-- | Predicate for checking values in the /aud/ claim. class HasAudiencePredicate s where audiencePredicate :: Lens' s (StringOrURI -> Bool) + +-- | Predicate for checking the /iss/ claim. class HasIssuerPredicate s where issuerPredicate :: Lens' s (StringOrURI -> Bool) + +-- | Whether to check that the /iat/ claim is not in the future. class HasCheckIssuedAt s where checkIssuedAt :: Lens' s Bool @@ -299,19 +380,33 @@ instance HasJWTValidationSettings a => HasCheckIssuedAt a where checkIssuedAt = jwtValidationSettingsCheckIssuedAt -defaultJWTValidationSettings :: JWTValidationSettings -defaultJWTValidationSettings = JWTValidationSettings +-- | Acquire the default validation settings. +-- +-- +-- states that applications MUST identify itself with a value in the +-- audience claim, therefore a predicate must be supplied. +-- +-- The other defaults are: +-- +-- - 'defaultValidationSettings' for JWS verification +-- - Zero clock skew tolerance when validating /nbf/, /exp/ and /iat/ claims +-- - /iat/ claim is checked +-- - /issuer/ claim is not checked +-- +defaultJWTValidationSettings :: (StringOrURI -> Bool) -> JWTValidationSettings +defaultJWTValidationSettings p = JWTValidationSettings defaultValidationSettings 0 - False - (const False) + True + p (const True) --- | Validate the claims made by a ClaimsSet. Currently only inspects --- the /exp/ and /nbf/ claims. N.B. These checks are also performed by --- 'validateJWSJWT', which also validates any signatures, so you --- shouldn’t need to use this directly in the normal course of things. +-- | 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. +-- validateClaimsSet :: ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a @@ -321,140 +416,127 @@ ) => a -> ClaimsSet - -> m () + -> m ClaimsSet validateClaimsSet conf claims = - sequence_ - [ validateExpClaim conf claims - , validateIatClaim conf claims - , validateNbfClaim conf claims - , validateIssClaim conf claims - , validateAudClaim conf claims + traverse_ (($ claims) . ($ conf)) + [ validateExpClaim + , validateIatClaim + , validateNbfClaim + , validateIssClaim + , validateAudClaim ] + *> pure claims validateExpClaim :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m) => a -> ClaimsSet -> m () -validateExpClaim conf (ClaimsSet _ _ _ (Just e) _ _ _ _) = do - now <- currentTime - if now < addUTCTime (abs (view allowedSkew conf)) (view _NumericDate e) - then pure () - else throwError (review _JWTExpired ()) -validateExpClaim _ _ = pure () +validateExpClaim conf = + traverse_ (\t -> do + now <- currentTime + unless (now < addUTCTime (abs (view allowedSkew conf)) (view _NumericDate t)) $ + throwError (review _JWTExpired ())) + . preview (claimExp . _Just) validateIatClaim :: (MonadTime m, HasCheckIssuedAt a, HasAllowedSkew a, AsJWTError e, MonadError e m) => a -> ClaimsSet -> m () -validateIatClaim conf (ClaimsSet _ _ _ _ _ (Just t) _ _) = do - now <- currentTime - when (view checkIssuedAt conf) $ - when ((view _NumericDate t) > addUTCTime (abs (view allowedSkew conf)) now) $ - throwError (review _JWTIssuedAtFuture ()) -validateIatClaim _ _ = pure () +validateIatClaim conf = + traverse_ (\t -> do + now <- currentTime + when (view checkIssuedAt conf) $ + when ((view _NumericDate t) > addUTCTime (abs (view allowedSkew conf)) now) $ + throwError (review _JWTIssuedAtFuture ())) + . preview (claimIat . _Just) validateNbfClaim :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m) => a -> ClaimsSet -> m () -validateNbfClaim conf (ClaimsSet _ _ _ _ (Just n) _ _ _) = do - now <- currentTime - if now >= addUTCTime (negate (abs (view allowedSkew conf))) (view _NumericDate n) - then pure () - else throwError (review _JWTNotYetValid ()) -validateNbfClaim _ _ = pure () +validateNbfClaim conf = + traverse_ (\t -> do + now <- currentTime + unless (now >= addUTCTime (negate (abs (view allowedSkew conf))) (view _NumericDate t)) $ + throwError (review _JWTNotYetValid ())) + . preview (claimNbf . _Just) validateAudClaim :: (HasAudiencePredicate s, AsJWTError e, MonadError e m) => s -> ClaimsSet -> m () -validateAudClaim conf claims = - maybe - (pure ()) - (\auds -> - if or (view audiencePredicate conf <$> auds) - then pure () - else throwError (review _JWTNotInAudience ()) - ) - (preview (claimAud . _Just . _Audience) claims) +validateAudClaim conf = + traverse_ + (\auds -> unless (or (view audiencePredicate conf <$> auds)) $ + throwError (review _JWTNotInAudience ())) + . preview (claimAud . _Just . _Audience) validateIssClaim :: (HasIssuerPredicate s, AsJWTError e, MonadError e m) => s -> ClaimsSet -> m () -validateIssClaim conf claims = - maybe - (pure ()) - (\iss -> - if view issuerPredicate conf iss - then pure () - else throwError (review _JWTNotInIssuer ()) - ) - (preview (claimIss . _Just) claims) - --- | Data representing the JOSE aspects of a JWT. --- -data JWTCrypto = JWTJWS (JWS JWSHeader) deriving (Eq, Show) - -instance FromCompact JWTCrypto where - fromCompact = fmap JWTJWS . fromCompact - -instance ToCompact JWTCrypto where - toCompact (JWTJWS jws) = toCompact jws +validateIssClaim conf = + traverse_ (\iss -> + unless (view issuerPredicate conf iss) $ + throwError (review _JWTNotInIssuer ())) + . preview (claimIss . _Just) -- | JSON Web Token data. -- -data JWT = JWT - { jwtCrypto :: JWTCrypto -- ^ JOSE aspect of the JWT. - , jwtClaimsSet :: ClaimsSet -- ^ Claims of the JWT. - } deriving (Eq, Show) +newtype JWT a = JWT a + deriving (Eq, Show) -instance FromCompact JWT where - fromCompact = fromCompact >=> toJWT where - toJWT (JWTJWS jws) = either - (throwError . review _CompactDecodeError) - (pure . JWT (JWTJWS jws)) - (eitherDecode $ jwsPayload jws) +-- | A digitally signed or MACed JWT +-- +type SignedJWT = JWT (CompactJWS JWSHeader) -instance ToCompact JWT where - toCompact = toCompact . jwtCrypto +instance FromCompact a => FromCompact (JWT a) where + fromCompact = fmap JWT . fromCompact +instance ToCompact a => ToCompact (JWT a) where + toCompact (JWT a) = toCompact a --- | Validate a JWT as a JWS (JSON Web Signature), then as a Claims --- Set. + +-- | Cryptographically verify a JWS JWT, then validate the +-- Claims Set, returning it if valid. -- -validateJWSJWT +-- 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. +-- +verifyClaims :: ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a , HasIssuerPredicate a , HasCheckIssuedAt a , HasValidationSettings a , AsError e, AsJWTError e, MonadError e m + , JWKStore k ) => a - -> JWK - -> JWT - -> m () -validateJWSJWT conf k (JWT (JWTJWS jws) c) = do + -> k + -> SignedJWT + -> m ClaimsSet +verifyClaims conf k (JWT jws) = -- It is important, for security reasons, that the signature get -- verified before the claims. - verifyJWS conf k jws >> validateClaimsSet conf c + verifyJWS conf k jws + >>= either (throwError . review _JWTClaimsSetDecodeError) pure . eitherDecode + >>= validateClaimsSet conf --- | Create a JWT that is a JWS. +-- | Create a JWS JWT -- -createJWSJWT +signClaims :: (MonadRandom m, MonadError e m, AsError e) => JWK - -> JWSHeader + -> JWSHeader () -> ClaimsSet - -> m JWT -createJWSJWT k h c = - (\jws -> JWT (JWTJWS jws) c) <$> signJWS (JWS payload []) h k - where - payload = Base64Octets $ BSL.toStrict $ encode c + -> m SignedJWT +signClaims k h c = + JWT <$> signJWS (encode c) (Identity (h, k)) diff --git a/test/JWK.hs b/test/JWK.hs --- a/test/JWK.hs +++ b/test/JWK.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2013 Fraser Tweedale +-- Copyright (C) 2013, 2017 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,11 +12,17 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module JWK where +import Data.Monoid ((<>)) + +import Control.Lens (_Right, review, view) +import Control.Lens.Extras (is) import Data.Aeson +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Test.Hspec @@ -34,9 +40,13 @@ jwkAppendixBSpec jwkAppendixC1Spec jwsAppendixA1Spec + cfrgSpec +#if MIN_VERSION_aeson(0,10,0) + thumbprintSpec +#endif jwsAppendixA1Spec :: Spec -jwsAppendixA1Spec = describe "JWS A.1.1. JWK" $ do +jwsAppendixA1Spec = describe "RFC 7515 A.1.1. JWK" $ do -- can't make aeson encode JSON to exact representation used in -- IETF doc, be we can go in reverse and then ensure that the -- round-trip checks out @@ -48,208 +58,251 @@ eitherDecode (encode jwk) `shouldBe` Right jwk where - exampleJWK = "\ - \{\"kty\":\"oct\",\ - \ \"k\":\"AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75\ - \aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow\"\ - \}" - jwk = JWK (OctKeyMaterial octKeyMaterial) z z z z z z z z where z = Nothing - octKeyMaterial = OctKeyParameters Oct $ Types.Base64Octets $ - foldr B.cons B.empty + exampleJWK = "" + <> "{\"kty\":\"oct\"," + <> "\"k\":\"AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75" + <> "aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow\"" + <> "}" + jwk = 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] jwk3Spec :: Spec -jwk3Spec = describe "JWK §3. Example JWK" $ +jwk3Spec = describe "RFC 7517 §3. Example JWK" $ it "successfully decodes the examples" $ - lr (eitherDecode exampleJWK :: Either String JWK) `shouldBe` R + (eitherDecode exampleJWK :: Either String JWK) `shouldSatisfy` is _Right where - exampleJWK = "\ - \{\"kty\":\"EC\",\ - \ \"crv\":\"P-256\",\ - \ \"x\":\"f83OJ3D2xF1Bg8vub9tLe1gHMzV76e8Tus9uPHvRVEU\",\ - \ \"y\":\"x_FEzRu9m36HLN_tue659LNpXW6pCyStikYjKIWI5a0\",\ - \ \"kid\":\"Public key used in JWS A.3 example\"\ - \}" + exampleJWK = "" + <> "{\"kty\":\"EC\"," + <> " \"crv\":\"P-256\"," + <> " \"x\":\"f83OJ3D2xF1Bg8vub9tLe1gHMzV76e8Tus9uPHvRVEU\"," + <> " \"y\":\"x_FEzRu9m36HLN_tue659LNpXW6pCyStikYjKIWI5a0\"," + <> " \"kid\":\"Public key used in JWS spec Appendix A.3 example\"" + <> "}" jwkAppendixA1Spec :: Spec -jwkAppendixA1Spec = describe "JWK A.1. Example Public Keys" $ +jwkAppendixA1Spec = describe "RFC 7517 A.1. Example Public Keys" $ it "successfully decodes the examples" $ - lr (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldBe` R + (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldSatisfy` is _Right where - exampleEC = "\ - \ {\"kty\":\"EC\",\ - \ \"crv\":\"P-256\",\ - \ \"x\":\"MKBCTNIcKUSDii11ySs3526iDZ8AiTo7Tu6KPAqv7D4\",\ - \ \"y\":\"4Etl6SRW2YiLUrN5vfvVHuhp7x8PxltmWWlbbM4IFyM\",\ - \ \"use\":\"enc\",\ - \ \"kid\":\"1\"}" - exampleRSA = "\ - \ {\"kty\":\"RSA\",\ - \ \"n\": \"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx\ - \4cbbfAAtVT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMs\ - \tn64tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FDW2\ - \QvzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n91CbOpbI\ - \SD08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINHaQ-G_xBniIqb\ - \w0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\",\ - \ \"e\":\"AQAB\",\ - \ \"alg\":\"RS256\",\ - \ \"kid\":\"2011-04-29\"}" + exampleEC = "" + <> "{\"kty\":\"EC\"," + <> " \"crv\":\"P-256\"," + <> " \"x\":\"MKBCTNIcKUSDii11ySs3526iDZ8AiTo7Tu6KPAqv7D4\"," + <> " \"y\":\"4Etl6SRW2YiLUrN5vfvVHuhp7x8PxltmWWlbbM4IFyM\"," + <> " \"use\":\"enc\"," + <> " \"kid\":\"1\"}" + exampleRSA = "" + <> "{\"kty\":\"RSA\"," + <> " \"n\": \"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx" + <> "4cbbfAAtVT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMs" + <> "tn64tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FDW2" + <> "QvzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n91CbOpbI" + <> "SD08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINHaQ-G_xBniIqb" + <> "w0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\"," + <> " \"e\":\"AQAB\"," + <> " \"alg\":\"RS256\"," + <> " \"kid\":\"2011-04-29\"}" exampleJWKSet = "{\"keys\": [" `L.append` exampleEC `L.append` "," `L.append` exampleRSA `L.append` "]}" jwkAppendixA2Spec :: Spec -jwkAppendixA2Spec = describe "JWK A.2. Example Private Keys" $ +jwkAppendixA2Spec = describe "RFC 7517 A.2. Example Private Keys" $ it "successfully decodes the examples" $ - lr (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldBe` R + (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldSatisfy` is _Right where - exampleJWKSet = "\ - \{\"keys\":\ - \ [\ - \ {\"kty\":\"EC\",\ - \ \"crv\":\"P-256\",\ - \ \"x\":\"MKBCTNIcKUSDii11ySs3526iDZ8AiTo7Tu6KPAqv7D4\",\ - \ \"y\":\"4Etl6SRW2YiLUrN5vfvVHuhp7x8PxltmWWlbbM4IFyM\",\ - \ \"d\":\"870MB6gfuTJ4HtUnUvYMyJpr5eUZNP4Bk43bVdj3eAE\",\ - \ \"use\":\"enc\",\ - \ \"kid\":\"1\"},\ - \\ - \ {\"kty\":\"RSA\",\ - \ \"n\":\"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx4\ - \cbbfAAtVT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMst\ - \n64tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FDW2Q\ - \vzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n91CbOpbIS\ - \D08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINHaQ-G_xBniIqbw\ - \0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\",\ - \ \"e\":\"AQAB\",\ - \ \"d\":\"X4cTteJY_gn4FYPsXB8rdXix5vwsg1FLN5E3EaG6RJoVH-HLLKD9\ - \M7dx5oo7GURknchnrRweUkC7hT5fJLM0WbFAKNLWY2vv7B6NqXSzUvxT0_YSfqij\ - \wp3RTzlBaCxWp4doFk5N2o8Gy_nHNKroADIkJ46pRUohsXywbReAdYaMwFs9tv8d\ - \_cPVY3i07a3t8MN6TNwm0dSawm9v47UiCl3Sk5ZiG7xojPLu4sbg1U2jx4IBTNBz\ - \nbJSzFHK66jT8bgkuqsk0GjskDJk19Z4qwjwbsnn4j2WBii3RL-Us2lGVkY8fkFz\ - \me1z0HbIkfz0Y6mqnOYtqc0X4jfcKoAC8Q\",\ - \ \"p\":\"83i-7IvMGXoMXCskv73TKr8637FiO7Z27zv8oj6pbWUQyLPQBQxtPV\ - \nwD20R-60eTDmD2ujnMt5PoqMrm8RfmNhVWDtjjMmCMjOpSXicFHj7XOuVIYQyqV\ - \WlWEh6dN36GVZYk93N8Bc9vY41xy8B9RzzOGVQzXvNEvn7O0nVbfs\",\ - \ \"q\":\"3dfOR9cuYq-0S-mkFLzgItgMEfFzB2q3hWehMuG0oCuqnb3vobLyum\ - \qjVZQO1dIrdwgTnCdpYzBcOfW5r370AFXjiWft_NGEiovonizhKpo9VVS78TzFgx\ - \kIdrecRezsZ-1kYd_s1qDbxtkDEgfAITAG9LUnADun4vIcb6yelxk\",\ - \ \"dp\":\"G4sPXkc6Ya9y8oJW9_ILj4xuppu0lzi_H7VTkS8xj5SdX3coE0oim\ - \YwxIi2emTAue0UOa5dpgFGyBJ4c8tQ2VF402XRugKDTP8akYhFo5tAA77Qe_Nmtu\ - \YZc3C3m3I24G2GvR5sSDxUyAN2zq8Lfn9EUms6rY3Ob8YeiKkTiBj0\",\ - \ \"dq\":\"s9lAH9fggBsoFR8Oac2R_E2gw282rT2kGOAhvIllETE1efrA6huUU\ - \vMfBcMpn8lqeW6vzznYY5SSQF7pMdC_agI3nG8Ibp1BUb0JUiraRNqUfLhcQb_d9\ - \GF4Dh7e74WbRsobRonujTYN1xCaP6TO61jvWrX-L18txXw494Q_cgk\",\ - \ \"qi\":\"GyM_p6JrXySiz1toFgKbWV-JdI3jQ4ypu9rbMWx3rQJBfmt0FoYzg\ - \UIZEVFEcOqwemRN81zoDAaa-Bk0KWNGDjJHZDdDmFhW3AN7lI-puxk_mHZGJ11rx\ - \yR8O55XLSe3SPmRfKwZI6yU24ZxvQKFYItdldUKGzO6Ia6zTKhAVRU\",\ - \ \"alg\":\"RS256\",\ - \ \"kid\":\"2011-04-29\"}\ - \ ]\ - \}" + exampleJWKSet = "" + <> "{\"keys\":" + <> " [" + <> " {\"kty\":\"EC\"," + <> " \"crv\":\"P-256\"," + <> " \"x\":\"MKBCTNIcKUSDii11ySs3526iDZ8AiTo7Tu6KPAqv7D4\"," + <> " \"y\":\"4Etl6SRW2YiLUrN5vfvVHuhp7x8PxltmWWlbbM4IFyM\"," + <> " \"d\":\"870MB6gfuTJ4HtUnUvYMyJpr5eUZNP4Bk43bVdj3eAE\"," + <> " \"use\":\"enc\"," + <> " \"kid\":\"1\"}," + <> "" + <> " {\"kty\":\"RSA\"," + <> " \"n\":\"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx4" + <> "cbbfAAtVT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMst" + <> "n64tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FDW2Q" + <> "vzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n91CbOpbIS" + <> "D08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINHaQ-G_xBniIqbw" + <> "0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\"," + <> " \"e\":\"AQAB\"," + <> " \"d\":\"X4cTteJY_gn4FYPsXB8rdXix5vwsg1FLN5E3EaG6RJoVH-HLLKD9" + <> "M7dx5oo7GURknchnrRweUkC7hT5fJLM0WbFAKNLWY2vv7B6NqXSzUvxT0_YSfqij" + <> "wp3RTzlBaCxWp4doFk5N2o8Gy_nHNKroADIkJ46pRUohsXywbReAdYaMwFs9tv8d" + <> "_cPVY3i07a3t8MN6TNwm0dSawm9v47UiCl3Sk5ZiG7xojPLu4sbg1U2jx4IBTNBz" + <> "nbJSzFHK66jT8bgkuqsk0GjskDJk19Z4qwjwbsnn4j2WBii3RL-Us2lGVkY8fkFz" + <> "me1z0HbIkfz0Y6mqnOYtqc0X4jfcKoAC8Q\"," + <> " \"p\":\"83i-7IvMGXoMXCskv73TKr8637FiO7Z27zv8oj6pbWUQyLPQBQxtPV" + <> "nwD20R-60eTDmD2ujnMt5PoqMrm8RfmNhVWDtjjMmCMjOpSXicFHj7XOuVIYQyqV" + <> "WlWEh6dN36GVZYk93N8Bc9vY41xy8B9RzzOGVQzXvNEvn7O0nVbfs\"," + <> " \"q\":\"3dfOR9cuYq-0S-mkFLzgItgMEfFzB2q3hWehMuG0oCuqnb3vobLyum" + <> "qjVZQO1dIrdwgTnCdpYzBcOfW5r370AFXjiWft_NGEiovonizhKpo9VVS78TzFgx" + <> "kIdrecRezsZ-1kYd_s1qDbxtkDEgfAITAG9LUnADun4vIcb6yelxk\"," + <> " \"dp\":\"G4sPXkc6Ya9y8oJW9_ILj4xuppu0lzi_H7VTkS8xj5SdX3coE0oim" + <> "YwxIi2emTAue0UOa5dpgFGyBJ4c8tQ2VF402XRugKDTP8akYhFo5tAA77Qe_Nmtu" + <> "YZc3C3m3I24G2GvR5sSDxUyAN2zq8Lfn9EUms6rY3Ob8YeiKkTiBj0\"," + <> " \"dq\":\"s9lAH9fggBsoFR8Oac2R_E2gw282rT2kGOAhvIllETE1efrA6huUU" + <> "vMfBcMpn8lqeW6vzznYY5SSQF7pMdC_agI3nG8Ibp1BUb0JUiraRNqUfLhcQb_d9" + <> "GF4Dh7e74WbRsobRonujTYN1xCaP6TO61jvWrX-L18txXw494Q_cgk\"," + <> " \"qi\":\"GyM_p6JrXySiz1toFgKbWV-JdI3jQ4ypu9rbMWx3rQJBfmt0FoYzg" + <> "UIZEVFEcOqwemRN81zoDAaa-Bk0KWNGDjJHZDdDmFhW3AN7lI-puxk_mHZGJ11rx" + <> "yR8O55XLSe3SPmRfKwZI6yU24ZxvQKFYItdldUKGzO6Ia6zTKhAVRU\"," + <> " \"alg\":\"RS256\"," + <> " \"kid\":\"2011-04-29\"}" + <> " ]" + <> "}" jwkAppendixA3Spec :: Spec -jwkAppendixA3Spec = describe "JWK A.3. Example Symmetric Keys" $ +jwkAppendixA3Spec = describe "RFC 7517 A.3. Example Symmetric Keys" $ it "successfully decodes the examples" $ - lr (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldBe` R + (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldSatisfy` is _Right where - exampleJWKSet = "\ - \{\"keys\":\ - \ [\ - \ {\"kty\":\"oct\",\ - \ \"alg\":\"A128KW\",\ - \ \"k\":\"GawgguFyGrWKav7AX4VKUg\"},\ - \\ - \ {\"kty\":\"oct\",\ - \ \"k\":\"AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75\ - \aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow\",\ - \ \"kid\":\"HMAC key used in JWS A.1 example\"}\ - \ ]\ - \}" + exampleJWKSet = "" + <> "{\"keys\":" + <> " [" + <> " {\"kty\":\"oct\"," + <> " \"alg\":\"A128KW\"," + <> " \"k\":\"GawgguFyGrWKav7AX4VKUg\"}," + <> "" + <> " {\"kty\":\"oct\"," + <> " \"k\":\"AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75" + <> "aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow\"," + <> " \"kid\":\"HMAC key used in JWS spec Appendix A.1 example\"}" + <> " ]" + <> "}" jwkAppendixBSpec :: Spec jwkAppendixBSpec = describe "JWK B. Example Use of \"x5c\" (X.509 Certificate Chain) Parameter" $ it "successfully decodes the example" $ - lr (eitherDecode exampleJWK :: Either String JWK) `shouldBe` R + (eitherDecode exampleJWK :: Either String JWK) `shouldSatisfy` is _Right where - exampleJWK = "\ - \{\"kty\":\"RSA\",\ - \ \"use\":\"sig\",\ - \ \"kid\":\"1b94c\",\ - \ \"n\":\"vrjOfz9Ccdgx5nQudyhdoR17V-IubWMeOZCwX_jj0hgAsz2J_pqYW08\ - \PLbK_PdiVGKPrqzmDIsLI7sA25VEnHU1uCLNwBuUiCO11_-7dYbsr4iJmG0Q\ - \u2j8DsVyT1azpJC_NG84Ty5KKthuCaPod7iI7w0LK9orSMhBEwwZDCxTWq4a\ - \YWAchc8t-emd9qOvWtVMDC2BXksRngh6X5bUYLy6AyHKvj-nUy1wgzjYQDwH\ - \MTplCoLtU-o-8SNnZ1tmRoGE9uJkBLdh5gFENabWnU5m1ZqZPdwS-qo-meMv\ - \VfJb6jJVWRpl2SUtCnYG2C32qvbWbjZ_jBPD5eunqsIo1vQ\",\ - \ \"e\":\"AQAB\",\ - \ \"x5c\":\ - \ [\"MIIDQjCCAiqgAwIBAgIGATz/FuLiMA0GCSqGSIb3DQEBBQUAMGIxCzAJB\ - \gNVBAYTAlVTMQswCQYDVQQIEwJDTzEPMA0GA1UEBxMGRGVudmVyMRwwGgYD\ - \VQQKExNQaW5nIElkZW50aXR5IENvcnAuMRcwFQYDVQQDEw5CcmlhbiBDYW1\ - \wYmVsbDAeFw0xMzAyMjEyMzI5MTVaFw0xODA4MTQyMjI5MTVaMGIxCzAJBg\ - \NVBAYTAlVTMQswCQYDVQQIEwJDTzEPMA0GA1UEBxMGRGVudmVyMRwwGgYDV\ - \QQKExNQaW5nIElkZW50aXR5IENvcnAuMRcwFQYDVQQDEw5CcmlhbiBDYW1w\ - \YmVsbDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAL64zn8/QnH\ - \YMeZ0LncoXaEde1fiLm1jHjmQsF/449IYALM9if6amFtPDy2yvz3YlRij66\ - \s5gyLCyO7ANuVRJx1NbgizcAblIgjtdf/u3WG7K+IiZhtELto/A7Fck9Ws6\ - \SQvzRvOE8uSirYbgmj6He4iO8NCyvaK0jIQRMMGQwsU1quGmFgHIXPLfnpn\ - \fajr1rVTAwtgV5LEZ4Iel+W1GC8ugMhyr4/p1MtcIM42EA8BzE6ZQqC7VPq\ - \PvEjZ2dbZkaBhPbiZAS3YeYBRDWm1p1OZtWamT3cEvqqPpnjL1XyW+oyVVk\ - \aZdklLQp2Btgt9qr21m42f4wTw+Xrp6rCKNb0CAwEAATANBgkqhkiG9w0BA\ - \QUFAAOCAQEAh8zGlfSlcI0o3rYDPBB07aXNswb4ECNIKG0CETTUxmXl9KUL\ - \+9gGlqCz5iWLOgWsnrcKcY0vXPG9J1r9AqBNTqNgHq2G03X09266X5CpOe1\ - \zFo+Owb1zxtp3PehFdfQJ610CDLEaS9V9Rqp17hCyybEpOGVwe8fnk+fbEL\ - \2Bo3UPGrpsHzUoaGpDftmWssZkhpBJKVMJyf/RuP2SmmaIzmnw9JiSlYhzo\ - \4tpzd5rFXhjRbg4zW9C+2qok+2+qDM1iJ684gPHMIY8aLWrdgQTxkumGmTq\ - \gawR+N5MDtdPTEQ0XfIBc2cJEUyMTY5MPvACWpkA6SdS4xSvdXK3IVfOWA==\"]\ - \}" + exampleJWK = "" + <> "{\"kty\":\"RSA\"," + <> " \"use\":\"sig\"," + <> " \"kid\":\"1b94c\"," + <> " \"n\":\"vrjOfz9Ccdgx5nQudyhdoR17V-IubWMeOZCwX_jj0hgAsz2J_pqYW08" + <> "PLbK_PdiVGKPrqzmDIsLI7sA25VEnHU1uCLNwBuUiCO11_-7dYbsr4iJmG0Q" + <> "u2j8DsVyT1azpJC_NG84Ty5KKthuCaPod7iI7w0LK9orSMhBEwwZDCxTWq4a" + <> "YWAchc8t-emd9qOvWtVMDC2BXksRngh6X5bUYLy6AyHKvj-nUy1wgzjYQDwH" + <> "MTplCoLtU-o-8SNnZ1tmRoGE9uJkBLdh5gFENabWnU5m1ZqZPdwS-qo-meMv" + <> "VfJb6jJVWRpl2SUtCnYG2C32qvbWbjZ_jBPD5eunqsIo1vQ\"," + <> " \"e\":\"AQAB\"," + <> " \"x5c\":" + <> " [\"MIIDQjCCAiqgAwIBAgIGATz/FuLiMA0GCSqGSIb3DQEBBQUAMGIxCzAJB" + <> "gNVBAYTAlVTMQswCQYDVQQIEwJDTzEPMA0GA1UEBxMGRGVudmVyMRwwGgYD" + <> "VQQKExNQaW5nIElkZW50aXR5IENvcnAuMRcwFQYDVQQDEw5CcmlhbiBDYW1" + <> "wYmVsbDAeFw0xMzAyMjEyMzI5MTVaFw0xODA4MTQyMjI5MTVaMGIxCzAJBg" + <> "NVBAYTAlVTMQswCQYDVQQIEwJDTzEPMA0GA1UEBxMGRGVudmVyMRwwGgYDV" + <> "QQKExNQaW5nIElkZW50aXR5IENvcnAuMRcwFQYDVQQDEw5CcmlhbiBDYW1w" + <> "YmVsbDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAL64zn8/QnH" + <> "YMeZ0LncoXaEde1fiLm1jHjmQsF/449IYALM9if6amFtPDy2yvz3YlRij66" + <> "s5gyLCyO7ANuVRJx1NbgizcAblIgjtdf/u3WG7K+IiZhtELto/A7Fck9Ws6" + <> "SQvzRvOE8uSirYbgmj6He4iO8NCyvaK0jIQRMMGQwsU1quGmFgHIXPLfnpn" + <> "fajr1rVTAwtgV5LEZ4Iel+W1GC8ugMhyr4/p1MtcIM42EA8BzE6ZQqC7VPq" + <> "PvEjZ2dbZkaBhPbiZAS3YeYBRDWm1p1OZtWamT3cEvqqPpnjL1XyW+oyVVk" + <> "aZdklLQp2Btgt9qr21m42f4wTw+Xrp6rCKNb0CAwEAATANBgkqhkiG9w0BA" + <> "QUFAAOCAQEAh8zGlfSlcI0o3rYDPBB07aXNswb4ECNIKG0CETTUxmXl9KUL" + <> "+9gGlqCz5iWLOgWsnrcKcY0vXPG9J1r9AqBNTqNgHq2G03X09266X5CpOe1" + <> "zFo+Owb1zxtp3PehFdfQJ610CDLEaS9V9Rqp17hCyybEpOGVwe8fnk+fbEL" + <> "2Bo3UPGrpsHzUoaGpDftmWssZkhpBJKVMJyf/RuP2SmmaIzmnw9JiSlYhzo" + <> "4tpzd5rFXhjRbg4zW9C+2qok+2+qDM1iJ684gPHMIY8aLWrdgQTxkumGmTq" + <> "gawR+N5MDtdPTEQ0XfIBc2cJEUyMTY5MPvACWpkA6SdS4xSvdXK3IVfOWA==\"]" + <> "}" jwkAppendixC1Spec :: Spec -jwkAppendixC1Spec = describe "JWK C.1. Plaintext RSA Private Key" $ +jwkAppendixC1Spec = describe "RFC 7517 C.1. Plaintext RSA Private Key" $ it "successfully decodes the example" $ - lr (eitherDecode exampleJWK :: Either String JWK) `shouldBe` R + (eitherDecode exampleJWK :: Either String JWK) `shouldSatisfy` is _Right where - exampleJWK = "\ - \{\ - \ \"kty\":\"RSA\",\ - \ \"kid\":\"juliet@capulet.lit\",\ - \ \"use\":\"enc\",\ - \ \"n\":\"t6Q8PWSi1dkJj9hTP8hNYFlvadM7DflW9mWepOJhJ66w7nyoK1gPNqFMSQRy\ - \O125Gp-TEkodhWr0iujjHVx7BcV0llS4w5ACGgPrcAd6ZcSR0-Iqom-QFcNP\ - \8Sjg086MwoqQU_LYywlAGZ21WSdS_PERyGFiNnj3QQlO8Yns5jCtLCRwLHL0\ - \Pb1fEv45AuRIuUfVcPySBWYnDyGxvjYGDSM-AqWS9zIQ2ZilgT-GqUmipg0X\ - \OC0Cc20rgLe2ymLHjpHciCKVAbY5-L32-lSeZO-Os6U15_aXrk9Gw8cPUaX1\ - \_I8sLGuSiVdt3C_Fn2PZ3Z8i744FPFGGcG1qs2Wz-Q\",\ - \ \"e\":\"AQAB\",\ - \ \"d\":\"GRtbIQmhOZtyszfgKdg4u_N-R_mZGU_9k7JQ_jn1DnfTuMdSNprTeaSTyWfS\ - \NkuaAwnOEbIQVy1IQbWVV25NY3ybc_IhUJtfri7bAXYEReWaCl3hdlPKXy9U\ - \vqPYGR0kIXTQRqns-dVJ7jahlI7LyckrpTmrM8dWBo4_PMaenNnPiQgO0xnu\ - \ToxutRZJfJvG4Ox4ka3GORQd9CsCZ2vsUDmsXOfUENOyMqADC6p1M3h33tsu\ - \rY15k9qMSpG9OX_IJAXmxzAh_tWiZOwk2K4yxH9tS3Lq1yX8C1EWmeRDkK2a\ - \hecG85-oLKQt5VEpWHKmjOi_gJSdSgqcN96X52esAQ\",\ - \ \"p\":\"2rnSOV4hKSN8sS4CgcQHFbs08XboFDqKum3sc4h3GRxrTmQdl1ZK9uw-PIHf\ - \QP0FkxXVrx-WE-ZEbrqivH_2iCLUS7wAl6XvARt1KkIaUxPPSYB9yk31s0Q8\ - \UK96E3_OrADAYtAJs-M3JxCLfNgqh56HDnETTQhH3rCT5T3yJws\",\ - \ \"q\":\"1u_RiFDP7LBYh3N4GXLT9OpSKYP0uQZyiaZwBtOCBNJgQxaj10RWjsZu0c6I\ - \edis4S7B_coSKB0Kj9PaPaBzg-IySRvvcQuPamQu66riMhjVtG6TlV8CLCYK\ - \rYl52ziqK0E_ym2QnkwsUX7eYTB7LbAHRK9GqocDE5B0f808I4s\",\ - \ \"dp\":\"KkMTWqBUefVwZ2_Dbj1pPQqyHSHjj90L5x_MOzqYAJMcLMZtbUtwKqvVDq3\ - \tbEo3ZIcohbDtt6SbfmWzggabpQxNxuBpoOOf_a_HgMXK_lhqigI4y_kqS1w\ - \Y52IwjUn5rgRrJ-yYo1h41KR-vz2pYhEAeYrhttWtxVqLCRViD6c\",\ - \ \"dq\":\"AvfS0-gRxvn0bwJoMSnFxYcK1WnuEjQFluMGfwGitQBWtfZ1Er7t1xDkbN9\ - \GQTB9yqpDoYaN06H7CFtrkxhJIBQaj6nkF5KKS3TQtQ5qCzkOkmxIe3KRbBy\ - \mXxkb5qwUpX5ELD5xFc6FeiafWYY63TmmEAu_lRFCOJ3xDea-ots\",\ - \ \"qi\":\"lSQi-w9CpyUReMErP1RsBLk7wNtOvs5EQpPqmuMvqW57NBUczScEoPwmUqq\ - \abu9V0-Py4dQ57_bapoKRu1R90bvuFnU63SHWEFglZQvJDMeAvmj4sm-Fp0o\ - \Yu_neotgQ0hzbI5gry7ajdYy9-2lNx_76aBZoOUu9HCJ-UsfSOI8\"\ - \}" + exampleJWK = "" + <> "{" + <> " \"kty\":\"RSA\"," + <> " \"kid\":\"juliet@capulet.lit\"," + <> " \"use\":\"enc\"," + <> " \"n\":\"t6Q8PWSi1dkJj9hTP8hNYFlvadM7DflW9mWepOJhJ66w7nyoK1gPNqFMSQRy" + <> "O125Gp-TEkodhWr0iujjHVx7BcV0llS4w5ACGgPrcAd6ZcSR0-Iqom-QFcNP" + <> "8Sjg086MwoqQU_LYywlAGZ21WSdS_PERyGFiNnj3QQlO8Yns5jCtLCRwLHL0" + <> "Pb1fEv45AuRIuUfVcPySBWYnDyGxvjYGDSM-AqWS9zIQ2ZilgT-GqUmipg0X" + <> "OC0Cc20rgLe2ymLHjpHciCKVAbY5-L32-lSeZO-Os6U15_aXrk9Gw8cPUaX1" + <> "_I8sLGuSiVdt3C_Fn2PZ3Z8i744FPFGGcG1qs2Wz-Q\"," + <> " \"e\":\"AQAB\"," + <> " \"d\":\"GRtbIQmhOZtyszfgKdg4u_N-R_mZGU_9k7JQ_jn1DnfTuMdSNprTeaSTyWfS" + <> "NkuaAwnOEbIQVy1IQbWVV25NY3ybc_IhUJtfri7bAXYEReWaCl3hdlPKXy9U" + <> "vqPYGR0kIXTQRqns-dVJ7jahlI7LyckrpTmrM8dWBo4_PMaenNnPiQgO0xnu" + <> "ToxutRZJfJvG4Ox4ka3GORQd9CsCZ2vsUDmsXOfUENOyMqADC6p1M3h33tsu" + <> "rY15k9qMSpG9OX_IJAXmxzAh_tWiZOwk2K4yxH9tS3Lq1yX8C1EWmeRDkK2a" + <> "hecG85-oLKQt5VEpWHKmjOi_gJSdSgqcN96X52esAQ\"," + <> " \"p\":\"2rnSOV4hKSN8sS4CgcQHFbs08XboFDqKum3sc4h3GRxrTmQdl1ZK9uw-PIHf" + <> "QP0FkxXVrx-WE-ZEbrqivH_2iCLUS7wAl6XvARt1KkIaUxPPSYB9yk31s0Q8" + <> "UK96E3_OrADAYtAJs-M3JxCLfNgqh56HDnETTQhH3rCT5T3yJws\"," + <> " \"q\":\"1u_RiFDP7LBYh3N4GXLT9OpSKYP0uQZyiaZwBtOCBNJgQxaj10RWjsZu0c6I" + <> "edis4S7B_coSKB0Kj9PaPaBzg-IySRvvcQuPamQu66riMhjVtG6TlV8CLCYK" + <> "rYl52ziqK0E_ym2QnkwsUX7eYTB7LbAHRK9GqocDE5B0f808I4s\"," + <> " \"dp\":\"KkMTWqBUefVwZ2_Dbj1pPQqyHSHjj90L5x_MOzqYAJMcLMZtbUtwKqvVDq3" + <> "tbEo3ZIcohbDtt6SbfmWzggabpQxNxuBpoOOf_a_HgMXK_lhqigI4y_kqS1w" + <> "Y52IwjUn5rgRrJ-yYo1h41KR-vz2pYhEAeYrhttWtxVqLCRViD6c\"," + <> " \"dq\":\"AvfS0-gRxvn0bwJoMSnFxYcK1WnuEjQFluMGfwGitQBWtfZ1Er7t1xDkbN9" + <> "GQTB9yqpDoYaN06H7CFtrkxhJIBQaj6nkF5KKS3TQtQ5qCzkOkmxIe3KRbBy" + <> "mXxkb5qwUpX5ELD5xFc6FeiafWYY63TmmEAu_lRFCOJ3xDea-ots\"," + <> " \"qi\":\"lSQi-w9CpyUReMErP1RsBLk7wNtOvs5EQpPqmuMvqW57NBUczScEoPwmUqq" + <> "abu9V0-Py4dQ57_bapoKRu1R90bvuFnU63SHWEFglZQvJDMeAvmj4sm-Fp0o" + <> "Yu_neotgQ0hzbI5gry7ajdYy9-2lNx_76aBZoOUu9HCJ-UsfSOI8\"" + <> "}" -data LR = L | R deriving (Eq, Show) +cfrgSpec :: Spec +cfrgSpec = describe "RFC 8037 test vectors" $ do + let + _A2_jwkJson = "" + <> "{\"kty\":\"OKP\",\"crv\":\"Ed25519\"," + <> "\"x\":\"11qYAYKxCrfVS_7TyWQHOg7hcvPapiMlrwIaaPcHURo\"}" + _A1_result = eitherDecode rfc8037_A1_jwkJson :: Either String JWK + _A2_result = eitherDecode _A2_jwkJson + describe "A.1. Ed25519 Private Key" $ + it "successfully decodes the example" $ _A1_result `shouldSatisfy` is _Right + describe "A.2. Ed25519 Public Key" $ do + it "successfully decodes the example" $ _A2_result `shouldSatisfy` is _Right + it "corresponds to A.1. private key" $ Right True == do + sk <- _A1_result + pk <- _A2_result + pure $ maybe False (== pk) (view asPublicKey sk) -lr :: Either a b -> LR -lr (Left _) = L -lr _ = R +rfc8037_A1_jwkJson = "" + <> "{\"kty\":\"OKP\",\"crv\":\"Ed25519\"," + <> "\"d\":\"nWGxne_9WmC6hEr0kuwsxERJxWl7MmkZcDusAxyuf2A\"," + <> "\"x\":\"11qYAYKxCrfVS_7TyWQHOg7hcvPapiMlrwIaaPcHURo\"}" + + +#if MIN_VERSION_aeson(0,10,0) +thumbprintSpec :: Spec +thumbprintSpec = describe "JWK Thumbprint" $ do + describe "RFC 7638 §3.1. Example JWK Thumbprint Computation" $ do + let + Just k = decode $ "" + <> "{" + <> " \"kty\": \"RSA\"," + <> " \"n\": \"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx4cbbfAAt" + <> "VT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMstn6" + <> "4tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FD" + <> "W2QvzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n9" + <> "1CbOpbISD08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINH" + <> "aQ-G_xBniIqbw0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\"," + <> " \"e\": \"AQAB\"," + <> " \"alg\": \"RS256\"," + <> " \"kid\": \"2011-04-29\"" + <> "}" + it "correctly computes thumbprint of RSA key" $ + review (base64url . digest) (view thumbprint k :: Digest SHA256) + `shouldBe` ("NzbLsXh8uDCcd-6MNwXF4W_7noWXFZAfHkxZsRGC9Xs" :: B.ByteString) + describe "RFC 8037 A.3. JWK Thumbprint Canonicalization" $ do + let Just k = decode rfc8037_A1_jwkJson + it "correctly computes thumbprint of Ed25519 key" $ + review (base64url . digest) (view thumbprint k :: Digest SHA256) + `shouldBe` ("kPrK_qmxVWaYVA9wwBF6Iuo3vVzz7TxHCTwXBygrS4k" :: B.ByteString) +#endif diff --git a/test/JWS.hs b/test/JWS.hs --- a/test/JWS.hs +++ b/test/JWS.hs @@ -19,8 +19,9 @@ import Data.Maybe import Data.Monoid ((<>)) -import Control.Lens +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 @@ -33,7 +34,6 @@ import Crypto.JOSE.JWA.JWK import Crypto.JOSE.JWK import Crypto.JOSE.JWS -import Crypto.JOSE.JWS.Internal (Signature(Signature)) import qualified Crypto.JOSE.JWA.JWS as JWA.JWS import qualified Crypto.JOSE.Types as Types @@ -49,42 +49,66 @@ appendixA3Spec appendixA5Spec appendixA6Spec + cfrgSpec -- Extension of JWSHeader to test "crit" behaviour -- -newtype JWSHeader' = JWSHeader' { unJWSHeader' :: JWSHeader } +newtype JWSHeader' p = JWSHeader' { unJWSHeader' :: JWSHeader p } deriving (Eq, Show) -_JWSHeader' :: Iso' JWSHeader' JWSHeader +_JWSHeader' :: Iso' (JWSHeader' p) (JWSHeader p) _JWSHeader' = iso unJWSHeader' JWSHeader' instance HasJWSHeader JWSHeader' where - jWSHeader = _JWSHeader' + jwsHeader = _JWSHeader' instance HasParams JWSHeader' where parseParamsFor proxy hp hu = JWSHeader' <$> parseParamsFor proxy hp hu params (JWSHeader' h) = params h extensions = const ["foo"] +-- More elaborate extension of JWSHeader to test parsing behaviour +-- +data ACMEHeader p = ACMEHeader + { _acmeJwsHeader :: JWSHeader p + , _acmeNonce :: Types.Base64Octets + } deriving (Show) +acmeJwsHeader :: Lens' (ACMEHeader p) (JWSHeader p) +acmeJwsHeader f s@(ACMEHeader { _acmeJwsHeader = a}) = + fmap (\a' -> s { _acmeJwsHeader = a'}) (f a) +acmeNonce :: Lens' (ACMEHeader p) Types.Base64Octets +acmeNonce f s@(ACMEHeader { _acmeNonce = a}) = + fmap (\a' -> s { _acmeNonce = a'}) (f a) +instance HasJWSHeader ACMEHeader where + jwsHeader = acmeJwsHeader +instance HasParams ACMEHeader where + parseParamsFor proxy hp hu = ACMEHeader + <$> parseParamsFor proxy hp hu + <*> headerRequiredProtected "nonce" hp hu + params h = + (True, "nonce" .= view acmeNonce h) + : params (view acmeJwsHeader h) + extensions = const ["nonce"] + headerSpec :: Spec headerSpec = describe "JWS Header" $ do - it "parses signature correctly" $ + it "parses signature correctly" $ do let sigJSON = "{\"protected\":\"eyJhbGciOiJSUzI1NiJ9\",\ \ \"header\":{\"kid\":\"2010-12-29\"},\ \ \"signature\":\"\"}" h = newJWSHeader (Protected, JWA.JWS.RS256) - & jwsHeaderKid .~ Just (HeaderParam Unprotected "2010-12-29") - sig = Signature (Just "eyJhbGciOiJSUzI1NiJ9") h (Types.Base64Octets "") - in - eitherDecode sigJSON `shouldBe` Right sig + & kid .~ Just (HeaderParam Unprotected "2010-12-29") + sig = eitherDecode sigJSON + sig ^? _Right . header `shouldBe` Just h + sig ^? _Right . signature `shouldBe` Just ("" :: BS.ByteString) it "rejects duplicate headers" $ let -- protected header: {"kid":""} s = "{\"protected\":\"eyJraWQiOiIifQ\",\"header\":{\"alg\":\"none\",\"kid\":\"\"},\"signature\":\"\"}" in - (eitherDecode s :: Either String (Signature JWSHeader)) + (eitherDecode s :: Either String (Signature Protection JWSHeader)) `shouldSatisfy` is _Left it "rejects reserved crit parameters" $ @@ -92,7 +116,7 @@ -- protected header: {"crit":["kid"],"kid":""} s = "{\"protected\":\"eyJjcml0IjpbImtpZCJdLCJraWQiOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in - (eitherDecode s :: Either String (Signature JWSHeader)) + (eitherDecode s :: Either String (Signature Protection JWSHeader)) `shouldSatisfy` is _Left it "rejects unknown crit parameters" $ @@ -100,7 +124,7 @@ -- protected header: {"crit":["foo"],"foo":""} s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdLCJmb28iOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in - (eitherDecode s :: Either String (Signature JWSHeader)) + (eitherDecode s :: Either String (Signature Protection JWSHeader)) `shouldSatisfy` is _Left it "accepts known crit parameter in protected header" $ @@ -108,7 +132,7 @@ -- protected header: {"crit":["foo"],"foo":""} s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdLCJmb28iOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in - (eitherDecode s :: Either String (Signature JWSHeader')) + (eitherDecode s :: Either String (Signature Protection JWSHeader')) `shouldSatisfy` is _Right it "accepts known crit parameter in unprotected header" $ @@ -116,7 +140,7 @@ -- protected header: {"crit":["foo"]} s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdfQ\",\"header\":{\"alg\":\"none\",\"foo\":\"\"},\"signature\":\"\"}" in - (eitherDecode s :: Either String (Signature JWSHeader')) + (eitherDecode s :: Either String (Signature Protection JWSHeader')) `shouldSatisfy` is _Right it "rejects known crit parameter that does not appear in JOSE header" $ @@ -124,14 +148,14 @@ -- protected header: {"crit":["foo"]} s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdfQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in - (eitherDecode s :: Either String (Signature JWSHeader')) + (eitherDecode s :: Either String (Signature Protection JWSHeader')) `shouldSatisfy` is _Left it "rejects unprotected crit parameters" $ let s = "{\"header\":{\"alg\":\"none\",\"crit\":[\"foo\"],\"foo\":\"\"},\"signature\":\"\"}" in - (eitherDecode s :: Either String (Signature JWSHeader')) + (eitherDecode s :: Either String (Signature Protection JWSHeader')) `shouldSatisfy` is _Left it "rejects empty crit parameters" $ @@ -139,40 +163,71 @@ -- protected header: {"crit":[]} s = "{\"protected\":\"eyJjcml0IjpbXX0\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" in - (eitherDecode s :: Either String (Signature JWSHeader')) + (eitherDecode s :: Either String (Signature Protection 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\":\"\"}" + in + (eitherDecode s :: Either String (Signature Protection ACMEHeader)) + `shouldSatisfy` is _Right -examplePayload :: Types.Base64Octets -examplePayload = Types.Base64Octets "\ + 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)) + `shouldSatisfy` is _Left + + it "accepts unprotected \"alg\" param with 'Protection' protection indicator" $ + let + s = "{\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" + in + (eitherDecode s :: Either String (Signature Protection JWSHeader)) + `shouldSatisfy` is _Right + + it "rejects unprotected \"alg\" param with '()' protection indicator" $ + let + s = "{\"header\":{\"alg\":\"none\"},\"signature\":\"\"}" + in + (eitherDecode s :: Either String (Signature () JWSHeader)) + `shouldSatisfy` is _Left + + +examplePayloadBytes :: BS.ByteString +examplePayloadBytes = "\ \{\"iss\":\"joe\",\r\n\ \ \"exp\":1300819380,\r\n\ \ \"http://example.com/is_root\":true}" +examplePayload :: Types.Base64Octets +examplePayload = Types.Base64Octets examplePayloadBytes + appendixA1Spec :: Spec -appendixA1Spec = describe "JWS A.1. Example JWS using HMAC SHA-256" $ do +appendixA1Spec = describe "RFC 7515 A.1. Example JWS using HMAC SHA-256" $ do -- can't make aeson encode JSON to exact representation used in -- IETF doc, be we can go in reverse and then ensure that the -- round-trip checks out -- - it "decodes the example to the correct value" $ - decodeCompact compactJWS - `shouldBe` (Right jws :: Either Error (JWS JWSHeader)) + it "decodes the example to the correct value" $ do + jws ^? _Right . signatures . signature `shouldBe` Just mac + jws ^? _Right . signatures . header `shouldBe` Just h - it "round-trips correctly" $ - (encodeCompact jws >>= decodeCompact) - `shouldBe` (Right jws :: Either Error (JWS JWSHeader)) + it "serialises the decoded JWS back to the original data" $ + fmap encodeCompact jws `shouldBe` Right compactJWS it "computes the HMAC correctly" $ fst (withDRG drg $ - runExceptT (sign alg (jwk ^. jwkMaterial) (L.toStrict signingInput'))) - `shouldBe` (Right (BS.pack macOctets) :: Either Error BS.ByteString) + runExceptT (sign alg (jwk ^. jwkMaterial) (signingInput' ^. recons))) + `shouldBe` (Right mac :: Either Error BS.ByteString) it "validates the JWS correctly" $ - ( (decodeCompact compactJWS :: Either Error (JWS JWSHeader)) - >>= verifyJWS defaultValidationSettings jwk - ) `shouldSatisfy` is _Right + (jws >>= verifyJWS defaultValidationSettings jwk) + `shouldBe` Right examplePayloadBytes where signingInput' = "\ @@ -181,20 +236,15 @@ \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\ \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ" compactJWS = signingInput' <> ".dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk" - jws = JWS examplePayload [signature] - signature = Signature encodedProtectedHeader h (Types.Base64Octets mac) - encodedProtectedHeader = Just "eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9" + jws = decodeCompact compactJWS :: Either Error (CompactJWS JWSHeader) alg = JWA.JWS.HS256 - h = newJWSHeader (Protected, alg) - & jwsHeaderTyp .~ Just (HeaderParam Protected "JWT") - mac = foldr BS.cons BS.empty macOctets - macOctets = + h = newJWSHeader ((), alg) + & typ .~ Just (HeaderParam () "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, 132, 141, 121] - jwk = JWK (OctKeyMaterial octKeyMaterial) z z z z z z z z where z = Nothing - octKeyMaterial = OctKeyParameters Oct $ Types.Base64Octets $ - foldr BS.cons BS.empty + jwk = 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, @@ -202,13 +252,14 @@ appendixA2Spec :: Spec -appendixA2Spec = describe "JWS A.2. Example JWS using RSASSA-PKCS-v1_5 SHA-256" $ do +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 (jwk ^. jwkMaterial) signingInput')) `shouldBe` (Right sig :: Either Error BS.ByteString) it "validates the signature correctly" $ - verify JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput' sig `shouldBe` Right True + verify JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput' sig + `shouldBe` (Right True :: Either Error Bool) where signingInput' = "\ @@ -255,9 +306,10 @@ appendixA3Spec :: Spec -appendixA3Spec = describe "JWS A.3. Example JWS using ECDSA P-256 SHA-256" $ +appendixA3Spec = describe "RFC 7515 A.3. Example JWS using ECDSA P-256 SHA-256" $ it "validates the signature correctly" $ - verify JWA.JWS.ES256 (jwk ^. jwkMaterial) signingInput' sig `shouldBe` Right True + verify JWA.JWS.ES256 (jwk ^. jwkMaterial) signingInput' sig + `shouldBe` (Right True :: Either Error Bool) where signingInput' = "\ \eyJhbGciOiJFUzI1NiJ9\ @@ -280,16 +332,17 @@ 143, 63, 127, 138, 131, 163, 84, 213] appendixA5Spec :: Spec -appendixA5Spec = describe "JWS A.5. Example Plaintext JWS" $ do +appendixA5Spec = describe "RFC 7515 A.5. Example Unsecured JWS" $ do it "encodes the correct JWS" $ - (jws >>= encodeCompact) `shouldBe` (Right exampleJWS :: Either Error L.ByteString) + fmap encodeCompact jws `shouldBe` Right exampleJWS it "decodes the correct JWS" $ decodeCompact exampleJWS `shouldBe` jws where jws = fst $ withDRG drg $ runExceptT $ - signJWS (JWS examplePayload []) (newJWSHeader (Protected, JWA.JWS.None)) undefined + signJWS examplePayloadBytes (Identity (newJWSHeader ((), JWA.JWS.None), undefined)) + :: Either Error (CompactJWS JWSHeader) exampleJWS = "eyJhbGciOiJub25lIn0\ \.\ \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\ @@ -298,20 +351,47 @@ appendixA6Spec :: Spec -appendixA6Spec = describe "JWS A.6. Example JWS Using JWS JSON Serialization" $ - it "decodes the correct JWS" $ do - eitherDecode exampleJWS `shouldBe` Right jws - eitherDecode exampleJWS' `shouldBe` Right jws' - (eitherDecode exampleFlatJWSWithSignatures :: Either String (JWS JWSHeader)) +appendixA6Spec = describe "RFC 7515 A.6. Example JWS Using General JSON Serialization" $ do + it "decodes JWS with multiple signatures correctly" $ do + let jws = eitherDecode exampleJWSTwoSigs :: Either String (GeneralJWS JWSHeader) + lengthOf (_Right . signatures) jws `shouldBe` 2 + jws ^? _Right . signatures . header `shouldBe` Just h1' + jws ^? _Right . signatures . signature `shouldBe` Just mac1 + jws ^? _Right . dropping 1 signatures . header `shouldBe` Just h2' + jws ^? _Right . dropping 1 signatures . signature `shouldBe` Just mac2 + + it "decodes single-sig Generalised JWS correctly" $ do + let jws = eitherDecode exampleJWSOneSig :: Either String (GeneralJWS JWSHeader) + lengthOf (_Right . signatures) jws `shouldBe` 1 + jws ^? _Right . signatures . header `shouldBe` Just h2' + jws ^? _Right . signatures . signature `shouldBe` Just mac2 + + it "fails to decode single-sig Generalised JWS to 'JWS Identity'" $ do + (eitherDecode exampleJWSOneSig :: Either String (FlattenedJWS JWSHeader)) `shouldSatisfy` is _Left + it "decodes flattened JWS to 'JWS []' correctly" $ do + let jws = eitherDecode exampleJWSFlat :: Either String (GeneralJWS JWSHeader) + lengthOf (_Right . signatures) jws `shouldBe` 1 + jws ^? _Right . signatures . header `shouldBe` Just h2' + jws ^? _Right . signatures . signature `shouldBe` Just mac2 + + it "decodes flattened JWS to 'JWS Identity' correctly" $ do + let jws = eitherDecode exampleJWSFlat :: Either String (FlattenedJWS JWSHeader) + lengthOf (_Right . signatures) jws `shouldBe` 1 + jws ^? _Right . signatures . header `shouldBe` Just h2' + jws ^? _Right . signatures . signature `shouldBe` Just mac2 + + it "fails to decode flattened JWS when \"signatures\" key is present" $ do + (eitherDecode exampleFlatJWSWithSignatures :: Either String (GeneralJWS JWSHeader)) + `shouldSatisfy` is _Left + (eitherDecode exampleFlatJWSWithSignatures :: Either String (FlattenedJWS JWSHeader)) + `shouldSatisfy` is _Left + where - jws = JWS examplePayload [sig1, sig2] - jws' = JWS examplePayload [sig2] - sig1 = Signature Nothing h1' (Types.Base64Octets mac1) h1 = newJWSHeader (Protected, JWA.JWS.RS256) - h1' = h1 & jwsHeaderKid .~ Just (HeaderParam Unprotected "2010-12-29") - mac1 = foldr BS.cons BS.empty + h1' = h1 & kid .~ Just (HeaderParam Unprotected "2010-12-29") + mac1 = view recons [112, 46, 33, 137, 67, 232, 143, 209, 30, 181, 216, 45, 191, 120, 69, 243, 65, 6, 174, 27, 129, 255, 247, 115, 17, 22, 173, 209, 113, 125, 131, 101, 109, 66, 10, 253, 60, 150, 238, 221, 115, 162, 102, 62, 81, @@ -329,15 +409,14 @@ 34, 165, 68, 200, 242, 122, 122, 45, 184, 6, 99, 209, 108, 247, 202, 234, 86, 222, 64, 92, 178, 33, 90, 69, 178, 194, 85, 102, 181, 90, 193, 167, 72, 160, 112, 223, 200, 163, 42, 70, 149, 67, 208, 25, 238, - 251, 71] - sig2 = Signature Nothing h2' (Types.Base64Octets mac2) + 251, 71] :: BS.ByteString h2 = newJWSHeader (Protected, JWA.JWS.ES256) - h2' = h2 & jwsHeaderKid .~ Just (HeaderParam Unprotected "e9bc097a-ce51-4036-9562-d2ade882db0d") + h2' = h2 & kid .~ Just (HeaderParam Unprotected "e9bc097a-ce51-4036-9562-d2ade882db0d") mac2 = B64U.decodeLenient "DtEhU3ljbEg8L38VWAfUAqOyKAM6-Xx-F4GawxaepmXFCgfTjDxw5djxLa8ISlSA\ \pmWQxfKTUJqPP3-Kg6NU1Q" - exampleJWS = "\ + exampleJWSTwoSigs = "\ \{\"payload\":\ \ \"eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGF\ \tcGxlLmNvbS9pc19yb290Ijp0cnVlfQ\",\ @@ -359,7 +438,19 @@ \ \"DtEhU3ljbEg8L38VWAfUAqOyKAM6-Xx-F4GawxaepmXFCgfTjDxw5djxLa8IS\ \lSApmWQxfKTUJqPP3-Kg6NU1Q\"}]\ \}" - exampleJWS' = "\ + exampleJWSOneSig = "\ + \{\"payload\":\ + \ \"eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGF\ + \tcGxlLmNvbS9pc19yb290Ijp0cnVlfQ\",\ + \ \"signatures\":[\ + \ {\"protected\":\"eyJhbGciOiJFUzI1NiJ9\",\ + \ \"header\":\ + \ {\"kid\":\"e9bc097a-ce51-4036-9562-d2ade882db0d\"},\ + \ \"signature\":\ + \ \"DtEhU3ljbEg8L38VWAfUAqOyKAM6-Xx-F4GawxaepmXFCgfTjDxw5djxLa8IS\ + \lSApmWQxfKTUJqPP3-Kg6NU1Q\"}]\ + \}" + exampleJWSFlat = "\ \{\ \ \"payload\":\ \ \"eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGF\ @@ -384,3 +475,24 @@ \lSApmWQxfKTUJqPP3-Kg6NU1Q\",\ \ \"signatures\":\"bogus\"\ \}" + +cfrgSpec :: Spec +cfrgSpec = describe "RFC 8037 signature/validation test vectors" $ do + let + jwk = fromJust $ decode "\ + \{\"kty\":\"OKP\",\"crv\":\"Ed25519\",\ + \\"d\":\"nWGxne_9WmC6hEr0kuwsxERJxWl7MmkZcDusAxyuf2A\",\ + \\"x\":\"11qYAYKxCrfVS_7TyWQHOg7hcvPapiMlrwIaaPcHURo\"}" + sigOctets = + [0x86,0x0c,0x98,0xd2,0x29,0x7f,0x30,0x60,0xa3,0x3f,0x42,0x73,0x96,0x72,0xd6,0x1b + ,0x53,0xcf,0x3a,0xde,0xfe,0xd3,0xd3,0xc6,0x72,0xf3,0x20,0xdc,0x02,0x1b,0x41,0x1e + ,0x9d,0x59,0xb8,0x62,0x8d,0xc3,0x51,0xe2,0x48,0xb8,0x8b,0x29,0x46,0x8e,0x0e,0x41 + ,0x85,0x5b,0x0f,0xb7,0xd8,0x3b,0xb1,0x5b,0xe9,0x02,0xbf,0xcc,0xb8,0xcd,0x0a,0x02] + sig = BS.pack sigOctets + signingInput = "eyJhbGciOiJFZERTQSJ9.RXhhbXBsZSBvZiBFZDI1NTE5IHNpZ25pbmc" + it "computes the correct signature" $ + fst (withDRG drg $ runExceptT (sign JWA.JWS.EdDSA (view jwkMaterial jwk) signingInput)) + `shouldBe` (Right sig :: Either Error BS.ByteString) + it "validates signatures correctly" $ + verify JWA.JWS.EdDSA (view jwkMaterial jwk) signingInput sig + `shouldBe` (Right True :: Either Error Bool) diff --git a/test/JWT.hs b/test/JWT.hs --- a/test/JWT.hs +++ b/test/JWT.hs @@ -35,7 +35,6 @@ import Safe (headMay) import Test.Hspec -import Crypto.JOSE import Crypto.JWT @@ -47,7 +46,7 @@ exampleClaimsSet :: ClaimsSet exampleClaimsSet = emptyClaimsSet - & claimIss .~ Just (fromString "joe") + & claimIss .~ preview stringOrUri ("joe" :: String) & claimExp .~ intDate "2011-03-22 18:43:00" & over unregisteredClaims (insert "http://example.com/is_root" (Bool True)) & addClaim "http://example.com/is_root" (Bool True) @@ -57,7 +56,8 @@ spec :: Spec spec = do - let conf = set algorithms (S.singleton None) defaultJWTValidationSettings + let conf = set algorithms (S.singleton None) + (defaultJWTValidationSettings (const False)) describe "JWT Claims Set" $ do it "parses from JSON correctly" $ @@ -77,7 +77,7 @@ let now = utcTime "2010-01-01 00:00:00" it "can be validated" $ runReaderT (validateClaimsSet conf exampleClaimsSet) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet) describe "when the current time is exactly the Expiration Time" $ do let now = utcTime "2011-03-22 18:43:00" @@ -97,31 +97,30 @@ it "can be validated if nonzero skew tolerance = delta" $ let conf' = set allowedSkew 2 conf in runReaderT (validateClaimsSet conf' exampleClaimsSet) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet) it "can be validated if nonzero skew tolerance > delta" $ let conf' = set allowedSkew 3 conf in runReaderT (validateClaimsSet conf' exampleClaimsSet) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet) it "can be validated if negative skew tolerance = -delta" $ let conf' = set allowedSkew (-2) conf in runReaderT (validateClaimsSet conf' exampleClaimsSet) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet) describe "with an Issued At claim" $ do let claimsSetWithIat = set claimIat (intDate "2011-02-22 18:43:00") emptyClaimsSet - let conf = set checkIssuedAt True defaultJWTValidationSettings describe "when the current time is after to the Issued At" $ do let now = utcTime "2011-03-01 00:00:00" it "can be validated" $ runReaderT (validateClaimsSet conf claimsSetWithIat) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet) describe "when the current time is exactly the Issued At" $ do let now = utcTime "2011-02-22 18:43:00" it "can be validated" $ runReaderT (validateClaimsSet conf claimsSetWithIat) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet) describe "when the current time is prior to the Issued At" $ do let now = utcTime "2011-02-22 18:42:59" -- 1s before issued at @@ -132,19 +131,19 @@ it "can be validated if nonzero skew tolerance < delta but validation is off" $ let conf' = set checkIssuedAt False conf in runReaderT (validateClaimsSet conf' claimsSetWithIat) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet) it "can be validated if nonzero skew tolerance = delta" $ let conf' = set allowedSkew 1 conf in runReaderT (validateClaimsSet conf' claimsSetWithIat) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet) it "can be validated if nonzero skew tolerance > delta" $ let conf' = set allowedSkew 2 conf in runReaderT (validateClaimsSet conf' claimsSetWithIat) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet) it "can be validated if negative skew tolerance = -delta" $ let conf' = set allowedSkew (-1) conf in runReaderT (validateClaimsSet conf' claimsSetWithIat) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet) describe "with a Not Before claim" $ do let @@ -161,25 +160,25 @@ it "can be validated if nonzero skew tolerance = delta" $ let conf' = set allowedSkew 2 conf in runReaderT (validateClaimsSet conf' claimsSet) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claimsSet :: 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 () :: Either JWTError ()) + `shouldBe` (Right claimsSet :: 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 () :: Either JWTError ()) + `shouldBe` (Right claimsSet :: 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 () :: Either JWTError ()) + `shouldBe` (Right claimsSet :: 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 () :: Either JWTError ()) + `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet) describe "with Expiration Time and Not Before claims" $ do let @@ -192,11 +191,11 @@ 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 () :: Either JWTError ()) + `shouldBe` (Right claimsSet :: 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 () :: Either JWTError ()) + `shouldBe` (Right claimsSet :: 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") @@ -224,7 +223,7 @@ let claims = emptyClaimsSet & set claimAud (Just (Audience ["foo", "bar", "baz"])) it "can be validated" $ runReaderT (validateClaimsSet conf' claims) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claims :: Either JWTError ClaimsSet) describe "when claim is empty, and predicate is unconditionally true" $ do let claims = emptyClaimsSet & set claimAud (Just (Audience [])) it "cannot be validated" $ @@ -243,7 +242,7 @@ let claims = emptyClaimsSet & set claimIss (Just "baz") it "can be validated" $ runReaderT (validateClaimsSet conf' claims) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claims :: Either JWTError ClaimsSet) describe "when issuer is nonempty but predicate is not matched" $ do let claims = emptyClaimsSet & set claimIss (Just "bar") it "cannot be validated" $ @@ -253,12 +252,12 @@ let claims = emptyClaimsSet & set claimIss (Just "") it "can be validated" $ runReaderT (validateClaimsSet conf claims) now - `shouldBe` (Right () :: Either JWTError ()) + `shouldBe` (Right claims :: Either JWTError ClaimsSet) describe "StringOrURI" $ it "parses from JSON correctly" $ do - (decode "[\"foo\"]" >>= headMay >>= getString) `shouldBe` Just "foo" - (decode "[\"http://example.com\"]" >>= headMay >>= getURI) + (decode "[\"foo\"]" >>= headMay >>= preview string) `shouldBe` Just "foo" + (decode "[\"http://example.com\"]" >>= headMay >>= preview uri) `shouldBe` parseURI "http://example.com" decode "[\":\"]" `shouldBe` (Nothing :: Maybe [StringOrURI]) decode "[12345]" `shouldBe` (Nothing :: Maybe [StringOrURI]) @@ -269,7 +268,7 @@ decode "[1382245921]" `shouldBe` fmap (:[]) (intDate "2013-10-20 05:12:01") decode "[\"notnum\"]" `shouldBe` (Nothing :: Maybe [NumericDate]) - describe "§6.1. Example Unsecured JWT" $ do + describe "RFC 7519 §6.1. Example Unsecured JWT" $ do let exampleJWT = "eyJhbGciOiJub25lIn0\ \.\ @@ -277,21 +276,21 @@ \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ\ \." jwt = decodeCompact exampleJWT - k = fromJust $ decode "{\"kty\":\"oct\",\"k\":\"\"}" + k = fromJust $ decode "{\"kty\":\"oct\",\"k\":\"\"}" :: JWK describe "when the current time is prior to the Expiration Time" $ it "can be decoded and validated" $ do - runReaderT (jwt >>= validateJWSJWT conf k) (utcTime "2010-01-01 00:00:00") - `shouldBe` (Right () :: Either JWTError ()) + runReaderT (jwt >>= verifyClaims conf k) (utcTime "2010-01-01 00:00:00") + `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet) describe "when the current time is after the Expiration Time" $ it "can be decoded, but not validated" $ do - runReaderT (jwt >>= validateJWSJWT conf k) (utcTime "2012-01-01 00:00:00") + runReaderT (jwt >>= verifyClaims conf k) (utcTime "2012-01-01 00:00:00") `shouldBe` Left JWTExpired describe "when signature is invalid and token is expired" $ it "fails on sig validation (claim validation not reached)" $ do let jwt' = decodeCompact (exampleJWT <> "badsig") - (runReaderT (jwt' >>= validateJWSJWT conf k) (utcTime "2012-01-01 00:00:00") - :: Either JWTError ()) + (runReaderT (jwt' >>= verifyClaims conf k) (utcTime "2012-01-01 00:00:00") + :: Either JWTError ClaimsSet) `shouldSatisfy` is (_Left . _JWSInvalidSignature) diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -27,7 +27,7 @@ import Test.QuickCheck.Monadic import Test.QuickCheck.Instances () -import Crypto.JOSE.Error (Error) +import Crypto.JOSE.Error (Error(..)) import Crypto.JOSE.Types import Crypto.JOSE.JWK import Crypto.JOSE.JWS @@ -60,22 +60,23 @@ k :: JWK <- run $ genJWK (RSAGenParam keylen) alg <- pick $ elements [RS256, RS384, RS512, PS256, PS384, PS512] monitor (collect alg) - wp (runExceptT (signJWS (newJWS msg) (newJWSHeader (Protected, alg)) k - >>= verifyJWS defaultValidationSettings k)) checkSignVerifyResult + wp (runExceptT (signJWS msg [(newJWSHeader (Protected, alg), k)] + >>= verifyJWS defaultValidationSettings k)) (checkSignVerifyResult msg) prop_bestJWSAlg :: B.ByteString -> Property prop_bestJWSAlg msg = monadicIO $ do genParam <- pick arbitrary k <- run $ genJWK genParam case bestJWSAlg k of - Left (_ :: Error) -> assert False + Left (KeyMismatch _) -> pre False -- skip non-signing keys + Left _ -> assert False Right alg -> do monitor (collect alg) let go = do - jws <- signJWS (newJWS msg) (newJWSHeader (Protected, alg)) k + jws <- signJWS msg [(newJWSHeader (Protected, alg), k)] verifyJWS defaultValidationSettings k jws - wp (runExceptT go) checkSignVerifyResult + wp (runExceptT go) (checkSignVerifyResult msg) -checkSignVerifyResult :: Monad m => Either Error a -> PropertyM m () -checkSignVerifyResult = assert . either (const False) (const True) +checkSignVerifyResult :: Monad m => B.ByteString -> Either Error B.ByteString -> PropertyM m () +checkSignVerifyResult msg = assert . either (const False) (== msg)