jose 0.5.0.5 → 0.6.0.0

raw patch · 26 files changed

+2064/−1154 lines, 26 filesdep +bifunctorsdep +concisedep −byteabledep ~basedep ~semigroupsdep ~template-haskell

Dependencies added: bifunctors, concise

Dependencies removed: byteable

Dependency ranges changed: base, semigroups, template-haskell

Files

• README.md +9/−4
• example/JWS.hs +44/−0
• example/Main.hs +50/−18
• jose.cabal +36/−25
• src/Crypto/JOSE.hs +3/−0
• src/Crypto/JOSE/Compact.hs +3/−3
• src/Crypto/JOSE/Error.hs +1/−1
• src/Crypto/JOSE/Header.hs +222/−36
• src/Crypto/JOSE/JWA/JWE.hs +5/−6
• src/Crypto/JOSE/JWA/JWE/Alg.hs +1/−1
• src/Crypto/JOSE/JWA/JWK.hs +182/−79
• src/Crypto/JOSE/JWA/JWS.hs +2/−1
• src/Crypto/JOSE/JWE.hs +39/−36
• src/Crypto/JOSE/JWK.hs +100/−14
• src/Crypto/JOSE/JWK/Store.hs +52/−0
• src/Crypto/JOSE/JWS.hs +572/−16
• src/Crypto/JOSE/JWS/Internal.hs +0/−332
• src/Crypto/JOSE/Legacy.hs +0/−117
• src/Crypto/JOSE/TH.hs +1/−3
• src/Crypto/JOSE/Types.hs +1/−5
• src/Crypto/JOSE/Types/Internal.hs +41/−4
• src/Crypto/JWT.hs +257/−175
• test/JWK.hs +226/−173
• test/JWS.hs +176/−64
• test/JWT.hs +32/−33
• test/Properties.hs +9/−8

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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) #-}

@@ -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

@@ -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 

@@ -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))

@@ -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

@@ -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.

@@ -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     )

@@ -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)   ])

@@ -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"

@@ -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

@@ -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)

@@ -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+<https://tools.ietf.org/html/rfc7515 RFC 7515>. +@+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

@@ -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

@@ -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

@@ -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]

@@ -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)

@@ -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.

@@ -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.+--+-- <https://tools.ietf.org/html/rfc7519#section-4.1.3 RFC 7519 §4.1.3.>+-- 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))

@@ -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

@@ -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)

@@ -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)

@@ -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)