jose 0.7.0.0 → 0.8.0.0

raw patch · 17 files changed

+525/−240 lines, 17 filesdep +unixdep ~semigroupsdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: unix

Dependency ranges changed: semigroups, text

API changes (from Hackage documentation)

Files

• README.md +16/−4
• example/JWS.hs +2/−2
• example/KeyDB.hs +40/−0
• example/Main.hs +21/−9
• jose.cabal +8/−3
• src/Crypto/JOSE/Error.hs +64/−3
• src/Crypto/JOSE/Header.hs +7/−4
• src/Crypto/JOSE/JWA/JWK.hs +26/−17
• src/Crypto/JOSE/JWE.hs +8/−7
• src/Crypto/JOSE/JWK.hs +67/−5
• src/Crypto/JOSE/JWK/Store.hs +58/−27
• src/Crypto/JOSE/JWS.hs +110/−75
• src/Crypto/JOSE/Types.hs +1/−0
• src/Crypto/JWT.hs +31/−43
• test/JWK.hs +49/−21
• test/JWS.hs +15/−18
• test/JWT.hs +2/−2

@@ -56,10 +56,22 @@   The datum [should be a base64url-encoded SHA-1 digest](   https://tools.ietf.org/html/rfc7515#section-4.1.7), but *Auth0*   produces a base64url-encoded hex-encoded SHA-1 digest.  The object-  can be repaired so that this library will admit it, unless the-  offending parameter is part of the *JWS Protected Header* in which-  case you are out of luck until *Auth0* bring their implementation-  into compliance.+  can be repaired+  ([example](https://github.com/frasertweedale/hs-jose/issues/54#issuecomment-356460452))+  so that this library will admit it, unless the offending parameter+  is part of the *JWS Protected Header* in which case you are out of+  luck (until *Auth0* bring their implementation into compliance).++- JWKs with leading null bytes in the RSA `"n"` parameter (a+  [violation of RFC+  7518](https://tools.ietf.org/html/rfc7518#section-2)) have been+  [seen in the+  wild](https://github.com/frasertweedale/hs-jose/issues/68).  This+  library rejects nonconformant JWKs.  If you know which+  programs/libraries produce such objects, please file bugs against+  them.  It is straightforward to repair these keys:+  base64url-decode the offending parameter, drop the leading null+  byte, base64url-encode again then update the JSON object.   ## Contributing

@@ -20,8 +20,8 @@   Just jwk <- decode <$> L.readFile jwkFilename   payload <- L.readFile payloadFilename   result <- runExceptT $ do-    alg <- bestJWSAlg jwk-    signJWS payload [(newJWSHeader (Protected, alg), jwk)]+    h <- makeJWSHeader jwk+    signJWS payload [(h :: JWSHeader Protection, jwk)]   case result of     Left e -> print (e :: Error) >> exitFailure     Right jws -> L.putStr (encode jws)

@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++module KeyDB+  (+    KeyDB(..)+  ) where++import Control.Exception (IOException, handle)+import Data.Maybe (catMaybes)+import Data.Semigroup ((<>))++import Control.Monad.Trans (MonadIO(..))+import Control.Lens (_Just, preview)+import Data.Aeson (decode)+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T++import Crypto.JWT++-- | A KeyDB is just a directory+--+newtype KeyDB = KeyDB FilePath++-- | Looks for a key in the directory, based on the @"kid"@ field of+-- the 'JWSHeader' or the @"iss"@ field of the JWT 'ClaimsSet'+--+instance (MonadIO m, HasKid h)+    => VerificationKeyStore m (h p) ClaimsSet KeyDB where+  getVerificationKeys h claims (KeyDB dir) = liftIO $+    fmap catMaybes . traverse findKey $ catMaybes+      [ preview (kid . _Just . param) h+      , preview (claimIss . _Just . string) claims]+    where+    findKey s =+      let path = dir <> "/" <> T.unpack s <> ".jwk"+      in handle+        (\(_ :: IOException) -> pure Nothing)+        (decode <$> L.readFile path)

@@ -1,13 +1,16 @@ {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}  import Data.Maybe (fromJust)+import Data.Semigroup ((<>)) import System.Environment (getArgs)-import System.Exit (exitFailure)+import System.Exit (die, exitFailure)  import qualified Data.ByteString.Lazy as L-import Data.Aeson (decode, encode)+import Data.Aeson (decode, eitherDecode, encode) import Data.Text.Strict.Lens (utf8)+import System.Posix.Files (getFileStatus, isDirectory)  import Control.Monad.Except (runExceptT) import Control.Lens (preview, re, review, set, view)@@ -15,6 +18,7 @@ import Crypto.JWT  import JWS (doJwsSign, doJwsVerify)+import KeyDB  main :: IO () main = do@@ -57,9 +61,7 @@ doJwtSign [jwkFilename, claimsFilename] = do   Just k <- decode <$> L.readFile jwkFilename   Just claims <- decode <$> L.readFile claimsFilename-  result <- runExceptT $ do-    alg' <- bestJWSAlg k-    signClaims k (newJWSHeader ((), alg')) claims+  result <- runExceptT $ makeJWSHeader k >>= \h -> signClaims k h claims   case result of     Left e -> print (e :: Error) >> exitFailure     Right jwt -> L.putStr (encodeCompact jwt)@@ -78,16 +80,26 @@ -- doJwtVerify :: [String] -> IO () doJwtVerify [jwkFilename, jwtFilename, aud] = do+  jwtData <- L.readFile jwtFilename   let     aud' = fromJust $ preview stringOrUri aud     conf = defaultJWTValidationSettings (== aud')-  Just k <- decode <$> L.readFile jwkFilename-  jwtData <- L.readFile jwtFilename-  result <- runExceptT-    (decodeCompact jwtData >>= verifyClaims conf (k :: JWK))+    go k = runExceptT (decodeCompact jwtData >>= verifyClaims conf k)++  jwkDir <- isDirectory <$> getFileStatus jwkFilename+  result <-+    if jwkDir+    then go (KeyDB jwkFilename)+    else (eitherDecode <$> L.readFile jwkFilename :: IO (Either String JWK))+      >>= rightOrDie "Failed to decode JWK"+      >>= go+   case result of     Left e -> print (e :: JWTError) >> exitFailure     Right claims -> L.putStr $ encode claims++rightOrDie :: (Show e) => String -> Either e a -> IO a+rightOrDie s = either (die . (\e -> s <> ": " <> show e)) pure   #if MIN_VERSION_aeson(0,10,0)

