diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/example/JWS.hs b/example/JWS.hs --- a/example/JWS.hs +++ b/example/JWS.hs @@ -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) diff --git a/example/KeyDB.hs b/example/KeyDB.hs new file mode 100644 --- /dev/null +++ b/example/KeyDB.hs @@ -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) diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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) diff --git a/jose.cabal b/jose.cabal --- a/jose.cabal +++ b/jose.cabal @@ -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 diff --git a/src/Crypto/JOSE/Error.hs b/src/Crypto/JOSE/Error.hs --- a/src/Crypto/JOSE/Error.hs +++ b/src/Crypto/JOSE/Error.hs @@ -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 diff --git a/src/Crypto/JOSE/Header.hs b/src/Crypto/JOSE/Header.hs --- a/src/Crypto/JOSE/Header.hs +++ b/src/Crypto/JOSE/Header.hs @@ -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)) diff --git a/src/Crypto/JOSE/JWA/JWK.hs b/src/Crypto/JOSE/JWA/JWK.hs --- a/src/Crypto/JOSE/JWA/JWK.hs +++ b/src/Crypto/JOSE/JWA/JWK.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2013, 2014, 2015, 2016, 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 diff --git a/src/Crypto/JOSE/JWE.hs b/src/Crypto/JOSE/JWE.hs --- a/src/Crypto/JOSE/JWE.hs +++ b/src/Crypto/JOSE/JWE.hs @@ -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 diff --git a/src/Crypto/JOSE/JWK.hs b/src/Crypto/JOSE/JWK.hs --- a/src/Crypto/JOSE/JWK.hs +++ b/src/Crypto/JOSE/JWK.hs @@ -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 diff --git a/src/Crypto/JOSE/JWK/Store.hs b/src/Crypto/JOSE/JWK/Store.hs --- a/src/Crypto/JOSE/JWK/Store.hs +++ b/src/Crypto/JOSE/JWK/Store.hs @@ -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 diff --git a/src/Crypto/JOSE/JWS.hs b/src/Crypto/JOSE/JWS.hs --- a/src/Crypto/JOSE/JWS.hs +++ b/src/Crypto/JOSE/JWS.hs @@ -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) diff --git a/src/Crypto/JOSE/Types.hs b/src/Crypto/JOSE/Types.hs --- a/src/Crypto/JOSE/Types.hs +++ b/src/Crypto/JOSE/Types.hs @@ -31,6 +31,7 @@ , Base64SHA1(..) , Base64SHA256(..) , Base64X509(..) + , SignedCertificate , URI , base64url ) where diff --git a/src/Crypto/JWT.hs b/src/Crypto/JWT.hs --- a/src/Crypto/JWT.hs +++ b/src/Crypto/JWT.hs @@ -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)) diff --git a/test/JWK.hs b/test/JWK.hs --- a/test/JWK.hs +++ b/test/JWK.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2013, 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\"," diff --git a/test/JWS.hs b/test/JWS.hs --- a/test/JWS.hs +++ b/test/JWS.hs @@ -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)) diff --git a/test/JWT.hs b/test/JWT.hs --- a/test/JWT.hs +++ b/test/JWT.hs @@ -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