@@ -1,5 +1,5 @@ name:                jose-version:             0.7.0.0+version:             0.8.0.0 synopsis:   Javascript Object Signing and Encryption and JSON Web Token library description:@@ -26,12 +26,12 @@   README.md author:              Fraser Tweedale maintainer:          frase@frase.id.au-copyright:           Copyright (C) 2013, 2014, 2015, 2016, 2017  Fraser Tweedale+copyright:           Copyright (C) 2013-2018  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.2, GHC==8.4.1+  GHC==7.10.3, GHC==8.0.1, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.1  library   exposed-modules:@@ -137,11 +137,16 @@   ghc-options:    -Wall   main-is:  Main.hs   other-modules:+    KeyDB     JWS+   build-depends:     base     , aeson     , bytestring     , lens     , mtl+    , semigroups+    , text+    , unix     , jose

@@ -26,26 +26,87 @@   (     Error(..)   , AsError(..)++  -- * JOSE compact serialisation errors+  , InvalidNumberOfParts(..), expectedParts, actualParts+  , CompactTextError(..)+  , CompactDecodeError(..)+  , _CompactInvalidNumberOfParts+  , _CompactInvalidText   ) where +import Data.Semigroup ((<>))+import Numeric.Natural+ import Control.Monad.Trans (MonadTrans(..)) import qualified Crypto.PubKey.RSA as RSA import Crypto.Error (CryptoError) import Crypto.Random (MonadRandom(..))-import Control.Lens.TH (makeClassyPrisms)+import Control.Lens (Getter, to)+import Control.Lens.TH (makeClassyPrisms, makePrisms)+import qualified Data.Text as T+import qualified Data.Text.Encoding.Error as T ++-- | The wrong number of parts were found when decoding a+-- compact JOSE object.+--+data InvalidNumberOfParts =+  InvalidNumberOfParts Natural Natural -- ^ expected vs actual parts+  deriving (Eq)++instance Show InvalidNumberOfParts where+  show (InvalidNumberOfParts n m) =+    "Expected " <> show n <> " parts; got " <> show m++-- | Get the expected or actual number of parts.+expectedParts, actualParts :: Getter InvalidNumberOfParts Natural+expectedParts = to $ \(InvalidNumberOfParts n _) -> n+actualParts   = to $ \(InvalidNumberOfParts _ n) -> n+++-- | Bad UTF-8 data in a compact object, at the specified index+data CompactTextError = CompactTextError+  Natural+  T.UnicodeException+  deriving (Eq)++instance Show CompactTextError where+  show (CompactTextError n s) =+    "Invalid text at part " <> show n <> ": " <> show s+++-- | An error when decoding a JOSE compact object.+-- JSON decoding errors that occur during compact object processing+-- throw 'JSONDecodeError'.+--+data CompactDecodeError+  = CompactInvalidNumberOfParts InvalidNumberOfParts+  | CompactInvalidText CompactTextError+  deriving (Eq)+makePrisms ''CompactDecodeError++instance Show CompactDecodeError where+  show err = "CompactDecodeError: " <> case err of+    CompactInvalidNumberOfParts e -> show e+    CompactInvalidText e        -> show e+++ -- | All the errors that can occur. -- data Error   = AlgorithmNotImplemented   -- ^ A requested algorithm is not implemented   | AlgorithmMismatch String  -- ^ A requested algorithm cannot be used-  | KeyMismatch String        -- ^ Wrong type of key was given+  | KeyMismatch T.Text        -- ^ Wrong type of key was given   | KeySizeTooSmall           -- ^ Key size is too small   | 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-  | CompactDecodeError String -- ^ Cannot decode compact representation+  | CompactDecodeError CompactDecodeError+  -- ^ Wrong number of parts in compact serialisation   | JSONDecodeError String    -- ^ JSON (Aeson) decoding error+  | NoUsableKeys              -- ^ No usable keys were found in the key store   | JWSCritUnprotected   | JWSNoValidSignatures   -- ^ 'AnyValidated' policy active, and no valid signature encountered

@@ -163,6 +163,9 @@ data HeaderParam p a = HeaderParam p a   deriving (Eq, Show) +instance Functor (HeaderParam p) where+  fmap f (HeaderParam p a) = HeaderParam p (f a)+ -- | 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)@@ -319,13 +322,13 @@   jwk :: Lens' (a p) (Maybe (HeaderParam p JWK))  class HasKid a where-  kid :: Lens' (a p) (Maybe (HeaderParam p String))+  kid :: Lens' (a p) (Maybe (HeaderParam p T.Text))  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)))+  x5c :: Lens' (a p) (Maybe (HeaderParam p (NonEmpty Types.SignedCertificate)))  class HasX5t a where   x5t :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA1))@@ -334,10 +337,10 @@   x5tS256 :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA256))  class HasTyp a where-  typ :: Lens' (a p) (Maybe (HeaderParam p String))+  typ :: Lens' (a p) (Maybe (HeaderParam p T.Text))  class HasCty a where-  cty :: Lens' (a p) (Maybe (HeaderParam p String))+  cty :: Lens' (a p) (Maybe (HeaderParam p T.Text))  class HasCrit a where   crit :: Lens' (a p) (Maybe (NonEmpty T.Text))

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014, 2015, 2016, 2017  Fraser Tweedale+-- Copyright (C) 2013-2018  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -44,6 +44,7 @@   , RSAPrivateKeyParameters(..)   , RSAKeyParameters(RSAKeyParameters)   , toRSAKeyParameters+  , toRSAPublicKeyParameters   , rsaE   , rsaN   , rsaPrivateKeyParameters@@ -160,7 +161,7 @@     o .:? "oth")  instance ToJSON RSAPrivateKeyOptionalParameters where-  toJSON (RSAPrivateKeyOptionalParameters {..}) = object $ [+  toJSON RSAPrivateKeyOptionalParameters{..} = object $ [     "p" .= rsaP     , "q" .= rsaQ     , "dp" .= rsaDp@@ -351,14 +352,19 @@ genRSA size = toRSAKeyParameters . snd <$> RSA.generate size 65537  toRSAKeyParameters :: RSA.PrivateKey -> RSAKeyParameters-toRSAKeyParameters (RSA.PrivateKey (RSA.PublicKey _ n e) d p q dp dq qi) =+toRSAKeyParameters priv@(RSA.PrivateKey pub _ _ _ _ _ _) =+  toRSAPublicKeyParameters pub+  & set rsaPrivateKeyParameters (pure $ toRSAPrivateKeyParameters priv)++toRSAPublicKeyParameters :: RSA.PublicKey -> RSAKeyParameters+toRSAPublicKeyParameters (RSA.PublicKey _ n e) =+  RSAKeyParameters (Types.Base64Integer n) (Types.Base64Integer e) Nothing++toRSAPrivateKeyParameters :: RSA.PrivateKey -> RSAPrivateKeyParameters+toRSAPrivateKeyParameters (RSA.PrivateKey _ d p q dp dq qi) =   let i = Types.Base64Integer-  in RSAKeyParameters-    ( i n )-    ( i e )-    ( Just (RSAPrivateKeyParameters (i d)-      (Just (RSAPrivateKeyOptionalParameters-        (i p) (i q) (i dp) (i dq) (i qi) Nothing))) )+  in RSAPrivateKeyParameters (i d)+      (Just (RSAPrivateKeyOptionalParameters (i p) (i q) (i dp) (i dq) (i qi) Nothing))  signPKCS15   :: (PKCS15.HashAlgorithmASN1 h, MonadRandom m, MonadError e m, AsError e)@@ -555,17 +561,20 @@   deriving (Eq, Show)  showKeyType :: KeyMaterial -> String-showKeyType (ECKeyMaterial (ECKeyParameters { _ecCrv = crv })) = "ECDSA (" ++ show crv ++ ")"+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)+    case M.lookup "kty" o of+      Nothing     -> fail "missing \"kty\" parameter"+      Just "EC"   -> ECKeyMaterial  <$> parseJSON (Object o)+      Just "RSA"  -> RSAKeyMaterial <$> parseJSON (Object o)+      Just "oct"  -> OctKeyMaterial <$> parseJSON (Object o)+      Just "OKP"  -> OKPKeyMaterial <$> parseJSON (Object o)+      Just s      -> fail $ "unsupported \"kty\": " <> show s  instance ToJSON KeyMaterial where   toJSON (ECKeyMaterial p)  = object $ Types.objectPairs (toJSON p)@@ -608,9 +617,9 @@   -> B.ByteString   -> m B.ByteString sign JWA.JWS.None _ = \_ -> return ""-sign JWA.JWS.ES256 (ECKeyMaterial k@(ECKeyParameters { _ecCrv = P_256 })) = signEC SHA256 k-sign JWA.JWS.ES384 (ECKeyMaterial k@(ECKeyParameters { _ecCrv = P_384 })) = signEC SHA384 k-sign JWA.JWS.ES512 (ECKeyMaterial k@(ECKeyParameters { _ecCrv = P_521 })) = signEC SHA512 k+sign JWA.JWS.ES256 (ECKeyMaterial k@ECKeyParameters{ _ecCrv = P_256 }) = signEC SHA256 k+sign JWA.JWS.ES384 (ECKeyMaterial k@ECKeyParameters{ _ecCrv = P_384 }) = signEC SHA384 k+sign JWA.JWS.ES512 (ECKeyMaterial k@ECKeyParameters{ _ecCrv = P_521 }) = signEC SHA512 k sign JWA.JWS.RS256 (RSAKeyMaterial k) = signPKCS15 SHA256 k sign JWA.JWS.RS384 (RSAKeyMaterial k) = signPKCS15 SHA384 k sign JWA.JWS.RS512 (RSAKeyMaterial k) = signPKCS15 SHA512 k

@@ -68,16 +68,16 @@ data JWEHeader p = JWEHeader   { _jweAlg :: Maybe AlgWithParams   , _jweEnc :: HeaderParam p Enc-  , _jweZip :: Maybe String  -- protected header only  "DEF" (DEFLATE) defined+  , _jweZip :: Maybe T.Text  -- protected header only  "DEF" (DEFLATE) defined   , _jweJku :: Maybe (HeaderParam p Types.URI)   , _jweJwk :: Maybe (HeaderParam p JWK)-  , _jweKid :: Maybe (HeaderParam p String)+  , _jweKid :: Maybe (HeaderParam p T.Text)   , _jweX5u :: Maybe (HeaderParam p Types.URI)-  , _jweX5c :: Maybe (HeaderParam p (NonEmpty Types.Base64X509))+  , _jweX5c :: Maybe (HeaderParam p (NonEmpty Types.SignedCertificate))   , _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)+  , _jweTyp :: Maybe (HeaderParam p T.Text)  -- ^ Content Type (of object)+  , _jweCty :: Maybe (HeaderParam p T.Text)  -- ^ Content Type (of payload)   , _jweCrit :: Maybe (NonEmpty T.Text)   }   deriving (Eq, Show)@@ -96,7 +96,8 @@     <*> headerOptional "jwk" hp hu     <*> headerOptional "kid" hp hu     <*> headerOptional "x5u" hp hu-    <*> headerOptional "x5c" hp hu+    <*> ((fmap . fmap . fmap . fmap)+          (\(Types.Base64X509 cert) -> cert) (headerOptional "x5c" hp hu))     <*> headerOptional "x5t" hp hu     <*> headerOptional "x5t#S256" hp hu     <*> headerOptional "typ" hp hu@@ -113,7 +114,7 @@       , 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, "x5c" .= fmap Types.Base64X509 (view param p))) x5c       , fmap (\p -> (view isProtected p, "x5t" .= view param p)) x5t       , fmap (\p -> (view isProtected p, "x5t#S256" .= view param p)) x5tS256       , fmap (\p -> (view isProtected p, "typ" .= view param p)) typ

@@ -62,6 +62,7 @@   , jwkKid   , jwkX5u   , jwkX5c+  , setJWKX5c   , jwkX5t   , jwkX5tS256 @@ -69,6 +70,7 @@   , fromKeyMaterial   , fromRSA   , fromOctets+  , fromX509Certificate  #if MIN_VERSION_aeson(0,10,0)   -- * JWK Thumbprint@@ -88,6 +90,8 @@   ) where  import Control.Applicative+import Control.Monad ((>=>))+import Data.Function (on) import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Word (Word8)@@ -104,6 +108,7 @@ import qualified Data.ByteString.Builder as Builder import Data.List.NonEmpty import qualified Data.Text as T+import qualified Data.X509 as X509  import Test.QuickCheck @@ -157,33 +162,62 @@   , _jwkAlg :: Maybe JWKAlg   , _jwkKid :: Maybe T.Text   , _jwkX5u :: Maybe Types.URI-  , _jwkX5c :: Maybe (NonEmpty Types.Base64X509)+  , _jwkX5cRaw :: Maybe (NonEmpty X509.SignedCertificate)   , _jwkX5t :: Maybe Types.Base64SHA1   , _jwkX5tS256 :: Maybe Types.Base64SHA256   }   deriving (Eq, Show) makeLenses ''JWK +-- | Get the certificate chain.  Not a lens, because the key of the first+-- certificate in the chain must correspond be the public key of the JWK.+-- To set the certificate chain use 'setJWKX5c'.+--+jwkX5c :: Getter JWK (Maybe (NonEmpty X509.SignedCertificate))+jwkX5c = jwkX5cRaw++-- | Set the @"x5c"@ Certificate Chain parameter.  If setting the list,+-- checks that the key in the first certificate matches the JWK; returns+-- @Nothing@ if it does not.+--+setJWKX5c :: Maybe (NonEmpty X509.SignedCertificate) -> JWK -> Maybe JWK+setJWKX5c Nothing k = pure (set jwkX5cRaw Nothing k)+setJWKX5c certs@(Just (cert :| _)) key+  | certMatchesKey key cert = pure (set jwkX5cRaw certs key)+  | otherwise = Nothing++certMatchesKey :: JWK -> X509.SignedCertificate -> Bool+certMatchesKey key cert =+  maybe False (((==) `on` preview (jwkMaterial . asPublicKey)) key)+    (fromX509CertificateMaybe cert)++ instance FromJSON JWK where-  parseJSON = withObject "JWK" $ \o -> JWK+  parseJSON = withObject "JWK" (\o -> JWK     <$> parseJSON (Object o)     <*> o .:? "use"     <*> o .:? "key_ops"     <*> o .:? "alg"     <*> o .:? "kid"     <*> o .:? "x5u"-    <*> o .:? "x5c"+    <*> ((fmap . fmap) (\(Types.Base64X509 cert) -> cert) <$> o .:? "x5c")     <*> o .:? "x5t"     <*> o .:? "x5t#S256"+    ) >=> checkKey+    where+    checkKey k+      | maybe False (not . certMatchesKey k . Data.List.NonEmpty.head) (view jwkX5c k)+        = fail "X.509 cert in \"x5c\" param does not match key"+      | otherwise = pure k  instance ToJSON JWK where-  toJSON (JWK {..}) = object $ catMaybes+  toJSON JWK{..} = object $ catMaybes     [ fmap ("alg" .=) _jwkAlg     , fmap ("use" .=) _jwkUse     , fmap ("key_ops" .=) _jwkKeyOps     , fmap ("kid" .=) _jwkKid     , fmap ("x5u" .=) _jwkX5u-    , fmap ("x5c" .=) _jwkX5c+    , fmap (("x5c" .=) . fmap Types.Base64X509) _jwkX5cRaw     , fmap ("x5t" .=) _jwkX5t     , fmap ("x5t#S256" .=) _jwkX5tS256     ]@@ -215,12 +249,40 @@ fromRSA :: RSA.PrivateKey -> JWK fromRSA = fromKeyMaterial . RSAKeyMaterial . toRSAKeyParameters +-- | Convert an RSA public key into a JWK+--+fromRSAPublic :: RSA.PublicKey -> JWK+fromRSAPublic = fromKeyMaterial . RSAKeyMaterial . toRSAPublicKeyParameters+ -- | Convert octet string into a JWK -- fromOctets :: Cons s s Word8 Word8 => s -> JWK fromOctets =   fromKeyMaterial . OctKeyMaterial . OctKeyParameters . Types.Base64Octets   . view recons+++-- | Convert an X.509 certificate into a JWK.+--+-- Only RSA keys are supported.  Other key types will throw+-- 'KeyMismatch'.+--+-- The @"x5c"@ field of the resulting JWK contains the certificate.+--+fromX509Certificate+  :: (AsError e, MonadError e m)+  => X509.SignedCertificate -> m JWK+fromX509Certificate =+  maybe (throwError (review _KeyMismatch "X.509 key type not supported")) pure+  . fromX509CertificateMaybe++fromX509CertificateMaybe :: X509.SignedCertificate -> Maybe JWK+fromX509CertificateMaybe cert = do+  k <- case (X509.certPubKey . X509.signedObject . X509.getSigned) cert of+    X509.PubKeyRSA k -> pure (fromRSAPublic k)+    _ -> {- TODO EC -} Nothing+  pure $ k & set jwkX5cRaw (Just (pure cert))+   instance AsPublicKey JWK where

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2014, 2015, 2016  Fraser Tweedale+-- Copyright (C) 2013-2018  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,41 +12,72 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}  {-| -A 'JWKStore' provides JWK enumeration and lookup.+Key stores.  Instances are provided for 'JWK' and 'JWKSet'.  These+instances ignore the header and payload and just return the JWK/s+they contain.  More complex scenarios, such as efficient key lookup+by @"kid"@ or searching a database, can be implemented by writing a+new instance. +For example, the following instance looks in a filesystem directory+for keys based on either the JWS Header's @"kid"@ parameter, or the+  @"iss"@ claim in a JWT Claims Set:++@+-- | A KeyDB is just a filesystem directory+newtype KeyDB = KeyDB FilePath++instance (MonadIO m, HasKid h)+    => VerificationKeyStore m (h p) ClaimsSet KeyDB where+  getVerificationKeys h claims (KeyDB dir) = liftIO $+    fmap catMaybes . traverse findKey $ catMaybes+      [ preview (kid . _Just . param) h+      , preview (claimIss . _Just . string) claims]+    where+    findKey :: T.Text -> IO (Maybe JWK)+    findKey s =+      let path = dir <> "/" <> T.unpack s <> ".jwk"+      in handle+        (\(_ :: IOException) -> pure Nothing)+        (decode <$> L.readFile path)+@+ -} module Crypto.JOSE.JWK.Store   (-    JWKStore(..)+    VerificationKeyStore(..)   ) 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+import Crypto.JOSE.JWK (JWK, JWKSet(..)) +-- | Verification keys.  Lookup operates in effect @m@ with access+-- to the JWS header of type @h@ and a payload of type @s@.+--+-- The returned keys are not guaranteed to be used, e.g. if the JWK+-- @"use"@ or @"key_ops"@ field does not allow use for verification.+--+class VerificationKeyStore m h s a where+  -- | Look up verification keys by JWS header and payload.+  getVerificationKeys+    :: h          -- ^ JWS header+    -> s          -- ^ Payload+    -> a+    -> m [JWK] -instance JWKStore JWK where-  keys = id+-- | Use a 'JWK' as a 'VerificationKeyStore'.  Can be used with any+-- payload type.  Header and payload are ignored.  No filtering is+-- performed.+--+instance Applicative m => VerificationKeyStore m h s JWK where+  getVerificationKeys _ _ k = pure [k] -instance JWKStore JWKSet where-  keys = folding (\(JWKSet xs) -> xs)+-- | Use a 'JWKSet' as a 'VerificationKeyStore'.  Can be used with+-- any payload type.  Returns all keys in the set; header and+-- payload are ignored.  No filtering is performed.+--+instance Applicative m => VerificationKeyStore m h s JWKSet where+  getVerificationKeys _ _ (JWKSet xs) = pure xs

@@ -35,6 +35,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Crypto.JOSE.JWS@@ -50,11 +52,13 @@    -- * JWS creation   , newJWSHeader+  , makeJWSHeader   , signJWS    -- * JWS verification   , verifyJWS   , verifyJWS'+  , verifyJWSWithPayload    -- ** JWS validation settings   , defaultValidationSettings@@ -90,7 +94,7 @@  import Control.Lens hiding ((.=)) import Control.Lens.Cons.Extras (recons)-import Control.Monad.Except (MonadError(throwError))+import Control.Monad.Except (MonadError(throwError), unless) import Data.Aeson import qualified Data.ByteString as B import qualified Data.HashMap.Strict as M@@ -175,81 +179,58 @@   { _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+  , _jwsHeaderKid :: Maybe (HeaderParam p T.Text)  -- ^ interpretation unspecified   , _jwsHeaderX5u :: Maybe (HeaderParam p Types.URI)-  , _jwsHeaderX5c :: Maybe (HeaderParam p (NonEmpty Types.Base64X509))+  , _jwsHeaderX5c :: Maybe (HeaderParam p (NonEmpty Types.SignedCertificate))   , _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)+  , _jwsHeaderTyp :: Maybe (HeaderParam p T.Text)  -- ^ Content Type (of object)+  , _jwsHeaderCty :: Maybe (HeaderParam p T.Text)  -- ^ Content Type (of payload)   , _jwsHeaderCrit :: Maybe (NonEmpty T.Text)   }   deriving (Eq, Show) -instance HasAlg JWSHeader where-  alg f h@(JWSHeader { _jwsHeaderAlg = a }) =+class HasJWSHeader a where+  jwsHeader :: Lens' (a p) (JWSHeader p)++instance HasJWSHeader JWSHeader where+  jwsHeader = id++instance HasJWSHeader a => HasAlg a where+  alg = jwsHeader . \f h@(JWSHeader { _jwsHeaderAlg = a }) ->     fmap (\a' -> h { _jwsHeaderAlg = a' }) (f a)-instance HasJku JWSHeader where-  jku f h@(JWSHeader { _jwsHeaderJku = a }) =+instance HasJWSHeader a => HasJku a where+  jku = jwsHeader . \f h@(JWSHeader { _jwsHeaderJku = a }) ->     fmap (\a' -> h { _jwsHeaderJku = a' }) (f a)-instance HasJwk JWSHeader where-  jwk f h@(JWSHeader { _jwsHeaderJwk = a }) =+instance HasJWSHeader a => HasJwk a where+  jwk = jwsHeader . \f h@(JWSHeader { _jwsHeaderJwk = a }) ->     fmap (\a' -> h { _jwsHeaderJwk = a' }) (f a)-instance HasKid JWSHeader where-  kid f h@(JWSHeader { _jwsHeaderKid = a }) =+instance HasJWSHeader a => HasKid a where+  kid = jwsHeader . \f h@(JWSHeader { _jwsHeaderKid = a }) ->     fmap (\a' -> h { _jwsHeaderKid = a' }) (f a)-instance HasX5u JWSHeader where-  x5u f h@(JWSHeader { _jwsHeaderX5u = a }) =+instance HasJWSHeader a => HasX5u a where+  x5u = jwsHeader . \f h@(JWSHeader { _jwsHeaderX5u = a }) ->     fmap (\a' -> h { _jwsHeaderX5u = a' }) (f a)-instance HasX5c JWSHeader where-  x5c f h@(JWSHeader { _jwsHeaderX5c = a }) =+instance HasJWSHeader a => HasX5c a where+  x5c = jwsHeader . \f h@(JWSHeader { _jwsHeaderX5c = a }) ->     fmap (\a' -> h { _jwsHeaderX5c = a' }) (f a)-instance HasX5t JWSHeader where-  x5t f h@(JWSHeader { _jwsHeaderX5t = a }) =+instance HasJWSHeader a => HasX5t a where+  x5t = jwsHeader . \f h@(JWSHeader { _jwsHeaderX5t = a }) ->     fmap (\a' -> h { _jwsHeaderX5t = a' }) (f a)-instance HasX5tS256 JWSHeader where-  x5tS256 f h@(JWSHeader { _jwsHeaderX5tS256 = a }) =+instance HasJWSHeader a => HasX5tS256 a where+  x5tS256 = jwsHeader . \f h@(JWSHeader { _jwsHeaderX5tS256 = a }) ->     fmap (\a' -> h { _jwsHeaderX5tS256 = a' }) (f a)-instance HasTyp JWSHeader where-  typ f h@(JWSHeader { _jwsHeaderTyp = a }) =+instance HasJWSHeader a => HasTyp a where+  typ = jwsHeader . \f h@(JWSHeader { _jwsHeaderTyp = a }) ->     fmap (\a' -> h { _jwsHeaderTyp = a' }) (f a)-instance HasCty JWSHeader where-  cty f h@(JWSHeader { _jwsHeaderCty = a }) =+instance HasJWSHeader a => HasCty a where+  cty = jwsHeader . \f h@(JWSHeader { _jwsHeaderCty = a }) ->     fmap (\a' -> h { _jwsHeaderCty = a' }) (f a)-instance HasCrit JWSHeader where-  crit f h@(JWSHeader { _jwsHeaderCrit = a }) =+instance HasJWSHeader a => HasCrit a where+  crit = jwsHeader . \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. --@@ -257,7 +238,35 @@ newJWSHeader a = JWSHeader (uncurry HeaderParam a) z z z z z z z z z z   where z = Nothing +-- | Make a JWS header for the given signing key.+--+-- Uses 'bestJWSAlg' to choose the algorithm.+-- If set, the JWK's @"kid"@, @"x5u"@, @"x5c"@, @"x5t"@ and+-- @"x5t#S256"@ parameters are copied to the JWS header (as+-- protected parameters).+--+-- May return 'KeySizeTooSmall' or 'KeyMismatch'.+--+makeJWSHeader+  :: forall e m p. (MonadError e m, AsError e, ProtectionIndicator p)+  => JWK+  -> m (JWSHeader p)+makeJWSHeader k = do+  let+    p = getProtected+    f :: ASetter s t a (Maybe (HeaderParam p a1))+      -> Getting (Maybe a1) JWK (Maybe a1)+      -> s -> t+    f lh lk = set lh (HeaderParam p <$> view lk k)+  algo <- bestJWSAlg k+  pure $ newJWSHeader (p, algo)+    & f kid (jwkKid . to (fmap (view recons)))+    & f x5u jwkX5u+    & f x5c jwkX5c+    & f x5t jwkX5t+    & f x5tS256 jwkX5tS256 + -- | Signature object containing header, and signature bytes. -- -- If it was decoded from a serialised JWS, it "remembers" how the@@ -322,9 +331,10 @@     <*> headerOptional "jwk" hp hu     <*> headerOptional "kid" hp hu     <*> headerOptional "x5u" hp hu+    <*> ((fmap . fmap . fmap . fmap)+          (\(Types.Base64X509 cert) -> cert) (headerOptional "x5c" 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@@ -337,7 +347,7 @@       , 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, "x5c" .= fmap Types.Base64X509 (view param p))) (view x5c h)       , fmap (\p -> (view isProtected p, "x5t" .= view param p)) (view x5t h)       , fmap (\p -> (view isProtected p, "x5t#S256" .= view param p)) (view x5tS256 h)       , fmap (\p -> (view isProtected p, "typ" .= view param p)) (view typ h)@@ -441,15 +451,18 @@ 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+      (h', p', s') <- (,,) <$> t 0 h <*> t 1 p <*> t 2 s       let o = object [ ("payload", p'), ("protected", h'), ("signature", s') ]       case fromJSON o of-        Error e -> throwError (compactErr e)+        Error e -> throwError (review _JSONDecodeError e)         Success a -> pure a-    xs' -> throwError $ compactErr $ "expected 3 parts, got " ++ show (length xs')+    xs' -> throwError $+            review (_CompactDecodeError . _CompactInvalidNumberOfParts)+            (InvalidNumberOfParts 3 (fromIntegral (length xs')))     where-      compactErr = review _CompactDecodeError-      t = either (throwError . compactErr . show) (pure . String)+      textErr n e = review (_CompactDecodeError . _CompactInvalidText)+        (CompactTextError n e)+      t n = either (throwError . textErr n) (pure . String)         . T.decodeUtf8' . view recons  @@ -545,7 +558,8 @@ -- See also 'defaultValidationSettings'. -- verifyJWS'-  ::  ( AsError e, MonadError e m , HasJWSHeader h, HasParams h , JWKStore k+  ::  ( AsError e, MonadError e m , HasJWSHeader h, HasParams h+      , VerificationKeyStore m (h p) s k       , Cons s s Word8 Word8, AsEmpty s       , Foldable t       , ProtectionIndicator p@@ -568,7 +582,7 @@ verifyJWS   ::  ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m       , HasJWSHeader h, HasParams h-      , JWKStore k+      , VerificationKeyStore m (h p) s k       , Cons s s Word8 Word8, AsEmpty s       , Foldable t       , ProtectionIndicator p@@ -577,24 +591,45 @@   -> k        -- ^ key or key store   -> JWS t p h  -- ^ JWS   -> m s-verifyJWS conf k (JWS p@(Types.Base64Octets p') sigs) =+verifyJWS = verifyJWSWithPayload pure++verifyJWSWithPayload+  ::  ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m+      , HasJWSHeader h, HasParams h+      , VerificationKeyStore m (h p) payload k+      , Cons s s Word8 Word8, AsEmpty s+      , Foldable t+      , ProtectionIndicator p+      )+  => (s -> m payload)  -- ^ payload decoder+  -> a                 -- ^ validation settings+  -> k                 -- ^ key or key store+  -> JWS t p h         -- ^ JWS+  -> m payload+verifyJWSWithPayload dec conf k (JWS p@(Types.Base64Octets p') sigs) =   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 ())+      unless (or xs) (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+      unless (and xs) (throwError (review _JWSInvalidSignature ()))++    validate payload sig = do+      keys <- getVerificationKeys (view header sig) payload k+      if null keys+        then throwError (review _NoUsableKeys ())+        else pure $ any ((== Right True) . verifySig p sig) keys+  in do+    payload <- (dec . view recons) p'+    results <- traverse (validate payload) $ filter shouldValidateSig $ toList sigs+    payload <$ applyPolicy policy results  verifySig   :: (HasJWSHeader a, HasParams a, ProtectionIndicator p)

@@ -31,6 +31,7 @@   , Base64SHA1(..)   , Base64SHA256(..)   , Base64X509(..)+  , SignedCertificate   , URI   , base64url   ) where

@@ -18,6 +18,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  {-| @@ -67,7 +69,6 @@   (   -- * Creating a JWT     signClaims-  , JWT   , SignedJWT    -- * Validating a JWT and extracting claims@@ -120,13 +121,13 @@ import Data.Foldable (traverse_) import Data.Functor.Identity import Data.Maybe-import Data.List (unfoldr) import qualified Data.String  import Control.Lens (   makeClassy, makeClassyPrisms, makePrisms,   Lens', _Just, over, preview, review, view,-  Prism', prism', Cons, cons, uncons, iso, Iso')+  Prism', prism', Cons, iso, AsEmpty)+import Control.Lens.Cons.Extras (recons) import Control.Monad.Except (MonadError(throwError)) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Data.Aeson@@ -167,22 +168,22 @@ -- contains a @:@ but does not parse as a 'URI'.  Use 'stringOrUri' -- directly in this situation. ---data StringOrURI = Arbitrary String | OrURI URI deriving (Eq, Show)+data StringOrURI = Arbitrary T.Text | OrURI URI deriving (Eq, Show) +-- | Non-total.  A string with a @':'@ in it MUST parse as a URI instance Data.String.IsString StringOrURI where   fromString = fromJust . preview stringOrUri -consString :: (Cons s s Char Char, Monoid s) => Iso' s String-consString = iso (unfoldr uncons) (foldr cons mempty)--stringOrUri :: (Cons s s Char Char, Monoid s) => Prism' s StringOrURI-stringOrUri = consString . prism' rev fwd+stringOrUri :: (Cons s s Char Char, AsEmpty s) => Prism' s StringOrURI+stringOrUri = iso (view recons) (view recons) . 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)+  rev (OrURI x) = T.pack (show x)+  fwd s+    | T.any (== ':') s = OrURI <$> parseURI (T.unpack s)+    | otherwise = pure (Arbitrary s) -string :: Prism' StringOrURI String+string :: Prism' StringOrURI T.Text string = prism' Arbitrary f where   f (Arbitrary s) = Just s   f _ = Nothing@@ -256,7 +257,7 @@ -- JWT.  The processing of this claim is generally application -- specific. claimIss :: Lens' ClaimsSet (Maybe StringOrURI)-claimIss f h@(ClaimsSet { _claimIss = a}) =+claimIss f h@ClaimsSet{ _claimIss = a} =   fmap (\a' -> h { _claimIss = a' }) (f a)  -- | The subject claim identifies the principal that is the@@ -266,7 +267,7 @@ -- globally unique.  The processing of this claim is generally -- application specific. claimSub :: Lens' ClaimsSet (Maybe StringOrURI)-claimSub f h@(ClaimsSet { _claimSub = a}) =+claimSub f h@ClaimsSet{ _claimSub = a} =   fmap (\a' -> h { _claimSub = a' }) (f a)  -- | The audience claim identifies the recipients that the JWT is@@ -276,7 +277,7 @@ -- 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}) =+claimAud f h@ClaimsSet{ _claimAud = a} =   fmap (\a' -> h { _claimAud = a' }) (f a)  -- | The expiration time claim identifies the expiration time on@@ -286,7 +287,7 @@ -- /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}) =+claimExp f h@ClaimsSet{ _claimExp = a} =   fmap (\a' -> h { _claimExp = a' }) (f a)  -- | The not before claim identifies the time before which the JWT@@ -296,14 +297,14 @@ -- 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}) =+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}) =+claimIat f h@ClaimsSet{ _claimIat = a} =   fmap (\a' -> h { _claimIat = a' }) (f a)  -- | The JWT ID claim provides a unique identifier for the JWT.@@ -313,12 +314,12 @@ -- 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}) =+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}) =+unregisteredClaims f h@ClaimsSet{ _unregisteredClaims = a} =   fmap (\a' -> h { _unregisteredClaims = a' }) (f a)  @@ -368,7 +369,7 @@   } makeClassy ''JWTValidationSettings -instance HasValidationSettings JWTValidationSettings where+instance HasJWTValidationSettings a => HasValidationSettings a where   validationSettings = jwtValidationSettingsValidationSettings  -- | Maximum allowed skew when validating the /nbf/, /exp/ and /iat/ claims.@@ -464,7 +465,7 @@   traverse_ (\t -> do     now <- currentTime     when (view checkIssuedAt conf) $-      when ((view _NumericDate t) > addUTCTime (abs (view allowedSkew conf)) now) $+      when (view _NumericDate t > addUTCTime (abs (view allowedSkew conf)) now) $         throwError (review _JWTIssuedAtFuture ()))     . preview (claimIat . _Just) @@ -502,21 +503,9 @@       throwError (review _JWTNotInIssuer ()))   . preview (claimIss . _Just) ---- | JSON Web Token data.----newtype JWT a = JWT a-  deriving (Eq, Show)- -- | A digitally signed or MACed JWT ---type SignedJWT = JWT (CompactJWS JWSHeader)--instance FromCompact a => FromCompact (JWT a) where-  fromCompact = fmap JWT . fromCompact--instance ToCompact a => ToCompact (JWT a) where-  toCompact (JWT a) = toCompact a+type SignedJWT = CompactJWS JWSHeader   newtype WrappedUTCTime = WrappedUTCTime { getUTCTime :: UTCTime }@@ -542,18 +531,18 @@     , HasCheckIssuedAt a     , HasValidationSettings a     , AsError e, AsJWTError e, MonadError e m-    , JWKStore k+    , VerificationKeyStore m (JWSHeader ()) ClaimsSet k     )   => a   -> k   -> SignedJWT   -> m ClaimsSet-verifyClaims conf k (JWT jws) =+verifyClaims conf k jws =   -- It is important, for security reasons, that the signature get   -- verified before the claims.-  verifyJWS conf k jws-  >>= either (throwError . review _JWTClaimsSetDecodeError) pure . eitherDecode-  >>= validateClaimsSet conf+  verifyJWSWithPayload f conf k jws >>= validateClaimsSet conf+  where+    f = either (throwError . review _JWTClaimsSetDecodeError) pure . eitherDecode   -- | Cryptographically verify a JWS JWT, then validate the@@ -570,7 +559,7 @@     , HasCheckIssuedAt a     , HasValidationSettings a     , AsError e, AsJWTError e, MonadError e m-    , JWKStore k+    , VerificationKeyStore (ReaderT WrappedUTCTime m) (JWSHeader ()) ClaimsSet k     )   => a   -> k@@ -587,5 +576,4 @@   -> JWSHeader ()   -> ClaimsSet   -> m SignedJWT-signClaims k h c =-  JWT <$> signJWS (encode c) (Identity (h, k))+signClaims k h c = signJWS (encode c) (Identity (h, k))

@@ -1,4 +1,4 @@--- Copyright (C) 2013, 2017  Fraser Tweedale+-- Copyright (C) 2013, 2017, 2018  Fraser Tweedale -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -19,7 +19,7 @@  import Data.Monoid ((<>)) -import Control.Lens (_Right, review, view)+import Control.Lens (_Left, _Right, review, view) import Control.Lens.Extras (is) import Data.Aeson import qualified Data.ByteArray as BA@@ -179,23 +179,10 @@       <> "}"  jwkAppendixBSpec :: Spec-jwkAppendixBSpec = describe "JWK B.  Example Use of \"x5c\" (X.509 Certificate Chain) Parameter" $-  it "successfully decodes the example" $-    (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"+jwkAppendixBSpec = describe "JWK B.  Example Use of \"x5c\" (X.509 Certificate Chain) Parameter" $ do+  let+    appendixBExampleX5c = ""+      <> "[\"MIIDQjCCAiqgAwIBAgIGATz/FuLiMA0GCSqGSIb3DQEBBQUAMGIxCzAJB"       <> "gNVBAYTAlVTMQswCQYDVQQIEwJDTzEPMA0GA1UEBxMGRGVudmVyMRwwGgYD"       <> "VQQKExNQaW5nIElkZW50aXR5IENvcnAuMRcwFQYDVQQDEw5CcmlhbiBDYW1"       <> "wYmVsbDAeFw0xMzAyMjEyMzI5MTVaFw0xODA4MTQyMjI5MTVaMGIxCzAJBg"@@ -214,7 +201,48 @@       <> "2Bo3UPGrpsHzUoaGpDftmWssZkhpBJKVMJyf/RuP2SmmaIzmnw9JiSlYhzo"       <> "4tpzd5rFXhjRbg4zW9C+2qok+2+qDM1iJ684gPHMIY8aLWrdgQTxkumGmTq"       <> "gawR+N5MDtdPTEQ0XfIBc2cJEUyMTY5MPvACWpkA6SdS4xSvdXK3IVfOWA==\"]"-      <> "}"+    exampleKeyCommon = ""+      <> "{\"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\""+    Just exampleJWKWithX5c = decode $ exampleKeyCommon <> ",\"x5c\":" <> appendixBExampleX5c <> "}"+    Just exampleJWKWithoutX5c = decode $ exampleKeyCommon <> "}"+    -- Note: this key is bogus: the "d" param does not correspond to the "n"+    -- of the public key.  This is not what we're testing, but if a "n"/"d"+    -- sanity check gets implemented in future this test will need updating+    Just examplePrivateJWKWithoutX5c = decode $ exampleKeyCommon+      <> ",\"d\":\"X4cTteJY_gn4FYPsXB8rdXix5vwsg1FLN5E3EaG6RJoVH-HLLKD9"+      <> "M7dx5oo7GURknchnrRweUkC7hT5fJLM0WbFAKNLWY2vv7B6NqXSzUvxT0_YSfqij"+      <> "wp3RTzlBaCxWp4doFk5N2o8Gy_nHNKroADIkJ46pRUohsXywbReAdYaMwFs9tv8d"+      <> "_cPVY3i07a3t8MN6TNwm0dSawm9v47UiCl3Sk5ZiG7xojPLu4sbg1U2jx4IBTNBz"+      <> "nbJSzFHK66jT8bgkuqsk0GjskDJk19Z4qwjwbsnn4j2WBii3RL-Us2lGVkY8fkFz"+      <> "me1z0HbIkfz0Y6mqnOYtqc0X4jfcKoAC8Q\"}"+    Just certs = (fmap . fmap) (\(Types.Base64X509 cert) -> cert) (decode appendixBExampleX5c)+    jwkWithMismatchedPubKeyAndX5c = ""+      <> "{\"kty\":\"RSA\","+      <> " \"n\":\"vrjOfz9Ccdgx5nQudyhdoR17V-IubWMeOZCwX_jj0hgAsz2J_pqYW08"+      <> "HACK_HACK_HACK_HACK_HACK_HACK_HACK_HACK_HACK_HACK_HACK_HACK_"+      <> "u2j8DsVyT1azpJC_NG84Ty5KKthuCaPod7iI7w0LK9orSMhBEwwZDCxTWq4a"+      <> "YWAchc8t-emd9qOvWtVMDC2BXksRngh6X5bUYLy6AyHKvj-nUy1wgzjYQDwH"+      <> "MTplCoLtU-o-8SNnZ1tmRoGE9uJkBLdh5gFENabWnU5m1ZqZPdwS-qo-meMv"+      <> "VfJb6jJVWRpl2SUtCnYG2C32qvbWbjZ_jBPD5eunqsIo1vQ\","+      <> " \"e\":\"AQAB\",\"x5c\":" <> appendixBExampleX5c <> "}"+  it "sets x5c in JWK with PUBLIC key when first cert matches key" $+    setJWKX5c (Just certs) exampleJWKWithoutX5c `shouldBe` Just exampleJWKWithX5c+  it "sets x5c in JWK with PRIVATE key when first cert matches key" $+    (setJWKX5c (Just certs) examplePrivateJWKWithoutX5c >>= view asPublicKey)+    `shouldBe` Just exampleJWKWithX5c+  it "unsets x5c in JWK when given x5c = Nothing" $+    setJWKX5c Nothing exampleJWKWithX5c `shouldBe` Just exampleJWKWithoutX5c+  it "rejects (parse error) keys with x5c that does not match public key" $+    (eitherDecode jwkWithMismatchedPubKeyAndX5c :: Either String JWK) `shouldSatisfy` is _Left  jwkAppendixC1Spec :: Spec jwkAppendixC1Spec = describe "RFC 7517  C.1. Plaintext RSA Private Key" $@@ -271,7 +299,7 @@     it "corresponds to A.1. private key" $ Right True == do       sk <- _A1_result       pk <- _A2_result-      pure $ maybe False (== pk) (view asPublicKey sk)+      pure $ view asPublicKey sk == Just pk  rfc8037_A1_jwkJson = ""   <> "{\"kty\":\"OKP\",\"crv\":\"Ed25519\","

@@ -72,10 +72,10 @@   , _acmeNonce :: Types.Base64Octets   } deriving (Show) acmeJwsHeader :: Lens' (ACMEHeader p) (JWSHeader p)-acmeJwsHeader f s@(ACMEHeader { _acmeJwsHeader = a}) =+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}) =+acmeNonce f s@ACMEHeader{ _acmeNonce = a} =   fmap (\a' -> s { _acmeNonce = a'}) (f a) instance HasJWSHeader ACMEHeader where   jwsHeader = acmeJwsHeader@@ -386,27 +386,24 @@     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+  let+    decodeChecks jws = do+      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+  it "decodes single-sig Generalised JWS correctly" $+    decodeChecks (eitherDecode exampleJWSOneSig :: Either String (GeneralJWS JWSHeader))++  it "fails to decode single-sig Generalised JWS to 'JWS Identity'" $     (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 []' correctly" $+    decodeChecks (eitherDecode exampleJWSFlat :: Either String (GeneralJWS JWSHeader)) -  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 "decodes flattened JWS to 'JWS Identity' correctly" $+    decodeChecks (eitherDecode exampleJWSFlat :: Either String (FlattenedJWS JWSHeader))    it "fails to decode flattened JWS when \"signatures\" key is present" $ do     (eitherDecode exampleFlatJWSWithSignatures :: Either String (GeneralJWS JWSHeader))

@@ -282,12 +282,12 @@       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+      it "can be decoded and validated" $         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+      it "can be decoded, but not validated" $         runReaderT (jwt >>= verifyClaims conf k) (utcTime "2012-01-01 00:00:00")           `shouldBe` Left JWTExpired