summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorfrasertweedale <>2017-07-17 01:12:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-07-17 01:12:00 (GMT)
commit3eb982ea839d09ad00f2923278cfa32d02ad3265 (patch)
treef2155c5f0e9061a7baada5210e32c2997167b864
parentf22b5e71133d161d240111638a939265dd11cf63 (diff)
version 0.6.0.30.6.0.3
-rw-r--r--README.md13
-rw-r--r--example/JWS.hs44
-rw-r--r--example/Main.hs105
-rw-r--r--jose.cabal71
-rw-r--r--src/Crypto/JOSE.hs3
-rw-r--r--src/Crypto/JOSE/Compact.hs13
-rw-r--r--src/Crypto/JOSE/Error.hs30
-rw-r--r--src/Crypto/JOSE/Header.hs343
-rw-r--r--src/Crypto/JOSE/JWA/JWE.hs12
-rw-r--r--src/Crypto/JOSE/JWA/JWE/Alg.hs2
-rw-r--r--src/Crypto/JOSE/JWA/JWK.hs337
-rw-r--r--src/Crypto/JOSE/JWA/JWS.hs3
-rw-r--r--src/Crypto/JOSE/JWE.hs194
-rw-r--r--src/Crypto/JOSE/JWK.hs163
-rw-r--r--src/Crypto/JOSE/JWK/Store.hs52
-rw-r--r--src/Crypto/JOSE/JWS.hs590
-rw-r--r--src/Crypto/JOSE/JWS/Internal.hs328
-rw-r--r--src/Crypto/JOSE/Legacy.hs119
-rw-r--r--src/Crypto/JOSE/TH.hs9
-rw-r--r--src/Crypto/JOSE/Types.hs8
-rw-r--r--src/Crypto/JOSE/Types/Armour.hs89
-rw-r--r--src/Crypto/JOSE/Types/Internal.hs110
-rw-r--r--src/Crypto/JOSE/Types/Orphans.hs15
-rw-r--r--src/Crypto/JWT.hs514
-rw-r--r--test/JWK.hs403
-rw-r--r--test/JWS.hs354
-rw-r--r--test/JWT.hs252
-rw-r--r--test/Properties.hs55
28 files changed, 2931 insertions, 1300 deletions
diff --git a/README.md b/README.md
index 8c9e843..01281e0 100644
--- a/README.md
+++ b/README.md
@@ -4,9 +4,14 @@ jose is a Haskell implementation of [Javascript Object Signing and
Encryption](https://datatracker.ietf.org/wg/jose/) and [JSON Web
Token](https://tools.ietf.org/html/rfc7519).
-Encryption (JWE) is not supported but signing is supported. All key
-types and algorithms are supported, however, EC signing is currently
-vulnerable to timing attacks therefore its use is **strongly
-discouraged** (EC validation is safe).
+The JSON Web Signature (JWS; RFC 7515) implementation is complete.
+JSON Web Encryption (JWE; RFC 7516) is not yet implemented.
+
+**EdDSA** signatures (RFC 8037) are supported (Ed25519 only).
+
+The **ECDSA implementation is vulnerable to timing attacks** and
+should therefore only be used for verification.
+
+JWK Thumbprint (RFC 7638) is supported (requires *aeson* >= 0.10).
Contributions are welcome.
diff --git a/example/JWS.hs b/example/JWS.hs
new file mode 100644
index 0000000..968de71
--- /dev/null
+++ b/example/JWS.hs
@@ -0,0 +1,44 @@
+module JWS where
+
+import System.Exit (exitFailure)
+
+import Control.Monad.Except (runExceptT)
+import Data.Aeson (decode, encode)
+import qualified Data.ByteString.Lazy as L
+
+import Crypto.JOSE.JWS
+
+-- | Create a JWS. Args are:
+--
+-- 1. filename of JWK
+-- 2. filename of payload
+--
+-- Output is a signed JWS (JSON serialisation).
+--
+doJwsSign :: [String] -> IO ()
+doJwsSign [jwkFilename, payloadFilename] = do
+ Just jwk <- decode <$> L.readFile jwkFilename
+ payload <- L.readFile payloadFilename
+ result <- runExceptT $ do
+ alg <- bestJWSAlg jwk
+ signJWS payload [(newJWSHeader (Protected, alg), jwk)]
+ case result of
+ Left e -> print (e :: Error) >> exitFailure
+ Right jws -> L.putStr (encode jws)
+
+
+-- | Verify a JWS and output the payload if valid. Args are:
+--
+-- 1. filename of JWK
+-- 2. filename of JWS
+--
+-- Exit code indicates validity.
+--
+doJwsVerify :: [String] -> IO ()
+doJwsVerify [jwkFilename, jwsFilename] = do
+ Just jwk <- decode <$> L.readFile jwkFilename
+ Just jws <- decode <$> L.readFile jwsFilename
+ result <- runExceptT $ verifyJWS' (jwk :: JWK) (jws :: GeneralJWS JWSHeader)
+ case result of
+ Left e -> print (e :: Error) >> exitFailure
+ Right s -> L.putStr s
diff --git a/example/Main.hs b/example/Main.hs
new file mode 100644
index 0000000..ffb7bad
--- /dev/null
+++ b/example/Main.hs
@@ -0,0 +1,105 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+{-# LANGUAGE CPP #-}
+
+import Data.Maybe (fromJust)
+import System.Environment (getArgs)
+import System.Exit (exitFailure)
+
+import qualified Data.ByteString.Lazy as L
+import Data.Aeson (decode, encode)
+import Data.Text.Strict.Lens (utf8)
+
+import Control.Monad.Except (runExceptT)
+import Control.Lens (preview, re, review, set, view)
+
+import Crypto.JWT
+
+import JWS (doJwsSign, doJwsVerify)
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case head args of
+ "jwk-gen" -> doGen (tail args)
+ "jws-sign" -> doJwsSign (tail args)
+ "jws-verify" -> doJwsVerify (tail args)
+ "jwt-sign" -> doJwtSign (tail args)
+ "jwt-verify" -> doJwtVerify (tail args)
+#if MIN_VERSION_aeson(0,10,0)
+ "jwk-thumbprint" -> doThumbprint (tail args)
+#endif
+
+doGen :: [String] -> IO ()
+doGen [kty] = do
+ let
+ param = case kty of
+ "oct" -> OctGenParam 32
+ "rsa" -> RSAGenParam 256
+ "ec" -> ECGenParam P_256
+ "eddsa" -> OKPGenParam Ed25519
+ jwk <- genJWK param
+#if MIN_VERSION_aeson(0,10,0)
+ let
+ h = view thumbprint jwk :: Digest SHA256
+ kid = view (re (base64url . digest) . utf8) h
+ jwk' = set jwkKid (Just kid) jwk
+#else
+ let jwk' = jwk
+#endif
+ L.putStr (encode jwk')
+
+-- | Mint a JWT. Args are:
+--
+-- 1. filename of JWK
+-- 2. filename of a claims object
+--
+-- Output is a signed JWT.
+--
+doJwtSign :: [String] -> IO ()
+doJwtSign [jwkFilename, claimsFilename] = do
+ Just jwk <- decode <$> L.readFile jwkFilename
+ Just claims <- decode <$> L.readFile claimsFilename
+ result <- runExceptT $ do
+ alg <- bestJWSAlg jwk
+ signClaims jwk (newJWSHeader ((), alg)) claims
+ case result of
+ Left e -> print (e :: Error) >> exitFailure
+ Right jwt -> L.putStr (encodeCompact jwt)
+
+
+-- | Validate a JWT. Args are:
+--
+-- 1. filename of JWK
+-- 2. filename of a JWT
+-- 3. audience
+--
+-- Extraneous trailing args are ignored.
+--
+-- If JWT is valid, output JSON claims and exit 0,
+-- otherwise exit nonzero.
+--
+doJwtVerify :: [String] -> IO ()
+doJwtVerify [jwkFilename, jwtFilename, aud] = do
+ let
+ aud' = fromJust $ preview stringOrUri aud
+ conf = defaultJWTValidationSettings (== aud')
+ Just jwk <- decode <$> L.readFile jwkFilename
+ jwtData <- L.readFile jwtFilename
+ result <- runExceptT
+ (decodeCompact jwtData >>= verifyClaims conf (jwk :: JWK))
+ case result of
+ Left e -> print (e :: JWTError) >> exitFailure
+ Right claims -> L.putStr $ encode claims
+
+
+#if MIN_VERSION_aeson(0,10,0)
+-- | Print a base64url-encoded SHA-256 JWK Thumbprint. Args are:
+--
+-- 1. filename of JWK
+--
+doThumbprint :: [String] -> IO ()
+doThumbprint (jwkFilename : _) = do
+ Just jwk <- decode <$> L.readFile jwkFilename
+ let h = view thumbprint jwk :: Digest SHA256
+ L.putStr $ review (base64url . digest) h
+#endif
diff --git a/jose.cabal b/jose.cabal
index 96cb608..8818109 100644
--- a/jose.cabal
+++ b/jose.cabal
@@ -1,24 +1,22 @@
name: jose
-version: 0.4.0.4
+version: 0.6.0.3
synopsis:
Javascript Object Signing and Encryption and JSON Web Token library
description:
.
An implementation of the Javascript Object Signing and Encryption
- (JOSE) and JSON Web Token (JWT; RFC 5717) formats.
+ (JOSE) and JSON Web Token (JWT; RFC 7519) formats.
.
- The JSON Web Signature (JWS; RFC 5715) implementation is complete.
- JSON Web Encryption (JWE; RFC 5716) is not yet implemented.
+ The JSON Web Signature (JWS; RFC 7515) implementation is complete.
.
- All JWS algorithms (HMAC, ECDSA, RSASSA-PKCS-v1_5 and RSASSA-PSS)
- are implemented, however, the ECDSA implementation is is
- vulnerable to timing attacks and should therefore only be used for
- JWS verification.
+ EdDSA signatures (RFC 8037) are supported (Ed25519 only).
.
- The 'Crypto.JOSE.Legacy' module is provided for working with the
- Mozilla Persona (formerly BrowserID) key format. Only RSA keys
- are supported - DSA keys cannot be used and must be handled as
- opaque objects.
+ JWK Thumbprint (RFC 7638) is supported (requires /aeson/ >= 0.10).
+ .
+ JSON Web Encryption (JWE; RFC 7516) is not yet implemented.
+ .
+ The __ECDSA implementation is vulnerable to timing attacks__ and
+ should only be used for verification.
homepage: https://github.com/frasertweedale/hs-jose
bug-reports: https://github.com/frasertweedale/hs-jose/issues
@@ -28,49 +26,50 @@ extra-source-files:
README.md
author: Fraser Tweedale
maintainer: frase@frase.id.au
-copyright: Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale
+copyright: Copyright (C) 2013, 2014, 2015, 2016, 2017 Fraser Tweedale
category: Cryptography
build-type: Simple
cabal-version: >= 1.8
+tested-with:
+ GHC==7.10.3, GHC==8.0.1, GHC==8.0.2, GHC==8.2.1
library
exposed-modules:
Crypto.JOSE
Crypto.JOSE.Compact
Crypto.JOSE.Error
+ Crypto.JOSE.Header
Crypto.JOSE.JWE
Crypto.JOSE.JWK
+ Crypto.JOSE.JWK.Store
Crypto.JOSE.JWS
- Crypto.JOSE.Legacy
Crypto.JOSE.Types
Crypto.JWT
-
- other-modules:
Crypto.JOSE.AESKW
Crypto.JOSE.JWA.JWK
Crypto.JOSE.JWA.JWS
Crypto.JOSE.JWA.JWE
Crypto.JOSE.JWA.JWE.Alg
- Crypto.JOSE.JWS.Internal
+
+ other-modules:
Crypto.JOSE.TH
- Crypto.JOSE.Types.Armour
Crypto.JOSE.Types.Internal
Crypto.JOSE.Types.Orphans
build-depends:
- base == 4.*
+ base >= 4.8 && < 5
, attoparsec
, base64-bytestring == 1.0.*
- , bifunctors >= 4.0
- , byteable == 0.1.*
+ , concise >= 0.1
+ , containers >= 0.5
, cryptonite >= 0.7
- , data-default-class
, lens >= 4.3
, memory >= 0.7
+ , monad-time >= 0.1
, mtl >= 2
+ , semigroups >= 0.15
, template-haskell >= 2.4
, safe >= 0.3
- , semigroups >= 0.15
, aeson >= 0.8.0.1
, unordered-containers == 0.2.*
, bytestring == 0.10.*
@@ -91,7 +90,7 @@ source-repository head
test-suite tests
type: exitcode-stdio-1.0
- hs-source-dirs: src, test
+ hs-source-dirs: test
main-is: Test.hs
other-modules:
AESKW
@@ -105,16 +104,15 @@ test-suite tests
base
, attoparsec
, base64-bytestring
- , bifunctors
- , byteable
+ , containers
, cryptonite
- , data-default-class
, lens
, memory
+ , monad-time
, mtl
+ , semigroups
, template-haskell
, safe
- , semigroups
, aeson
, unordered-containers
, bytestring
@@ -124,9 +122,26 @@ test-suite tests
, vector
, x509
+ , concise
+ , jose
+
, tasty
, tasty-hspec
, tasty-quickcheck
, hspec
, QuickCheck
, quickcheck-instances
+
+executable example
+ hs-source-dirs: example
+ ghc-options: -Wall
+ main-is: Main.hs
+ other-modules:
+ JWS
+ build-depends:
+ base
+ , aeson
+ , bytestring
+ , lens
+ , mtl
+ , jose
diff --git a/src/Crypto/JOSE.hs b/src/Crypto/JOSE.hs
index 18b522c..49e0582 100644
--- a/src/Crypto/JOSE.hs
+++ b/src/Crypto/JOSE.hs
@@ -22,12 +22,15 @@ module Crypto.JOSE
module Crypto.JOSE.Compact
, module Crypto.JOSE.Error
, module Crypto.JOSE.JWK
+ , module Crypto.JOSE.JWK.Store
, module Crypto.JOSE.JWS
) where
import Crypto.JOSE.Compact
import Crypto.JOSE.Error
import Crypto.JOSE.JWK
+import Crypto.JOSE.JWK.Store
import Crypto.JOSE.JWS
+import Crypto.JOSE.Types (base64url)
{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}
diff --git a/src/Crypto/JOSE/Compact.hs b/src/Crypto/JOSE/Compact.hs
index 38bf2ad..387e881 100644
--- a/src/Crypto/JOSE/Compact.hs
+++ b/src/Crypto/JOSE/Compact.hs
@@ -23,28 +23,29 @@ functions for working with such data.
-}
module Crypto.JOSE.Compact where
+import Control.Monad.Except (MonadError)
import qualified Data.ByteString.Lazy as L
-import Crypto.JOSE.Error
+import Crypto.JOSE.Error (AsError)
-- | Data that can be parsed from a compact representation.
--
class FromCompact a where
- fromCompact :: [L.ByteString] -> Either Error a
+ fromCompact :: (AsError e, MonadError e m) => [L.ByteString] -> m a
-- | Decode a compact representation.
--
-decodeCompact :: FromCompact a => L.ByteString -> Either Error a
+decodeCompact :: (FromCompact a, AsError e, MonadError e m) => L.ByteString -> m a
decodeCompact = fromCompact . L.split 46
-- | Data that can be converted to a compact representation.
--
class ToCompact a where
- toCompact :: a -> Either Error [L.ByteString]
+ toCompact :: a -> [L.ByteString]
-- | Encode data to a compact representation.
--
-encodeCompact :: ToCompact a => a -> Either Error L.ByteString
-encodeCompact = fmap (L.intercalate ".") . toCompact
+encodeCompact :: (ToCompact a) => a -> L.ByteString
+encodeCompact = (L.intercalate ".") . toCompact
diff --git a/src/Crypto/JOSE/Error.hs b/src/Crypto/JOSE/Error.hs
index 22b9e9d..3c3f0ab 100644
--- a/src/Crypto/JOSE/Error.hs
+++ b/src/Crypto/JOSE/Error.hs
@@ -12,6 +12,11 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
{-|
JOSE error types.
@@ -20,10 +25,14 @@ JOSE error types.
module Crypto.JOSE.Error
(
Error(..)
+ , AsError(..)
) where
+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)
-- | All the errors that can occur.
--
@@ -35,11 +44,24 @@ data Error
| OtherPrimesNotSupported -- ^ RSA private key with >2 primes not supported
| RSAError RSA.Error -- ^ RSA encryption, decryption or signing error
| CryptoError CryptoError -- ^ Various cryptonite library error cases
- | CompactEncodeError String -- ^ Cannot produce compact representation of data
| CompactDecodeError String -- ^ Cannot decode compact representation
| JSONDecodeError String -- ^ JSON (Aeson) decoding error
- | JWSMissingHeader
- | JWSMissingAlg
| JWSCritUnprotected
- | JWSDuplicateHeaderParameter
+ | JWSNoValidSignatures
+ -- ^ 'AnyValidated' policy active, and no valid signature encountered
+ | JWSInvalidSignature
+ -- ^ 'AllValidated' policy active, and invalid signature encountered
+ | JWSNoSignatures
+ -- ^ 'AllValidated' policy active, and there were no signatures on object
+ -- that matched the allowed algorithms
deriving (Eq, Show)
+makeClassyPrisms ''Error
+
+
+instance (
+ MonadRandom m
+ , MonadTrans t
+ , Functor (t m)
+ , Monad (t m)
+ ) => MonadRandom (t m) where
+ getRandomBytes = lift . getRandomBytes
diff --git a/src/Crypto/JOSE/Header.hs b/src/Crypto/JOSE/Header.hs
new file mode 100644
index 0000000..21a233e
--- /dev/null
+++ b/src/Crypto/JOSE/Header.hs
@@ -0,0 +1,343 @@
+-- Copyright (C) 2016, 2017 Fraser Tweedale
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+-- http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-|
+
+Types and functions for working with JOSE header parameters.
+
+-}
+module Crypto.JOSE.Header
+ (
+ -- * Defining header data types
+ HeaderParam(..)
+ , ProtectionIndicator(..)
+ , Protection(..)
+ , protection
+ , isProtected
+ , param
+
+ -- * Defining header parsers
+ -- $parsing
+ , HasParams(..)
+ , headerRequired
+ , headerRequiredProtected
+ , headerOptional
+ , headerOptionalProtected
+
+ -- * Parsing headers
+ , parseParams
+ , parseCrit
+
+ -- * Encoding headers
+ , protectedParamsEncoded
+ , unprotectedParams
+
+
+ -- * Header fields shared by JWS and JWE
+ , HasAlg(..)
+ , HasJku(..)
+ , HasJwk(..)
+ , HasKid(..)
+ , HasX5u(..)
+ , HasX5c(..)
+ , HasX5t(..)
+ , HasX5tS256(..)
+ , HasTyp(..)
+ , HasCty(..)
+ , HasCrit(..)
+ ) where
+
+
+import Data.List.NonEmpty (NonEmpty)
+import Data.Monoid ((<>))
+import Data.Proxy (Proxy(..))
+
+import Control.Lens (Lens', Getter, to)
+import Data.Aeson (FromJSON(..), Object, Value, encode, object)
+import Data.Aeson.Types (Pair, Parser)
+import qualified Data.ByteString.Base64.URL.Lazy as B64UL
+import qualified Data.ByteString.Lazy as L
+import qualified Data.HashMap.Strict as M
+import qualified Data.Text as T
+
+import qualified Crypto.JOSE.JWA.JWS as JWA.JWS
+import Crypto.JOSE.JWK (JWK)
+import Crypto.JOSE.Types.Orphans ()
+import Crypto.JOSE.Types.Internal (unpad)
+import qualified Crypto.JOSE.Types as Types
+
+
+-- | A thing with parameters.
+--
+class HasParams (a :: * -> *) where
+ -- | Return a list of parameters,
+ -- each paired with whether it is protected or not.
+ params :: ProtectionIndicator p => a p -> [(Bool, Pair)]
+
+ -- | List of "known extensions", i.e. keys that may appear in the
+ -- "crit" header parameter.
+ extensions :: Proxy a -> [T.Text]
+ extensions = const []
+
+ parseParamsFor
+ :: (HasParams b, ProtectionIndicator p)
+ => Proxy b -> Maybe Object -> Maybe Object -> Parser (a p)
+
+-- | Parse a pair of objects (protected and unprotected header)
+--
+-- This internally invokes 'parseParamsFor' applied to a proxy for
+-- the target type. (This allows the parsing of the "crit" parameter
+-- to access "known extensions" understood by the target type.)
+--
+parseParams
+ :: forall a p. (HasParams a, ProtectionIndicator p)
+ => Maybe Object -- ^ protected header
+ -> Maybe Object -- ^ unprotected header
+ -> Parser (a p)
+parseParams = parseParamsFor (Proxy :: Proxy a)
+
+protectedParams
+ :: (HasParams a, ProtectionIndicator p)
+ => a p -> Maybe Value {- ^ Object -}
+protectedParams h =
+ case (map snd . filter fst . params) h of
+ [] -> Nothing
+ xs -> Just (object xs)
+
+-- | Return the encoded protected parameters
+--
+protectedParamsEncoded
+ :: (HasParams a, ProtectionIndicator p)
+ => a p -> L.ByteString
+protectedParamsEncoded =
+ maybe mempty (unpad . B64UL.encode . encode) . protectedParams
+
+-- | Return unprotected params as a JSON 'Value' (always an object)
+--
+unprotectedParams
+ :: (HasParams a, ProtectionIndicator p)
+ => a p -> Maybe Value {- ^ Object -}
+unprotectedParams h =
+ case (map snd . filter (not . fst) . params) h of
+ [] -> Nothing
+ xs -> Just (object xs)
+
+-- | Whether a header is protected or unprotected
+--
+data Protection = Protected | Unprotected
+ deriving (Eq, Show)
+
+class Eq a => ProtectionIndicator a where
+ -- | Get a value for indicating protection.
+ getProtected :: a
+
+ -- | Get a 'Just' a value for indicating no protection, or 'Nothing'
+ -- if the type does not support unprotected headers.
+ getUnprotected :: Maybe a
+
+instance ProtectionIndicator Protection where
+ getProtected = Protected
+ getUnprotected = Just Unprotected
+
+instance ProtectionIndicator () where
+ getProtected = ()
+ getUnprotected = Nothing
+
+
+-- | A header value, along with a protection indicator.
+--
+data HeaderParam p a = HeaderParam p a
+ deriving (Eq, Show)
+
+-- | 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)
+
+-- | Lens for a 'HeaderParam' value
+param :: Lens' (HeaderParam p a) a
+param f (HeaderParam p v) = fmap (\v' -> HeaderParam p v') (f v)
+
+-- | Getter for whether a parameter is protected
+isProtected :: (ProtectionIndicator p) => Getter (HeaderParam p a) Bool
+isProtected = protection . to (== getProtected)
+
+
+{- $parsing
+
+The 'parseParamsFor' function defines the parser for a header type.
+
+@
+'parseParamsFor'
+ :: ('HasParams' a, HasParams b)
+ => Proxy b -> Maybe Object -> Maybe Object -> 'Parser' a
+@
+
+It is defined over two objects: the /protected header/ and the
+/unprotected header/. The following functions are provided for
+parsing header parameters:
+
+['headerOptional']
+ An optional parameter that may be protected or unprotected.
+['headerRequired']
+ A required parameter that may be protected or unprotected.
+['headerOptionalProtected']
+ An optional parameter that, if present, MUST be carried in the protected header.
+['headerRequiredProtected']
+ A required parameter that, if present, MUST be carried in the protected header.
+
+Duplicate headers are forbidden. The above functions all perform
+duplicate header detection. If you do not use them, be sure to
+perform this detection yourself!
+
+An example parser:
+
+@
+instance HasParams ACMEHeader where
+ 'parseParamsFor' proxy hp hu = ACMEHeader
+ \<$> 'parseParamsFor' proxy hp hu
+ \<*> 'headerRequiredProtected' "nonce" hp hu
+@
+
+-}
+
+-- | Parse an optional parameter that may be carried in either
+-- the protected or the unprotected header.
+--
+headerOptional
+ :: (FromJSON a, ProtectionIndicator p)
+ => T.Text
+ -> Maybe Object
+ -> Maybe Object
+ -> Parser (Maybe (HeaderParam p a))
+headerOptional k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of
+ (Just _, Just _) -> fail $ "duplicate header " ++ show k
+ (Just v, Nothing) -> Just . HeaderParam getProtected <$> parseJSON v
+ (Nothing, Just v) -> maybe
+ (fail "unprotected header not supported")
+ (\p -> Just . HeaderParam p <$> parseJSON v)
+ getUnprotected
+ (Nothing, Nothing) -> pure Nothing
+
+-- | Parse an optional parameter that, if present, MUST be carried
+-- in the protected header.
+--
+headerOptionalProtected
+ :: FromJSON a
+ => T.Text
+ -> Maybe Object
+ -> Maybe Object
+ -> Parser (Maybe a)
+headerOptionalProtected k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of
+ (Just _, Just _) -> fail $ "duplicate header " ++ show k
+ (_, Just _) -> fail $ "header must be protected: " ++ show k
+ (Just v, _) -> Just <$> parseJSON v
+ _ -> pure Nothing
+
+-- | Parse a required parameter that may be carried in either
+-- the protected or the unprotected header.
+--
+headerRequired
+ :: (FromJSON a, ProtectionIndicator p)
+ => T.Text
+ -> Maybe Object
+ -> Maybe Object
+ -> Parser (HeaderParam p a)
+headerRequired k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of
+ (Just _, Just _) -> fail $ "duplicate header " ++ show k
+ (Just v, Nothing) -> HeaderParam getProtected <$> parseJSON v
+ (Nothing, Just v) -> maybe
+ (fail "unprotected header not supported")
+ (\p -> HeaderParam p <$> parseJSON v)
+ getUnprotected
+ (Nothing, Nothing) -> fail $ "missing required header " ++ show k
+
+-- | Parse a required parameter that MUST be carried
+-- in the protected header.
+--
+headerRequiredProtected
+ :: FromJSON a
+ => T.Text
+ -> Maybe Object
+ -> Maybe Object
+ -> Parser a
+headerRequiredProtected k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of
+ (Just _, Just _) -> fail $ "duplicate header " ++ show k
+ (_, Just _) -> fail $ "header must be protected: " <> show k
+ (Just v, _) -> parseJSON v
+ _ -> fail $ "missing required protected header: " <> show k
+
+
+critObjectParser
+ :: (Foldable t0, Foldable t1, Monad m)
+ => t0 T.Text -> t1 T.Text -> Object -> T.Text -> m T.Text
+critObjectParser reserved exts o s
+ | s `elem` reserved = fail "crit key is reserved"
+ | s `notElem` exts = fail "crit key is not understood"
+ | not (s `M.member` o) = fail "crit key is not present in headers"
+ | otherwise = pure s
+
+-- | Parse a "crit" header param
+--
+-- Fails if:
+--
+-- * any reserved header appears in "crit" header
+-- * any value in "crit" is not a recognised extension
+-- * any value in "crit" does not have a corresponding key in the object
+--
+parseCrit
+ :: (Foldable t0, Foldable t1, Traversable t2, Traversable t3, Monad m)
+ => t0 T.Text -- ^ reserved header parameters
+ -> t1 T.Text -- ^ recognised extensions
+ -> Object -- ^ full header (union of protected and unprotected headers)
+ -> t2 (t3 T.Text) -- ^ crit header
+ -> m (t2 (t3 T.Text))
+parseCrit reserved exts o = mapM (mapM (critObjectParser reserved exts o))
+ -- TODO fail on duplicate strings
+
+
+class HasAlg a where
+ alg :: Lens' (a p) (HeaderParam p JWA.JWS.Alg)
+
+class HasJku a where
+ jku :: Lens' (a p) (Maybe (HeaderParam p Types.URI))
+
+class HasJwk a where
+ jwk :: Lens' (a p) (Maybe (HeaderParam p JWK))
+
+class HasKid a where
+ kid :: Lens' (a p) (Maybe (HeaderParam p String))
+
+class HasX5u a where
+ x5u :: Lens' (a p) (Maybe (HeaderParam p Types.URI))
+
+class HasX5c a where
+ x5c :: Lens' (a p) (Maybe (HeaderParam p (NonEmpty Types.Base64X509)))
+
+class HasX5t a where
+ x5t :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA1))
+
+class HasX5tS256 a where
+ x5tS256 :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA256))
+
+class HasTyp a where
+ typ :: Lens' (a p) (Maybe (HeaderParam p String))
+
+class HasCty a where
+ cty :: Lens' (a p) (Maybe (HeaderParam p String))
+
+class HasCrit a where
+ crit :: Lens' (a p) (Maybe (NonEmpty T.Text))
diff --git a/src/Crypto/JOSE/JWA/JWE.hs b/src/Crypto/JOSE/JWA/JWE.hs
index f85316e..a71a69b 100644
--- a/src/Crypto/JOSE/JWA/JWE.hs
+++ b/src/Crypto/JOSE/JWA/JWE.hs
@@ -22,7 +22,6 @@ JSON Web Encryption data types specified under JSON Web Algorithms.
-}
module Crypto.JOSE.JWA.JWE where
-import Control.Applicative
import Data.Maybe (catMaybes)
import qualified Data.HashMap.Strict as M
@@ -35,8 +34,7 @@ import Crypto.JOSE.Types.Internal (objectPairs)
import Data.Aeson
---
--- JWA §4. Cryptographic Algorithms for Encryption
+-- | RFC 7518 §4. Cryptographic Algorithms for Key Management
--
data AlgWithParams
= RSA1_5
@@ -108,7 +106,7 @@ instance ToJSON AlgWithParams where
toJSON (PBES2_HS512_A256KW params) = algWithParamsObject params "PBES2-HS512+A256KW"
--- | JWA §4.7.1. Header Parameters Used for ECDH Key Agreement
+-- | RFC 7518 §4.6.1. Header Parameters Used for ECDH Key Agreement
--
data ECDHParameters = ECDHParameters
{ _epk :: JWK -- ^ Ephemeral Public Key ; a JWK PUBLIC key
@@ -130,7 +128,7 @@ instance ToJSON ECDHParameters where
]
--- | JWA §4.8.1. Header Parameters Used for AES GCM Key Encryption
+-- | RFC 7518 §4.7.1. Header Parameters Used for AES GCM Key Encryption
--
data AESGCMParameters = AESGCMParameters
{ _iv :: Base64Octets -- ^ Initialization Vector (must be 96 bits?)
@@ -146,7 +144,7 @@ instance ToJSON AESGCMParameters where
toJSON (AESGCMParameters iv tag) = object ["iv" .= iv, "tag" .= tag]
--- | JWA §4.9.1. Header Parameters Used for PBES2 Key Encryption
+-- | RFC 7518 §4.8.1. Header Parameters Used for PBES2 Key Encryption
--
data PBES2Parameters = PBES2Parameters
{ _p2s :: Base64Octets -- ^ PBKDF2 salt input
@@ -162,7 +160,7 @@ instance ToJSON PBES2Parameters where
toJSON (PBES2Parameters p2s p2c) = object ["p2s" .= p2s, "p2c" .= p2c]
--- | JWA §4.2. "enc" (Encryption Method) Header Parameters Values for JWE
+-- | RFC 7518 §5 Cryptographic Algorithms for Content Encryption
--
$(deriveJOSEType "Enc" [
"A128CBC-HS256" -- AES HMAC SHA authenticated encryption Required
diff --git a/src/Crypto/JOSE/JWA/JWE/Alg.hs b/src/Crypto/JOSE/JWA/JWE/Alg.hs
index 913013e..3ee9e5c 100644
--- a/src/Crypto/JOSE/JWA/JWE/Alg.hs
+++ b/src/Crypto/JOSE/JWA/JWE/Alg.hs
@@ -25,7 +25,7 @@ module Crypto.JOSE.JWA.JWE.Alg where
import qualified Crypto.JOSE.TH
--- | JWA §4.1. "alg" (Algorithm) Header Parameter Values for JWE
+-- | RFC 7518 §4.1. "alg" (Algorithm) Header Parameter Values for JWE
--
-- This section is shuffled off into its own module to avoid
-- circular import via Crypto.JOSE.JWK, which needs Alg.
diff --git a/src/Crypto/JOSE/JWA/JWK.hs b/src/Crypto/JOSE/JWA/JWK.hs
index 1822878..95b554f 100644
--- a/src/Crypto/JOSE/JWA/JWK.hs
+++ b/src/Crypto/JOSE/JWA/JWK.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale
+-- Copyright (C) 2013, 2014, 2015, 2016, 2017 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -13,6 +13,7 @@
-- limitations under the License.
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -29,11 +30,6 @@ module Crypto.JOSE.JWA.JWK (
-- * Type classes
AsPublicKey(..)
- -- * \"kty\" (Key Type) Parameter Values
- , EC(..)
- , RSA(..)
- , Oct(..)
-
-- * Parameters for Elliptic Curve Keys
, Crv(..)
, ECKeyParameters(..)
@@ -43,8 +39,8 @@ module Crypto.JOSE.JWA.JWK (
, RSAPrivateKeyOptionalParameters(..)
, RSAPrivateKeyParameters(..)
, RSAKeyParameters(RSAKeyParameters)
+ , toRSAKeyParameters
, rsaE
- , rsaKty
, rsaN
, rsaPrivateKeyParameters
, rsaPublicKey
@@ -53,9 +49,16 @@ module Crypto.JOSE.JWA.JWK (
-- * Parameters for Symmetric Keys
, OctKeyParameters(..)
+ -- * Parameters for CFRG EC keys (RFC 8037)
+ , OKPKeyParameters(..)
+ , OKPCrv(..)
+
+ -- * Key generation
, KeyMaterialGenParam(..)
, KeyMaterial(..)
, genKeyMaterial
+
+ -- * Signing and verification
, sign
, verify
@@ -63,10 +66,15 @@ module Crypto.JOSE.JWA.JWK (
) where
import Control.Applicative
+import Control.Monad (guard)
+import Control.Monad.Except (MonadError(throwError))
import Data.Bifunctor
-import Data.Maybe
+import Data.Foldable (toList)
+import Data.Maybe (fromMaybe, isJust)
+import Data.Monoid ((<>))
-import Control.Lens hiding ((.=))
+import Control.Lens hiding ((.=), elements)
+import Crypto.Error (onCryptoFailure)
import Crypto.Hash
import Crypto.MAC.HMAC
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
@@ -75,13 +83,16 @@ import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15
import qualified Crypto.PubKey.RSA.PSS as PSS
import qualified Crypto.PubKey.ECC.Types as ECC
+import qualified Crypto.PubKey.Ed25519 as Ed25519
+import qualified Crypto.PubKey.Curve25519 as Curve25519
import Crypto.Random
import Data.Aeson
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.HashMap.Strict as M
-import Data.List.NonEmpty
-import Test.QuickCheck
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Text as T
+import Test.QuickCheck (Arbitrary(..), arbitrarySizedNatural, elements, oneof, vectorOf)
import Crypto.JOSE.Error
import qualified Crypto.JOSE.JWA.JWS as JWA.JWS
@@ -91,20 +102,12 @@ import qualified Crypto.JOSE.Types.Internal as Types
import Crypto.JOSE.Types.Orphans ()
--- | Elliptic Curve key type (Recommeded+)
-$(Crypto.JOSE.TH.deriveJOSEType "EC" ["EC"])
--- | RSA key type (Required)
-$(Crypto.JOSE.TH.deriveJOSEType "RSA" ["RSA"])
--- | Octet sequence (symmetric key) key type (Required)
-$(Crypto.JOSE.TH.deriveJOSEType "Oct" ["oct"])
-
-
-- | \"crv\" (Curve) Parameter
--
$(Crypto.JOSE.TH.deriveJOSEType "Crv" ["P-256", "P-384", "P-521"])
instance Arbitrary Crv where
- arbitrary = oneof $ pure <$> [P_256, P_384, P_521]
+ arbitrary = elements [P_256, P_384, P_521]
-- | \"oth\" (Other Primes Info) Parameter
@@ -196,9 +199,7 @@ instance Arbitrary RSAPrivateKeyParameters where
-- | Parameters for Elliptic Curve Keys
--
data ECKeyParameters = ECKeyParameters
- {
- ecKty :: EC
- , ecCrv :: Crv
+ { ecCrv :: Crv
, ecX :: Types.SizedBase64Integer
, ecY :: Types.SizedBase64Integer
, ecD :: Maybe Types.SizedBase64Integer
@@ -207,10 +208,10 @@ data ECKeyParameters = ECKeyParameters
instance FromJSON ECKeyParameters where
parseJSON = withObject "EC" $ \o -> do
+ o .: "kty" >>= guard . (== ("EC" :: T.Text))
crv <- o .: "crv"
ECKeyParameters
- <$> o .: "kty"
- <*> pure crv
+ <$> pure crv
<*> (o .: "x" >>= Types.checkSize (ecCoordBytes crv))
<*> (o .: "y" >>= Types.checkSize (ecCoordBytes crv))
<*> (o .:? "d" >>= \case
@@ -219,17 +220,17 @@ instance FromJSON ECKeyParameters where
instance ToJSON ECKeyParameters where
toJSON (ECKeyParameters {..}) = object $
- [ "kty" .= ecKty
+ [ "kty" .= ("EC" :: T.Text)
, "crv" .= ecCrv
, "x" .= ecX
, "y" .= ecY
- ] ++ fmap ("d" .=) (maybeToList ecD)
+ ] ++ fmap ("d" .=) (toList ecD)
instance Arbitrary ECKeyParameters where
arbitrary = do
crv <- arbitrary
let w = ecCoordBytes crv
- ECKeyParameters EC crv
+ ECKeyParameters crv
<$> Types.genSizedBase64IntegerOf w
<*> Types.genSizedBase64IntegerOf w
<*> oneof
@@ -238,20 +239,21 @@ instance Arbitrary ECKeyParameters where
]
signEC
- :: (BA.ByteArrayAccess msg, HashAlgorithm h, MonadRandom m)
+ :: (BA.ByteArrayAccess msg, HashAlgorithm h,
+ MonadRandom m, MonadError e m, AsError e)
=> h
-> ECKeyParameters
-> msg
- -> m (Either Error B.ByteString)
+ -> m B.ByteString
signEC h (ECKeyParameters {..}) m = case ecD of
- Just ecD' -> Right . sigToBS <$> sig where
+ Just ecD' -> sigToBS <$> sig where
w = ecCoordBytes ecCrv
sig = ECDSA.sign privateKey h m
sigToBS (ECDSA.Signature r s) =
- Types.sizedIntegerToBS w r `B.append` Types.sizedIntegerToBS w s
+ Types.sizedIntegerToBS w r <> Types.sizedIntegerToBS w s
privateKey = ECDSA.PrivateKey (curve ecCrv) (d ecD')
d (Types.SizedBase64Integer _ n) = n
- Nothing -> return (Left $ KeyMismatch "not an EC private key")
+ Nothing -> throwError (review _KeyMismatch "not an EC private key")
verifyEC
:: (BA.ByteArrayAccess msg, HashAlgorithm h)
@@ -259,8 +261,8 @@ verifyEC
-> ECKeyParameters
-> msg
-> B.ByteString
- -> Either Error Bool
-verifyEC h k m s = Right $ ECDSA.verify h pubkey sig m
+ -> Bool
+verifyEC h k m s = ECDSA.verify h pubkey sig m
where
pubkey = ECDSA.PublicKey (curve $ ecCrv k) (point k)
sig = uncurry ECDSA.Signature
@@ -290,8 +292,7 @@ ecDBytes crv = ceiling (logBase 2 (fromIntegral order) / 8 :: Double) where
-- | Parameters for RSA Keys
--
data RSAKeyParameters = RSAKeyParameters
- { _rsaKty :: RSA
- , _rsaN :: Types.SizedBase64Integer
+ { _rsaN :: Types.SizedBase64Integer
, _rsaE :: Types.Base64Integer
, _rsaPrivateKeyParameters :: Maybe RSAPrivateKeyParameters
}
@@ -299,10 +300,10 @@ data RSAKeyParameters = RSAKeyParameters
makeLenses ''RSAKeyParameters
instance FromJSON RSAKeyParameters where
- parseJSON = withObject "RSA" $ \o ->
+ parseJSON = withObject "RSA" $ \o -> do
+ o .: "kty" >>= guard . (== ("RSA" :: T.Text))
RSAKeyParameters
- <$> o .: "kty"
- <*> o .: "n"
+ <$> o .: "n"
<*> o .: "e"
<*> if M.member "d" o
then Just <$> parseJSON (Object o)
@@ -310,22 +311,24 @@ instance FromJSON RSAKeyParameters where
instance ToJSON RSAKeyParameters where
toJSON RSAKeyParameters {..} = object $
- ("kty" .= _rsaKty)
+ ("kty" .= ("RSA" :: T.Text))
: ("n" .= _rsaN)
: ("e" .= _rsaE)
: maybe [] (Types.objectPairs . toJSON) _rsaPrivateKeyParameters
instance Arbitrary RSAKeyParameters where
- arbitrary = RSAKeyParameters RSA
+ arbitrary = RSAKeyParameters
<$> arbitrary
<*> arbitrary
<*> arbitrary
genRSA :: MonadRandom m => Int -> m RSAKeyParameters
-genRSA size = do
- (RSA.PublicKey s n e, RSA.PrivateKey _ d p q dp dq qi) <- RSA.generate size 65537
+genRSA size = toRSAKeyParameters . snd <$> RSA.generate size 65537
+
+toRSAKeyParameters :: RSA.PrivateKey -> RSAKeyParameters
+toRSAKeyParameters (RSA.PrivateKey (RSA.PublicKey s n e) d p q dp dq qi) =
let i = Types.Base64Integer
- return $ RSAKeyParameters RSA
+ in RSAKeyParameters
( Types.SizedBase64Integer s n )
( i e )
( Just (RSAPrivateKeyParameters (i d)
@@ -333,14 +336,15 @@ genRSA size = do
(i p) (i q) (i dp) (i dq) (i qi) Nothing))) )
signPKCS15
- :: (PKCS15.HashAlgorithmASN1 h, MonadRandom m)
+ :: (PKCS15.HashAlgorithmASN1 h, MonadRandom m, MonadError e m, AsError e)
=> h
-> RSAKeyParameters
-> B.ByteString
- -> m (Either Error B.ByteString)
+ -> m B.ByteString
signPKCS15 h k m = case rsaPrivateKey k of
- Left e -> return (Left e)
- Right k' -> first RSAError <$> PKCS15.signSafer (Just h) k' m
+ Left e -> throwError (review _Error e)
+ Right k' -> PKCS15.signSafer (Just h) k' m
+ >>= either (throwError . review _RSAError) pure
verifyPKCS15
:: PKCS15.HashAlgorithmASN1 h
@@ -348,18 +352,19 @@ verifyPKCS15
-> RSAKeyParameters
-> B.ByteString
-> B.ByteString
- -> Either Error Bool
-verifyPKCS15 h k m = Right . PKCS15.verify (Just h) (rsaPublicKey k) m
+ -> Bool
+verifyPKCS15 h k = PKCS15.verify (Just h) (rsaPublicKey k)
signPSS
- :: (HashAlgorithm h, MonadRandom m)
+ :: (HashAlgorithm h, MonadRandom m, MonadError e m, AsError e)
=> h
-> RSAKeyParameters
-> B.ByteString
- -> m (Either Error B.ByteString)
+ -> m B.ByteString
signPSS h k m = case rsaPrivateKey k of
- Left e -> return (Left e)
- Right k' -> first RSAError <$> PSS.signSafer (PSS.defaultPSSParams h) k' m
+ Left e -> throwError (review _Error e)
+ Right k' -> PSS.signSafer (PSS.defaultPSSParams h) k' m
+ >>= either (throwError . review _RSAError) pure
verifyPSS
:: (HashAlgorithm h)
@@ -367,12 +372,11 @@ verifyPSS
-> RSAKeyParameters
-> B.ByteString
-> B.ByteString
- -> Either Error Bool
-verifyPSS h k m = Right .
- PSS.verify (PSS.defaultPSSParams h) (rsaPublicKey k) m
+ -> Bool
+verifyPSS h k = PSS.verify (PSS.defaultPSSParams h) (rsaPublicKey k)
rsaPrivateKey :: RSAKeyParameters -> Either Error RSA.PrivateKey
-rsaPrivateKey (RSAKeyParameters _
+rsaPrivateKey (RSAKeyParameters
(Types.SizedBase64Integer size n)
(Types.Base64Integer e)
(Just (RSAPrivateKeyParameters (Types.Base64Integer d) opt)))
@@ -388,39 +392,131 @@ rsaPrivateKey (RSAKeyParameters _
rsaPrivateKey _ = Left $ KeyMismatch "not an RSA private key"
rsaPublicKey :: RSAKeyParameters -> RSA.PublicKey
-rsaPublicKey (RSAKeyParameters _
+rsaPublicKey (RSAKeyParameters
(Types.SizedBase64Integer size n) (Types.Base64Integer e) _)
= RSA.PublicKey size n e
-- | Symmetric key parameters data.
--
-data OctKeyParameters = OctKeyParameters
- { octKty :: Oct
- , octK :: Types.Base64Octets
+newtype OctKeyParameters = OctKeyParameters
+ { octK :: Types.Base64Octets
}
deriving (Eq, Show)
instance FromJSON OctKeyParameters where
- parseJSON = withObject "symmetric key" $ \o ->
- OctKeyParameters <$> o .: "kty" <*> o .: "k"
+ parseJSON = withObject "symmetric key" $ \o -> do
+ o .: "kty" >>= guard . (== ("oct" :: T.Text))
+ OctKeyParameters <$> o .: "k"
instance ToJSON OctKeyParameters where
- toJSON OctKeyParameters {..} = object ["kty" .= octKty, "k" .= octK]
+ toJSON OctKeyParameters {..} = object
+ [ "kty" .= ("oct" :: T.Text)
+ , "k" .= octK
+ ]
instance Arbitrary OctKeyParameters where
- arbitrary = OctKeyParameters Oct <$> arbitrary
+ arbitrary = OctKeyParameters <$> arbitrary
signOct
- :: forall h. HashAlgorithm h
+ :: forall h e m. (HashAlgorithm h, MonadError e m, AsError e)
=> h
-> OctKeyParameters
-> B.ByteString
- -> Either Error B.ByteString
-signOct h (OctKeyParameters _ (Types.Base64Octets k)) m =
+ -> m B.ByteString
+signOct h (OctKeyParameters (Types.Base64Octets k)) m =
if B.length k < hashDigestSize h
- then Left KeySizeTooSmall
- else Right $ B.pack $ BA.unpack (hmac k m :: HMAC h)
+ then throwError (review _KeySizeTooSmall ())
+ else pure $ B.pack $ BA.unpack (hmac k m :: HMAC h)
+
+
+-- "OKP" (CFRG Octet Key Pair) keys (RFC 8037)
+--
+data OKPKeyParameters
+ = Ed25519Key Ed25519.PublicKey (Maybe Ed25519.SecretKey)
+ | X25519Key Curve25519.PublicKey (Maybe Curve25519.SecretKey)
+ deriving (Eq)
+
+instance Show OKPKeyParameters where
+ show = \case
+ Ed25519Key pk sk -> "Ed25519 " <> showKeys pk sk
+ X25519Key pk sk -> "X25519 " <> showKeys pk sk
+ where
+ showKeys pk sk = show pk <> " " <> show (("SECRET" :: String) <$ sk)
+
+instance FromJSON OKPKeyParameters where
+ parseJSON = withObject "OKP" $ \o -> do
+ o .: "kty" >>= guard . (== ("OKP" :: T.Text))
+ crv <- o .: "crv"
+ case (crv :: T.Text) of
+ "Ed25519" -> parseOKPKey Ed25519Key Ed25519.publicKey Ed25519.secretKey o
+ "X25519" -> parseOKPKey X25519Key Curve25519.publicKey Curve25519.secretKey o
+ "Ed448" -> fail "Ed448 keys not implemented"
+ "X448" -> fail "X448 not implemented"
+ _ -> fail "unrecognised OKP key subtype"
+ where
+ bs (Types.Base64Octets k) = k
+ handleError = onCryptoFailure (fail . show) pure
+ parseOKPKey con mkPub mkSec o = con
+ <$> (o .: "x" >>= handleError . mkPub . bs)
+ <*> (o .:? "d" >>= traverse (handleError . mkSec . bs))
+
+instance ToJSON OKPKeyParameters where
+ toJSON x = object $
+ "kty" .= ("OKP" :: T.Text) : case x of
+ Ed25519Key pk sk -> "crv" .= ("Ed25519" :: T.Text) : params pk sk
+ X25519Key pk sk -> "crv" .= ("X25519" :: T.Text) : params pk sk
+ where
+ b64 = Types.Base64Octets . BA.convert
+ params pk sk = "x" .= b64 pk : (("d" .=) . b64 <$> toList sk)
+
+instance Arbitrary OKPKeyParameters where
+ arbitrary = oneof
+ [ Ed25519Key
+ <$> keyOfLen 32 Ed25519.publicKey
+ <*> oneof [pure Nothing, Just <$> keyOfLen 32 Ed25519.secretKey]
+ , X25519Key
+ <$> keyOfLen 32 Curve25519.publicKey
+ <*> oneof [pure Nothing, Just <$> keyOfLen 32 Curve25519.secretKey]
+ ]
+ where
+ bsOfLen n = B.pack <$> vectorOf n arbitrary
+ keyOfLen n con = onCryptoFailure (error . show) id . con <$> bsOfLen n
+
+data OKPCrv = Ed25519 | X25519
+ deriving (Eq, Show)
+
+instance Arbitrary OKPCrv where
+ arbitrary = elements [Ed25519, X25519]
+
+genOKP :: MonadRandom m => OKPCrv -> m OKPKeyParameters
+genOKP = \case
+ Ed25519 -> go 32 Ed25519Key Ed25519.secretKey Ed25519.toPublic
+ X25519 -> go 32 X25519Key Curve25519.secretKey Curve25519.toPublic
+ where
+ go len con skCon toPub = do
+ (bs :: B.ByteString) <- getRandomBytes len
+ let sk = onCryptoFailure (error . show) id (skCon bs)
+ pure $ con (toPub sk) (Just sk)
+
+signEdDSA
+ :: (MonadError e m, AsError e)
+ => OKPKeyParameters
+ -> B.ByteString
+ -> m B.ByteString
+signEdDSA (Ed25519Key pk (Just sk)) m = pure . BA.convert $ Ed25519.sign sk pk m
+signEdDSA (Ed25519Key _ Nothing) _ = throwError (review _KeyMismatch "not a private key")
+signEdDSA _ _ = throwError (review _KeyMismatch "not an EdDSA key")
+
+verifyEdDSA
+ :: (BA.ByteArrayAccess msg, BA.ByteArrayAccess sig, MonadError e m, AsError e)
+ => OKPKeyParameters -> msg -> sig -> m Bool
+verifyEdDSA (Ed25519Key pk _) m s =
+ onCryptoFailure
+ (throwError . review _CryptoError)
+ (pure . Ed25519.verify pk m)
+ (Ed25519.signature s)
+verifyEdDSA _ _ _ = throwError (review _AlgorithmMismatch "not an EdDSA key")
-- | Key material sum type.
@@ -429,30 +525,48 @@ data KeyMaterial
= ECKeyMaterial ECKeyParameters
| RSAKeyMaterial RSAKeyParameters
| OctKeyMaterial OctKeyParameters
+ | OKPKeyMaterial OKPKeyParameters
deriving (Eq, Show)
showKeyType :: KeyMaterial -> String
showKeyType (ECKeyMaterial (ECKeyParameters { ecCrv = crv })) = "ECDSA (" ++ show crv ++ ")"
showKeyType (RSAKeyMaterial _) = "RSA"
showKeyType (OctKeyMaterial _) = "symmetric"
+showKeyType (OKPKeyMaterial _) = "OKP"
instance FromJSON KeyMaterial where
parseJSON = withObject "KeyMaterial" $ \o ->
ECKeyMaterial <$> parseJSON (Object o)
<|> RSAKeyMaterial <$> parseJSON (Object o)
<|> OctKeyMaterial <$> parseJSON (Object o)
+ <|> OKPKeyMaterial <$> parseJSON (Object o)
instance ToJSON KeyMaterial where
toJSON (ECKeyMaterial p) = object $ Types.objectPairs (toJSON p)
toJSON (RSAKeyMaterial p) = object $ Types.objectPairs (toJSON p)
toJSON (OctKeyMaterial p) = object $ Types.objectPairs (toJSON p)
+ toJSON (OKPKeyMaterial p) = object $ Types.objectPairs (toJSON p)
-- | Keygen parameters.
--
data KeyMaterialGenParam
= ECGenParam Crv
+ -- ^ Generate an EC key with specified curve.
| RSAGenParam Int
+ -- ^ Generate an RSA key with specified size in /bytes/.
| OctGenParam Int
+ -- ^ Generate a symmetric key with specified size in /bytes/.
+ | OKPGenParam OKPCrv
+ -- ^ Generate an EdDSA or Edwards ECDH key with specified curve.
+ deriving (Eq, Show)
+
+instance Arbitrary KeyMaterialGenParam where
+ arbitrary = oneof
+ [ ECGenParam <$> arbitrary
+ , RSAGenParam <$> elements ((`div` 8) <$> [2048, 3072, 4096])
+ , OctGenParam <$> liftA2 (+) arbitrarySizedNatural (elements [32, 48, 64])
+ , OKPGenParam <$> arbitrary
+ ]
genKeyMaterial :: MonadRandom m => KeyMaterialGenParam -> m KeyMaterial
genKeyMaterial (ECGenParam crv) = do
@@ -462,19 +576,20 @@ genKeyMaterial (ECGenParam crv) = do
(ECDSA.PublicKey _ p, ECDSA.PrivateKey _ d) <- ECC.generate (curve crv)
case p of
ECC.Point x y -> return $ ECKeyMaterial $
- ECKeyParameters EC crv (xyValue x) (xyValue y) (Just (dValue d))
+ ECKeyParameters crv (xyValue x) (xyValue y) (Just (dValue d))
ECC.PointO -> genKeyMaterial (ECGenParam crv) -- JWK cannot represent point at infinity; recurse
genKeyMaterial (RSAGenParam size) = RSAKeyMaterial <$> genRSA size
genKeyMaterial (OctGenParam n) =
- OctKeyMaterial . OctKeyParameters Oct . Types.Base64Octets <$> getRandomBytes n
+ OctKeyMaterial . OctKeyParameters . Types.Base64Octets <$> getRandomBytes n
+genKeyMaterial (OKPGenParam crv) = OKPKeyMaterial <$> genOKP crv
sign
- :: MonadRandom m
+ :: (MonadRandom m, MonadError e m, AsError e)
=> JWA.JWS.Alg
-> KeyMaterial
-> B.ByteString
- -> m (Either Error B.ByteString)
-sign JWA.JWS.None _ = \_ -> return $ Right ""
+ -> 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
@@ -484,58 +599,68 @@ sign JWA.JWS.RS512 (RSAKeyMaterial k) = signPKCS15 SHA512 k
sign JWA.JWS.PS256 (RSAKeyMaterial k) = signPSS SHA256 k
sign JWA.JWS.PS384 (RSAKeyMaterial k) = signPSS SHA384 k
sign JWA.JWS.PS512 (RSAKeyMaterial k) = signPSS SHA512 k
-sign JWA.JWS.HS256 (OctKeyMaterial k) = return . signOct SHA256 k
-sign JWA.JWS.HS384 (OctKeyMaterial k) = return . signOct SHA384 k
-sign JWA.JWS.HS512 (OctKeyMaterial k) = return . signOct SHA512 k
-sign h k = \_ -> return $ Left $ AlgorithmMismatch
- $ show h ++ "cannot be used with " ++ showKeyType k ++ " key"
+sign JWA.JWS.HS256 (OctKeyMaterial k) = signOct SHA256 k
+sign JWA.JWS.HS384 (OctKeyMaterial k) = signOct SHA384 k
+sign JWA.JWS.HS512 (OctKeyMaterial k) = signOct SHA512 k
+sign JWA.JWS.EdDSA (OKPKeyMaterial k) = signEdDSA k
+sign h k = \_ -> throwError (review _AlgorithmMismatch
+ (show h <> "cannot be used with " <> showKeyType k <> " key"))
verify
- :: JWA.JWS.Alg
+ :: (MonadError e m, AsError e)
+ => JWA.JWS.Alg
-> KeyMaterial
-> B.ByteString
-> B.ByteString
- -> Either Error Bool
-verify JWA.JWS.None _ = \_ s -> Right $ s == ""
-verify JWA.JWS.ES256 (ECKeyMaterial k) = verifyEC SHA256 k
-verify JWA.JWS.ES384 (ECKeyMaterial k) = verifyEC SHA384 k
-verify JWA.JWS.ES512 (ECKeyMaterial k) = verifyEC SHA512 k
-verify JWA.JWS.RS256 (RSAKeyMaterial k) = verifyPKCS15 SHA256 k
-verify JWA.JWS.RS384 (RSAKeyMaterial k) = verifyPKCS15 SHA384 k
-verify JWA.JWS.RS512 (RSAKeyMaterial k) = verifyPKCS15 SHA512 k
-verify JWA.JWS.PS256 (RSAKeyMaterial k) = verifyPSS SHA256 k
-verify JWA.JWS.PS384 (RSAKeyMaterial k) = verifyPSS SHA384 k
-verify JWA.JWS.PS512 (RSAKeyMaterial k) = verifyPSS SHA512 k
+ -> m Bool
+verify JWA.JWS.None _ = \_ s -> pure $ s == ""
+verify JWA.JWS.ES256 (ECKeyMaterial k) = fmap pure . verifyEC SHA256 k
+verify JWA.JWS.ES384 (ECKeyMaterial k) = fmap pure . verifyEC SHA384 k
+verify JWA.JWS.ES512 (ECKeyMaterial k) = fmap pure . verifyEC SHA512 k
+verify JWA.JWS.RS256 (RSAKeyMaterial k) = fmap pure . verifyPKCS15 SHA256 k
+verify JWA.JWS.RS384 (RSAKeyMaterial k) = fmap pure . verifyPKCS15 SHA384 k
+verify JWA.JWS.RS512 (RSAKeyMaterial k) = fmap pure . verifyPKCS15 SHA512 k
+verify JWA.JWS.PS256 (RSAKeyMaterial k) = fmap pure . verifyPSS SHA256 k
+verify JWA.JWS.PS384 (RSAKeyMaterial k) = fmap pure . verifyPSS SHA384 k
+verify JWA.JWS.PS512 (RSAKeyMaterial k) = fmap pure . verifyPSS SHA512 k
verify JWA.JWS.HS256 (OctKeyMaterial k) = \m s -> BA.constEq s <$> signOct SHA256 k m
verify JWA.JWS.HS384 (OctKeyMaterial k) = \m s -> BA.constEq s <$> signOct SHA384 k m
verify JWA.JWS.HS512 (OctKeyMaterial k) = \m s -> BA.constEq s <$> signOct SHA512 k m
-verify h k = \_ -> return $ Left $ AlgorithmMismatch
- $ show h ++ "cannot be used with " ++ showKeyType k ++ " key"
+verify JWA.JWS.EdDSA (OKPKeyMaterial k) = verifyEdDSA k
+verify h k = \_ _ -> throwError $ review _AlgorithmMismatch
+ (show h <> "cannot be used with " <> showKeyType k <> " key")
instance Arbitrary KeyMaterial where
arbitrary = oneof
[ ECKeyMaterial <$> arbitrary
, RSAKeyMaterial <$> arbitrary
, OctKeyMaterial <$> arbitrary
+ , OKPKeyMaterial <$> arbitrary
]
+-- | Keys that may have have public material
+--
class AsPublicKey k where
- asPublicKey :: Prism' k k
+ -- | Get the public key
+ asPublicKey :: Getter k (Maybe k)
-instance AsPublicKey OctKeyParameters where
- asPublicKey = prism' id (const Nothing)
-
instance AsPublicKey RSAKeyParameters where
- asPublicKey = prism' id (Just . set rsaPrivateKeyParameters Nothing)
+ asPublicKey = to (Just . set rsaPrivateKeyParameters Nothing)
instance AsPublicKey ECKeyParameters where
- asPublicKey = prism' id (\k -> Just k { ecD = Nothing })
+ asPublicKey = to (\k -> Just k { ecD = Nothing })
+
+instance AsPublicKey OKPKeyParameters where
+ asPublicKey = to $ \case
+ Ed25519Key pk _ -> Just (Ed25519Key pk Nothing)
+ X25519Key pk _ -> Just (X25519Key pk Nothing)
instance AsPublicKey KeyMaterial where
- asPublicKey = prism' id (\x -> case x of
- OctKeyMaterial k -> OctKeyMaterial <$> k ^? asPublicKey
- RSAKeyMaterial k -> RSAKeyMaterial <$> k ^? asPublicKey
- ECKeyMaterial k -> ECKeyMaterial <$> k ^? asPublicKey
+ asPublicKey = to (\x -> case x of
+ OctKeyMaterial _ -> Nothing
+ RSAKeyMaterial k -> RSAKeyMaterial <$> view asPublicKey k
+ ECKeyMaterial k -> ECKeyMaterial <$> view asPublicKey k
+ OKPKeyMaterial k -> OKPKeyMaterial <$> view asPublicKey k
)
diff --git a/src/Crypto/JOSE/JWA/JWS.hs b/src/Crypto/JOSE/JWA/JWS.hs
index fcb43c6..3349453 100644
--- a/src/Crypto/JOSE/JWA/JWS.hs
+++ b/src/Crypto/JOSE/JWA/JWS.hs
@@ -25,7 +25,7 @@ module Crypto.JOSE.JWA.JWS where
import qualified Crypto.JOSE.TH
--- | JWA §3.1. "alg" (Algorithm) Header Parameters for JWS
+-- | RFC 7518 §3.1. "alg" (Algorithm) Header Parameters Values for JWS
--
$(Crypto.JOSE.TH.deriveJOSEType "Alg" [
"HS256" -- HMAC SHA ; REQUIRED
@@ -41,4 +41,5 @@ $(Crypto.JOSE.TH.deriveJOSEType "Alg" [
, "PS384" -- RSASSA-PSS SHA ; OPTIONAL
, "PS512" -- RSSSSA-PSS SHA ; OPTIONAL
, "none" -- "none" No signature or MAC ; Optional
+ , "EdDSA" -- EdDSA (RFC 8037)
])
diff --git a/src/Crypto/JOSE/JWE.hs b/src/Crypto/JOSE/JWE.hs
index 7f6bad3..4ea2d89 100644
--- a/src/Crypto/JOSE/JWE.hs
+++ b/src/Crypto/JOSE/JWE.hs
@@ -24,22 +24,19 @@ module Crypto.JOSE.JWE
, JWE(..)
) where
-import Prelude hiding (mapM)
-import Control.Applicative
-import Data.Bifunctor (first, bimap)
-import Data.Maybe (catMaybes)
-import Data.Traversable (mapM)
+import Control.Applicative ((<|>))
+import Data.Bifunctor (bimap)
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Monoid ((<>))
+import Control.Lens (view)
import Data.Aeson
import Data.Aeson.Types
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Base64.URL as B64U
-import qualified Data.ByteString.Base64.URL.Lazy as B64UL
import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import Data.List.NonEmpty (NonEmpty(..), toList)
+import Data.List.NonEmpty (NonEmpty)
import Crypto.Cipher.AES
import Crypto.Cipher.Types
@@ -52,11 +49,11 @@ import qualified Crypto.PubKey.RSA.OAEP as OAEP
import Crypto.JOSE.AESKW
import Crypto.JOSE.Error
+import Crypto.JOSE.Header
import Crypto.JOSE.JWA.JWE
import Crypto.JOSE.JWK
import qualified Crypto.JOSE.Types as Types
import qualified Crypto.JOSE.Types.Internal as Types
-import Crypto.JOSE.Types.Armour
critInvalidNames :: [T.Text]
@@ -67,119 +64,112 @@ critInvalidNames =
newtype CritParameters = CritParameters (NonEmpty (T.Text, Value))
deriving (Eq, Show)
-critObjectParser :: Object -> T.Text -> Parser (T.Text, Value)
-critObjectParser o s
- | s `elem` critInvalidNames = fail "crit key is reserved"
- | otherwise = (\v -> (s, v)) <$> o .: s
-parseCrit :: Object -> NonEmpty T.Text -> Parser CritParameters
-parseCrit o = fmap CritParameters . mapM (critObjectParser o)
- -- TODO fail on duplicate strings
-
-instance FromJSON CritParameters where
- parseJSON = withObject "crit" $ \o -> o .: "crit" >>= parseCrit o
-
-instance ToJSON CritParameters where
- toJSON (CritParameters m) = object $ ("crit", toJSON $ fmap fst m) : toList m
-
-
-data JWEHeader = JWEHeader
+data JWEHeader p = JWEHeader
{ _jweAlg :: Maybe AlgWithParams
- , _jweEnc :: Maybe Enc
+ , _jweEnc :: HeaderParam p Enc
, _jweZip :: Maybe String -- protected header only "DEF" (DEFLATE) defined
- , _jweJku :: Maybe Types.URI
- , _jweJwk :: Maybe JWK
- , _jweKid :: Maybe String
- , _jweX5u :: Maybe Types.URI
- , _jweX5c :: Maybe (NonEmpty Types.Base64X509)
- , _jweX5t :: Maybe Types.Base64SHA1
- , _jweX5tS256 :: Maybe Types.Base64SHA256
- , _jweTyp :: Maybe String -- ^ Content Type (of object)
- , _jweCty :: Maybe String -- ^ Content Type (of payload)
- , _jweCrit :: Maybe CritParameters
+ , _jweJku :: Maybe (HeaderParam p Types.URI)
+ , _jweJwk :: Maybe (HeaderParam p JWK)
+ , _jweKid :: Maybe (HeaderParam p String)
+ , _jweX5u :: Maybe (HeaderParam p Types.URI)
+ , _jweX5c :: Maybe (HeaderParam p (NonEmpty Types.Base64X509))
+ , _jweX5t :: Maybe (HeaderParam p Types.Base64SHA1)
+ , _jweX5tS256 :: Maybe (HeaderParam p Types.Base64SHA256)
+ , _jweTyp :: Maybe (HeaderParam p String) -- ^ Content Type (of object)
+ , _jweCty :: Maybe (HeaderParam p String) -- ^ Content Type (of payload)
+ , _jweCrit :: Maybe (NonEmpty T.Text)
}
deriving (Eq, Show)
-newJWEHeader :: AlgWithParams -> JWEHeader
-newJWEHeader alg = JWEHeader (Just alg) z z z z z z z z z z z z where z = Nothing
-
-
-instance FromJSON JWEHeader where
- parseJSON = withObject "JWE" $ \o -> JWEHeader
- <$> parseJSON (Object o)
- <*> o .: "enc"
- <*> o .:? "zip"
- <*> o .:? "jku"
- <*> o .:? "jwk"
- <*> o .:? "kid"
- <*> o .:? "x5u"
- <*> o .:? "x5c"
- <*> o .:? "x5t"
- <*> o .:? "x5t#S256"
- <*> o .:? "typ"
- <*> o .:? "cty"
- <*> (o .:? "crit" >>= mapM (parseCrit o)) -- TODO
-
-instance ToJSON JWEHeader where
- toJSON (JWEHeader alg enc _zip jku jwk kid x5u x5c x5t x5tS256 typ cty crit) =
- object $ catMaybes
- [ fmap ("enc" .=) enc
- , fmap ("zip" .=) _zip
- , fmap ("jku" .=) jku
- , fmap ("jwk" .=) jwk
- , fmap ("kid" .=) kid
- , fmap ("x5u" .=) x5u
- , fmap ("x5c" .=) x5c
- , fmap ("x5t" .=) x5t
- , fmap ("x5t#S256" .=) x5tS256
- , fmap ("typ" .=) typ
- , fmap ("cty" .=) cty
+newJWEHeader :: ProtectionIndicator p => AlgWithParams -> Enc -> JWEHeader p
+newJWEHeader alg enc =
+ JWEHeader (Just alg) (HeaderParam getProtected enc) z z z z z z z z z z z
+ where z = Nothing
+
+instance HasParams JWEHeader where
+ parseParamsFor proxy hp hu = JWEHeader
+ <$> parseJSON (Object (fromMaybe mempty hp <> fromMaybe mempty hu))
+ <*> headerRequired "enc" hp hu
+ <*> headerOptionalProtected "zip" hp hu
+ <*> headerOptional "jku" hp hu
+ <*> headerOptional "jwk" hp hu
+ <*> headerOptional "kid" hp hu
+ <*> headerOptional "x5u" hp hu
+ <*> headerOptional "x5c" hp hu
+ <*> headerOptional "x5t" hp hu
+ <*> headerOptional "x5t#S256" hp hu
+ <*> headerOptional "typ" hp hu
+ <*> headerOptional "cty" hp hu
+ <*> (headerOptionalProtected "crit" hp hu
+ >>= parseCrit critInvalidNames (extensions proxy)
+ (fromMaybe mempty hp <> fromMaybe mempty hu))
+ params (JWEHeader alg enc zip' jku jwk kid x5u x5c x5t x5tS256 typ cty crit) =
+ catMaybes
+ [ undefined -- TODO
+ , Just (view isProtected enc, "enc" .= view param enc)
+ , fmap (\p -> (True, "zip" .= p)) zip'
+ , fmap (\p -> (view isProtected p, "jku" .= view param p)) jku
+ , fmap (\p -> (view isProtected p, "jwk" .= view param p)) jwk
+ , fmap (\p -> (view isProtected p, "kid" .= view param p)) kid
+ , fmap (\p -> (view isProtected p, "x5u" .= view param p)) x5u
+ , fmap (\p -> (view isProtected p, "x5c" .= view param p)) x5c
+ , fmap (\p -> (view isProtected p, "x5t" .= view param p)) x5t
+ , fmap (\p -> (view isProtected p, "x5t#S256" .= view param p)) x5tS256
+ , fmap (\p -> (view isProtected p, "typ" .= view param p)) typ
+ , fmap (\p -> (view isProtected p, "cty" .= view param p)) cty
+ , fmap (\p -> (True, "crit" .= p)) crit
]
- ++ Types.objectPairs (toJSON crit)
- ++ maybe [] (Types.objectPairs . toJSON) alg
-
-instance FromArmour T.Text Error JWEHeader where
- parseArmour s =
- first (compactErr "header")
- (B64UL.decode (L.fromStrict $ Types.pad $ T.encodeUtf8 s))
- >>= first JSONDecodeError . eitherDecode
- where
- compactErr s' = CompactDecodeError . ((s' ++ " decode failed: ") ++)
-
-instance ToArmour T.Text JWEHeader where
- toArmour = T.decodeUtf8 . Types.unpad . B64U.encode . L.toStrict . encode
-data JWERecipient = JWERecipient
- { _jweHeader :: Maybe JWEHeader -- ^ JWE Per-Recipient Unprotected Header
+data JWERecipient a p = JWERecipient
+ { _jweHeader :: a p
, _jweEncryptedKey :: Maybe Types.Base64Octets -- ^ JWE Encrypted Key
}
-instance FromJSON JWERecipient where
+instance FromJSON (JWERecipient a p) where
parseJSON = withObject "JWE Recipient" $ \o -> JWERecipient
- <$> o .:? "header"
+ <$> undefined -- o .:? "header"
<*> o .:? "encrypted_key"
-data JWE = JWE
- { _jweProtected :: Maybe (Armour T.Text JWEHeader)
- , _jweUnprotected :: Maybe JWEHeader
+parseRecipient
+ :: (HasParams a, ProtectionIndicator p)
+ => Maybe Object -> Maybe Object -> Value -> Parser (JWERecipient a p)
+parseRecipient hp hu = withObject "JWE Recipient" $ \o -> do
+ hr <- o .:? "header"
+ JWERecipient
+ <$> parseParams hp (hu <> hr) -- TODO fail on key collision in (hr <> hu)
+ <*> o .:? "encrypted_key"
+
+-- parseParamsFor :: HasParams b => Proxy b -> Maybe Object -> Maybe Object -> Parser a
+
+data JWE a p = JWE
+ { _protectedRaw :: (Maybe T.Text) -- ^ Encoded protected header, if available
, _jweIv :: Maybe Types.Base64Octets -- ^ JWE Initialization Vector
, _jweAad :: Maybe Types.Base64Octets -- ^ JWE AAD
, _jweCiphertext :: Types.Base64Octets -- ^ JWE Ciphertext
, _jweTag :: Maybe Types.Base64Octets -- ^ JWE Authentication Tag
- , _jweRecipients :: [JWERecipient]
+ , _jweRecipients :: [JWERecipient a p]
}
-instance FromJSON JWE where
- parseJSON =
- withObject "JWE JSON Serialization" $ \o -> JWE
- <$> o .:? "protected"
- <*> o .:? "unprotected"
+instance (HasParams a, ProtectionIndicator p) => FromJSON (JWE a p) where
+ parseJSON = withObject "JWE JSON Serialization" $ \o -> do
+ hpB64 <- o .:? "protected"
+ hp <- maybe
+ (pure Nothing)
+ (withText "base64url-encoded header params"
+ (Types.parseB64Url (maybe
+ (fail "protected header contains invalid JSON")
+ pure . decode . L.fromStrict)))
+ hpB64
+ hu <- o .:? "unprotected"
+ JWE
+ <$> (Just <$> (o .: "protected" <|> pure "")) -- raw protected header
<*> o .:? "iv"
<*> o .:? "aad"
<*> o .: "ciphertext"
<*> o .:? "tag"
- <*> o .: "recipients"
+ <*> (o .: "recipients" >>= traverse (parseRecipient hp hu))
-- TODO flattened serialization
@@ -195,11 +185,11 @@ wrap RSA_OAEP _ _ = return $ Left $ AlgorithmMismatch "Cannot use RSA_OAEP with
wrap alg@RSA_OAEP_256 (RSAKeyMaterial k) m = bimap RSAError (alg,) <$>
OAEP.encrypt (OAEP.OAEPParams SHA256 (mgf1 SHA256) Nothing) (rsaPublicKey k) m
wrap RSA_OAEP_256 _ _ = return $ Left $ AlgorithmMismatch "Cannot use RSA_OAEP_256 with non-RSA key"
-wrap A128KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m
+wrap A128KW (OctKeyMaterial (OctKeyParameters (Types.Base64Octets k))) m
= return $ (A128KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES128) m
-wrap A192KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m
+wrap A192KW (OctKeyMaterial (OctKeyParameters (Types.Base64Octets k))) m
= return $ (A192KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES192) m
-wrap A256KW (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m
+wrap A256KW (OctKeyMaterial (OctKeyParameters (Types.Base64Octets k))) m
= return $ (A256KW,) <$> wrapAESKW (cipherInit k :: CryptoFailable AES256) m
wrap (A128GCMKW _) k m = wrapAESGCM A128GCMKW A128GCM k m
wrap (A192GCMKW _) k m = wrapAESGCM A192GCMKW A192GCM k m
@@ -222,7 +212,7 @@ wrapAESGCM
-> KeyMaterial
-> B.ByteString
-> m (Either Error (AlgWithParams, B.ByteString))
-wrapAESGCM f enc (OctKeyMaterial (OctKeyParameters _ (Types.Base64Octets k))) m =
+wrapAESGCM f enc (OctKeyMaterial (OctKeyParameters (Types.Base64Octets k))) m =
fmap (\(iv, tag, m') -> (f (AESGCMParameters (Types.Base64Octets iv) (Types.Base64Octets tag)), m'))
<$> encrypt enc k m ""
wrapAESGCM _ _ _ _ = return $ Left $ AlgorithmMismatch "Cannot use AESGCMKW with non-Oct key"
diff --git a/src/Crypto/JOSE/JWK.hs b/src/Crypto/JOSE/JWK.hs
index 5e2e37c..31f29d4 100644
--- a/src/Crypto/JOSE/JWK.hs
+++ b/src/Crypto/JOSE/JWK.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale
+-- Copyright (C) 2013, 2014, 2015, 2016, 2017 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -12,6 +12,9 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -24,36 +27,87 @@ structure that represents a cryptographic key. This module also
defines a JSON Web Key Set (JWK Set) JSON data structure for
representing a set of JWKs.
+@
+-- Generate RSA JWK and set "kid" param to
+-- base64url-encoded SHA-256 thumbprint of key.
+--
+doGen :: IO JWK
+doGen = do
+ jwk <- 'genJWK' (RSAGenParam (4096 \`div` 8))
+ let
+ h = view 'thumbprint' jwk :: Digest SHA256
+ kid = view (re ('base64url' . 'digest') . utf8) h
+ pure $ set 'jwkKid' (Just kid) jwk
+@
+
-}
module Crypto.JOSE.JWK
(
- JWK(JWK)
+ -- * JWK generation
+ genJWK
+ , KeyMaterialGenParam(..)
+ , Crv(..)
+ , OKPCrv(..)
+ , JWK
+ , AsPublicKey(..)
+
+ -- * Parts of a JWK
, jwkMaterial
, jwkUse
+ , KeyUse(..)
, jwkKeyOps
+ , KeyOp(..)
, jwkAlg
+ , JWKAlg(..)
, jwkKid
, jwkX5u
, jwkX5c
, jwkX5t
, jwkX5tS256
+
+ -- * Converting from other key formats
, fromKeyMaterial
- , genJWK
+ , fromRSA
+ , fromOctets
+
+#if MIN_VERSION_aeson(0,10,0)
+ -- * JWK Thumbprint
+ , thumbprint
+ , digest
+ , Types.base64url
+ , module Crypto.Hash
+#endif
+ -- * JWK Set
, JWKSet(..)
+ -- Miscellaneous
+ , bestJWSAlg
+
, module Crypto.JOSE.JWA.JWK
) where
import Control.Applicative
import Data.Maybe (catMaybes)
+import Data.Monoid ((<>))
+import Data.Word (Word8)
import Control.Lens hiding ((.=))
+import Control.Lens.Cons.Extras (recons)
+import Control.Monad.Except (MonadError(throwError))
+import Crypto.Hash
+import qualified Crypto.PubKey.RSA as RSA
import Data.Aeson
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Builder as Builder
import Data.List.NonEmpty
+import qualified Data.Text as T
import Test.QuickCheck
+import Crypto.JOSE.Error
import qualified Crypto.JOSE.JWA.JWE.Alg as JWA.JWE
import Crypto.JOSE.JWA.JWK
import qualified Crypto.JOSE.JWA.JWS as JWA.JWS
@@ -62,20 +116,25 @@ import qualified Crypto.JOSE.Types as Types
import qualified Crypto.JOSE.Types.Internal as Types
--- | JWK §3.3. "alg" (Algorithm) Parameter
+-- | RFC 7517 §4.4. "alg" (Algorithm) Parameter
--
-data Alg = JWSAlg JWA.JWS.Alg | JWEAlg JWA.JWE.Alg
+-- See also RFC 7518 §6.4. which states that for "oct" keys, an
+-- "alg" member SHOULD be present to identify the algorithm intended
+-- to be used with the key, unless the application uses another
+-- means or convention to determine the algorithm used.
+--
+data JWKAlg = JWSAlg JWA.JWS.Alg | JWEAlg JWA.JWE.Alg
deriving (Eq, Show)
-instance FromJSON Alg where
+instance FromJSON JWKAlg where
parseJSON v = (JWSAlg <$> parseJSON v) <|> (JWEAlg <$> parseJSON v)
-instance ToJSON Alg where
+instance ToJSON JWKAlg where
toJSON (JWSAlg alg) = toJSON alg
toJSON (JWEAlg alg) = toJSON alg
--- | JWK §3.3. "key_ops" (Key Operations) Parameter
+-- | RFC 7517 §4.3. "key_ops" (Key Operations) Parameter
--
$(Crypto.JOSE.TH.deriveJOSEType "KeyOp"
[ "sign", "verify", "encrypt", "decrypt"
@@ -83,20 +142,20 @@ $(Crypto.JOSE.TH.deriveJOSEType "KeyOp"
])
--- | JWK §3.2. "use" (Public Key Use) Parameter
+-- | RFC 7517 §4.2. "use" (Public Key Use) Parameter
--
$(Crypto.JOSE.TH.deriveJOSEType "KeyUse" ["sig", "enc"])
--- | JWK §3. JSON Web Key (JWK) Format
+-- | RFC 7517 §4. JSON Web Key (JWK) Format
--
data JWK = JWK
{
_jwkMaterial :: Crypto.JOSE.JWA.JWK.KeyMaterial
, _jwkUse :: Maybe KeyUse
, _jwkKeyOps :: Maybe [KeyOp]
- , _jwkAlg :: Maybe Alg
- , _jwkKid :: Maybe String
+ , _jwkAlg :: Maybe JWKAlg
+ , _jwkKid :: Maybe T.Text
, _jwkX5u :: Maybe Types.URI
, _jwkX5c :: Maybe (NonEmpty Types.Base64X509)
, _jwkX5t :: Maybe Types.Base64SHA1
@@ -130,6 +189,8 @@ instance ToJSON JWK where
]
++ Types.objectPairs (toJSON _jwkMaterial)
+-- | Generate a JWK. Apart from key parameters, no other parameters are set.
+--
genJWK :: MonadRandom m => KeyMaterialGenParam -> m JWK
genJWK p = fromKeyMaterial <$> genKeyMaterial p
@@ -149,13 +210,87 @@ fromKeyMaterial :: KeyMaterial -> JWK
fromKeyMaterial k = JWK k z z z z z z z z where z = Nothing
+-- | Convert RSA private key into a JWK
+--
+fromRSA :: RSA.PrivateKey -> JWK
+fromRSA = fromKeyMaterial . RSAKeyMaterial . toRSAKeyParameters
+
+-- | Convert octet string into a JWK
+--
+fromOctets :: Cons s s Word8 Word8 => s -> JWK
+fromOctets =
+ fromKeyMaterial . OctKeyMaterial . OctKeyParameters . Types.Base64Octets
+ . view recons
+
+
instance AsPublicKey JWK where
- asPublicKey = prism' id (jwkMaterial (preview asPublicKey))
+ asPublicKey = to (jwkMaterial (view asPublicKey))
--- | JWK §4. JSON Web Key Set (JWK Set) Format
+-- | RFC 7517 §5. JWK Set Format
--
newtype JWKSet = JWKSet [JWK] deriving (Eq, Show)
instance FromJSON JWKSet where
parseJSON = withObject "JWKSet" (\o -> JWKSet <$> o .: "keys")
+
+
+-- | Choose the cryptographically strongest JWS algorithm for a
+-- given key. The JWK "alg" algorithm parameter is ignored.
+--
+bestJWSAlg
+ :: (MonadError e m, AsError e)
+ => JWK
+ -> m JWA.JWS.Alg
+bestJWSAlg jwk = case view jwkMaterial jwk of
+ ECKeyMaterial k -> pure $ case ecCrv k of
+ P_256 -> JWA.JWS.ES256
+ P_384 -> JWA.JWS.ES384
+ P_521 -> JWA.JWS.ES512
+ RSAKeyMaterial k ->
+ let
+ Types.SizedBase64Integer _ n = view rsaN k
+ in
+ if n >= 2 ^ (2040 :: Integer)
+ then pure JWA.JWS.PS512
+ else throwError (review _KeySizeTooSmall ())
+ OctKeyMaterial (OctKeyParameters { octK = Types.Base64Octets k })
+ | B.length k >= 512 `div` 8 -> pure JWA.JWS.HS512
+ | B.length k >= 384 `div` 8 -> pure JWA.JWS.HS384
+ | B.length k >= 256 `div` 8 -> pure JWA.JWS.HS256
+ | otherwise -> throwError (review _KeySizeTooSmall ())
+ OKPKeyMaterial (Ed25519Key _ _) -> pure JWA.JWS.EdDSA
+ OKPKeyMaterial _ -> throwError (review _KeyMismatch "Cannot sign with OKP ECDH key")
+
+
+#if MIN_VERSION_aeson(0,10,0)
+-- | Compute the JWK Thumbprint of a JWK
+--
+thumbprint :: HashAlgorithm a => Getter JWK (Digest a)
+thumbprint = to (hash . L.toStrict . thumbprintRepr)
+
+-- | Prism from ByteString to @HashAlgorithm a => Digest a@.
+--
+-- Use @'re' digest@ to view the bytes of a digest
+--
+digest :: HashAlgorithm a => Prism' B.ByteString (Digest a)
+digest = prism' BA.convert digestFromByteString
+
+-- | JWK canonicalised for thumbprint computation
+--
+thumbprintRepr :: JWK -> L.ByteString
+thumbprintRepr k = Builder.toLazyByteString . fromEncoding . pairs $
+ case view jwkMaterial k of
+ ECKeyMaterial ECKeyParameters {..} ->
+ "crv" .= ecCrv <> "kty" .= ("EC" :: T.Text) <> "x" .= ecX <> "y" .= ecY
+ RSAKeyMaterial k' ->
+ "e" .= view rsaE k' <> "kty" .= ("RSA" :: T.Text) <> "n" .= view rsaN k'
+ OctKeyMaterial (OctKeyParameters k') ->
+ "k" .= k' <> "kty" .= ("oct" :: T.Text)
+ OKPKeyMaterial (Ed25519Key pk _) -> okpSeries "Ed25519" pk
+ OKPKeyMaterial (X25519Key pk _) -> okpSeries "X25519" pk
+ where
+ b64 = Types.Base64Octets . BA.convert
+ okpSeries crv pk =
+ "crv" .= (crv :: T.Text) <> "kty" .= ("OKP" :: T.Text) <> "x" .= b64 pk
+#endif
diff --git a/src/Crypto/JOSE/JWK/Store.hs b/src/Crypto/JOSE/JWK/Store.hs
new file mode 100644
index 0000000..67e7fbe
--- /dev/null
+++ b/src/Crypto/JOSE/JWK/Store.hs
@@ -0,0 +1,52 @@
+-- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+-- http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+
+{-# LANGUAGE RankNTypes #-}
+
+{-|
+
+A 'JWKStore' provides JWK enumeration and lookup.
+
+-}
+module Crypto.JOSE.JWK.Store
+ (
+ JWKStore(..)
+ ) where
+
+
+import Control.Lens (Fold, folding)
+
+import Crypto.JOSE.Header
+import Crypto.JOSE.JWK (JWK, JWKSet(..), KeyOp)
+
+class JWKStore a where
+ -- | Enumerate keys
+ keys :: Fold a JWK
+
+ -- | Look up key by JWS/JWE header
+ keysFor
+ :: ( HasAlg h, HasJku h, HasJwk h, HasKid h
+ , HasX5u h, HasX5c h, HasX5t h, HasX5tS256 h
+ , HasTyp h, HasCty h )
+ => KeyOp
+ -> h p
+ -> Fold a JWK
+ keysFor _ _ = keys
+
+
+instance JWKStore JWK where
+ keys = id
+
+instance JWKStore JWKSet where
+ keys = folding (\(JWKSet xs) -> xs)
diff --git a/src/Crypto/JOSE/JWS.hs b/src/Crypto/JOSE/JWS.hs
index f162c6a..ead54e7 100644
--- a/src/Crypto/JOSE/JWS.hs
+++ b/src/Crypto/JOSE/JWS.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2013, 2014 Fraser Tweedale
+-- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -16,25 +16,593 @@
JSON Web Signature (JWS) represents content secured with digital
signatures or Message Authentication Codes (MACs) using JavaScript
-Object Notation (JSON) based data structures.
+Object Notation (JSON) based data structures. It is defined in
+<https://tools.ietf.org/html/rfc7515 RFC 7515>.
+
+@
+doJwsSign :: 'JWK' -> L.ByteString -> IO (Either 'Error' ('GeneralJWS' 'JWSHeader'))
+doJwsSign jwk payload = runExceptT $ do
+ alg \<- 'bestJWSAlg' jwk
+ 'signJWS' payload [('newJWSHeader' ('Protected', alg), jwk)]
+
+doJwsVerify :: 'JWK' -> 'GeneralJWS' 'JWSHeader' -> IO (Either 'Error' ())
+doJwsVerify jwk jws = runExceptT $ 'verifyJWS'' jwk jws
+@
-}
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
module Crypto.JOSE.JWS
(
- Alg(..)
+ -- * Overview
+ JWS
+ , GeneralJWS
+ , FlattenedJWS
+ , CompactJWS
- , JWSHeader(..)
- , newJWSHeader
+ -- ** Defining additional header parameters
+ -- $extending
- , JWS(..)
- , newJWS
- , jwsPayload
+ -- * JWS creation
+ , newJWSHeader
, signJWS
- , ValidationAlgorithms(..)
- , ValidationPolicy(..)
+ -- * JWS verification
, verifyJWS
+ , verifyJWS'
+
+ -- ** JWS validation settings
+ , defaultValidationSettings
+ , ValidationSettings
+ , ValidationPolicy(..)
+ , HasValidationSettings(..)
+ , HasAlgorithms(..)
+ , HasValidationPolicy(..)
+
+ -- * Signature data
+ , signatures
+ , Signature
+ , header
+ , signature
+
+ -- * JWS headers
+ , Alg(..)
+ , HasJWSHeader(..)
+ , JWSHeader
+
+ , module Crypto.JOSE.Error
+ , module Crypto.JOSE.Header
+ , module Crypto.JOSE.JWK
) where
+import Control.Applicative ((<|>))
+import Data.Foldable (toList)
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Monoid ((<>))
+import Data.List.NonEmpty (NonEmpty)
+import Data.Traversable (traverse)
+import Data.Word (Word8)
+
+import Control.Lens hiding ((.=))
+import Control.Lens.Cons.Extras (recons)
+import Control.Monad.Except (MonadError(throwError))
+import Data.Aeson
+import qualified Data.ByteString as B
+import qualified Data.HashMap.Strict as M
+import qualified Data.Set as S
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+
+import Crypto.JOSE.Compact
+import Crypto.JOSE.Error
import Crypto.JOSE.JWA.JWS
-import Crypto.JOSE.JWS.Internal
+import Crypto.JOSE.JWK
+import Crypto.JOSE.JWK.Store
+import Crypto.JOSE.Header
+import qualified Crypto.JOSE.Types as Types
+import qualified Crypto.JOSE.Types.Internal as Types
+
+{- $extending
+
+Several specifications extend JWS with additional header parameters.
+The 'JWS' type is parameterised over the header type; this library
+provides the 'JWSHeader' type which encompasses all the JWS header
+parameters defined in RFC 7515. To define an extended header type
+declare the data type, and instances for 'HasJWSHeader' and
+'HasParams'. For example:
+
+@
+data ACMEHeader p = ACMEHeader
+ { _acmeJwsHeader :: 'JWSHeader' p
+ , _acmeNonce :: 'Types.Base64Octets'
+ }
+
+acmeJwsHeader :: Lens' (ACMEHeader p) (JWSHeader p)
+acmeJwsHeader f s\@(ACMEHeader { _acmeJwsHeader = a}) =
+ fmap (\\a' -> s { _acmeJwsHeader = a'}) (f a)
+
+acmeNonce :: Lens' (ACMEHeader p) Types.Base64Octets
+acmeNonce f s\@(ACMEHeader { _acmeNonce = a}) =
+ fmap (\\a' -> s { _acmeNonce = a'}) (f a)
+
+instance HasJWSHeader ACMEHeader where
+ jwsHeader = acmeJwsHeader
+
+instance HasParams ACMEHeader where
+ 'parseParamsFor' proxy hp hu = ACMEHeader
+ \<$> 'parseParamsFor' proxy hp hu
+ \<*> 'headerRequiredProtected' "nonce" hp hu
+ params h =
+ (True, "nonce" .= view acmeNonce h)
+ : 'params' (view acmeJwsHeader h)
+ 'extensions' = const ["nonce"]
+@
+
+See also:
+
+- 'HasParams'
+- 'headerRequired'
+- 'headerRequiredProtected'
+- 'headerOptional'
+- 'headerOptionalProtected'
+
+-}
+
+
+jwsCritInvalidNames :: [T.Text]
+jwsCritInvalidNames = [
+ "alg"
+ , "jku"
+ , "jwk"
+ , "x5u"
+ , "x5t"
+ , "x5t#S256"
+ , "x5c"
+ , "kid"
+ , "typ"
+ , "cty"
+ , "crit"
+ ]
+
+-- | JWS Header data type.
+--
+data JWSHeader p = JWSHeader
+ { _jwsHeaderAlg :: HeaderParam p Alg
+ , _jwsHeaderJku :: Maybe (HeaderParam p Types.URI) -- ^ JWK Set URL
+ , _jwsHeaderJwk :: Maybe (HeaderParam p JWK)
+ , _jwsHeaderKid :: Maybe (HeaderParam p String) -- ^ interpretation unspecified
+ , _jwsHeaderX5u :: Maybe (HeaderParam p Types.URI)
+ , _jwsHeaderX5c :: Maybe (HeaderParam p (NonEmpty Types.Base64X509))
+ , _jwsHeaderX5t :: Maybe (HeaderParam p Types.Base64SHA1)
+ , _jwsHeaderX5tS256 :: Maybe (HeaderParam p Types.Base64SHA256)
+ , _jwsHeaderTyp :: Maybe (HeaderParam p String) -- ^ Content Type (of object)
+ , _jwsHeaderCty :: Maybe (HeaderParam p String) -- ^ Content Type (of payload)
+ , _jwsHeaderCrit :: Maybe (NonEmpty T.Text)
+ }
+ deriving (Eq, Show)
+
+instance HasAlg JWSHeader where
+ alg f h@(JWSHeader { _jwsHeaderAlg = a }) =
+ fmap (\a' -> h { _jwsHeaderAlg = a' }) (f a)
+instance HasJku JWSHeader where
+ jku f h@(JWSHeader { _jwsHeaderJku = a }) =
+ fmap (\a' -> h { _jwsHeaderJku = a' }) (f a)
+instance HasJwk JWSHeader where
+ jwk f h@(JWSHeader { _jwsHeaderJwk = a }) =
+ fmap (\a' -> h { _jwsHeaderJwk = a' }) (f a)
+instance HasKid JWSHeader where
+ kid f h@(JWSHeader { _jwsHeaderKid = a }) =
+ fmap (\a' -> h { _jwsHeaderKid = a' }) (f a)
+instance HasX5u JWSHeader where
+ x5u f h@(JWSHeader { _jwsHeaderX5u = a }) =
+ fmap (\a' -> h { _jwsHeaderX5u = a' }) (f a)
+instance HasX5c JWSHeader where
+ x5c f h@(JWSHeader { _jwsHeaderX5c = a }) =
+ fmap (\a' -> h { _jwsHeaderX5c = a' }) (f a)
+instance HasX5t JWSHeader where
+ x5t f h@(JWSHeader { _jwsHeaderX5t = a }) =
+ fmap (\a' -> h { _jwsHeaderX5t = a' }) (f a)
+instance HasX5tS256 JWSHeader where
+ x5tS256 f h@(JWSHeader { _jwsHeaderX5tS256 = a }) =
+ fmap (\a' -> h { _jwsHeaderX5tS256 = a' }) (f a)
+instance HasTyp JWSHeader where
+ typ f h@(JWSHeader { _jwsHeaderTyp = a }) =
+ fmap (\a' -> h { _jwsHeaderTyp = a' }) (f a)
+instance HasCty JWSHeader where
+ cty f h@(JWSHeader { _jwsHeaderCty = a }) =
+ fmap (\a' -> h { _jwsHeaderCty = a' }) (f a)
+instance HasCrit JWSHeader where
+ crit f h@(JWSHeader { _jwsHeaderCrit = a }) =
+ fmap (\a' -> h { _jwsHeaderCrit = a' }) (f a)
+
+class HasJWSHeader a where
+ jwsHeader :: Lens' (a p) (JWSHeader p)
+
+instance HasJWSHeader JWSHeader where
+ jwsHeader = id
+
+instance {-# INCOHERENT #-} HasJWSHeader a => HasAlg a where
+ alg = jwsHeader . alg
+instance {-# INCOHERENT #-} HasJWSHeader a => HasJku a where
+ jku = jwsHeader . jku
+instance {-# INCOHERENT #-} HasJWSHeader a => HasJwk a where
+ jwk = jwsHeader . jwk
+instance {-# INCOHERENT #-} HasJWSHeader a => HasKid a where
+ kid = jwsHeader . kid
+instance {-# INCOHERENT #-} HasJWSHeader a => HasX5u a where
+ x5u = jwsHeader . x5u
+instance {-# INCOHERENT #-} HasJWSHeader a => HasX5c a where
+ x5c = jwsHeader . x5c
+instance {-# INCOHERENT #-} HasJWSHeader a => HasX5t a where
+ x5t = jwsHeader . x5t
+instance {-# INCOHERENT #-} HasJWSHeader a => HasX5tS256 a where
+ x5tS256 = jwsHeader . x5tS256
+instance {-# INCOHERENT #-} HasJWSHeader a => HasTyp a where
+ typ = jwsHeader . typ
+instance {-# INCOHERENT #-} HasJWSHeader a => HasCty a where
+ cty = jwsHeader . cty
+instance {-# INCOHERENT #-} HasJWSHeader a => HasCrit a where
+ crit = jwsHeader . crit
+
+
+-- | Construct a minimal header with the given algorithm and
+-- protection indicator for the /alg/ header.
+--
+newJWSHeader :: (p, Alg) -> (JWSHeader p)
+newJWSHeader a = JWSHeader (uncurry HeaderParam a) z z z z z z z z z z
+ where z = Nothing
+
+
+-- | Signature object containing header, and signature bytes.
+--
+-- If it was decoded from a serialised JWS, it "remembers" how the
+-- protected header was encoded; the remembered value is used when
+-- computing the signing input and when serialising the object.
+--
+-- The remembered value is not used in equality checks, i.e. two
+-- decoded signatures with differently serialised by otherwise equal
+-- protected headers, and equal signature bytes, are equal.
+--
+data Signature p a = Signature
+ (Maybe T.Text) -- Encoded protected header, if available
+ (a p) -- Header
+ Types.Base64Octets -- Signature
+ deriving (Show)
+
+-- | Getter for header of a signature
+header :: Getter (Signature p a) (a p)
+header = to (\(Signature _ h _) -> h)
+
+-- | Getter for signature bytes
+signature :: (Cons s s Word8 Word8, AsEmpty s) => Getter (Signature p a) s
+signature = to (\(Signature _ _ (Types.Base64Octets s)) -> s) . recons
+
+instance (Eq (a p)) => Eq (Signature p a) where
+ Signature _ h s == Signature _ h' s' = h == h' && s == s'
+
+instance (HasParams a, ProtectionIndicator p) => FromJSON (Signature p a) where
+ parseJSON = withObject "signature" (\o -> Signature
+ <$> (Just <$> (o .: "protected" <|> pure "")) -- raw protected header
+ <*> do
+ hpB64 <- o .:? "protected"
+ hp <- maybe
+ (pure Nothing)
+ (withText "base64url-encoded header params"
+ (Types.parseB64Url (maybe
+ (fail "protected header contains invalid JSON")
+ pure . decode . view recons)))
+ hpB64
+ hu <- o .:? "header"
+ parseParams hp hu
+ <*> o .: "signature"
+ )
+
+instance (HasParams a, ProtectionIndicator p) => ToJSON (Signature p a) where
+ toJSON (Signature _ h sig) =
+ let
+ pro = case protectedParamsEncoded h of
+ "" -> id
+ bs -> ("protected" .= String (T.decodeUtf8 (view recons bs)) :)
+ unp = case unprotectedParams h of
+ Nothing -> id
+ Just o -> ("header" .= o :)
+ in
+ object $ (pro . unp) [("signature" .= sig)]
+
+
+instance HasParams JWSHeader where
+ parseParamsFor proxy hp hu = JWSHeader
+ <$> headerRequired "alg" hp hu
+ <*> headerOptional "jku" hp hu
+ <*> headerOptional "jwk" hp hu
+ <*> headerOptional "kid" hp hu
+ <*> headerOptional "x5u" hp hu
+ <*> headerOptional "x5t" hp hu
+ <*> headerOptional "x5t#S256" hp hu
+ <*> headerOptional "x5c" hp hu
+ <*> headerOptional "typ" hp hu
+ <*> headerOptional "cty" hp hu
+ <*> (headerOptionalProtected "crit" hp hu
+ >>= parseCrit jwsCritInvalidNames (extensions proxy)
+ (fromMaybe mempty hp <> fromMaybe mempty hu))
+ params h =
+ catMaybes
+ [ Just (view (alg . isProtected) h, "alg" .= (view (alg . param) h))
+ , fmap (\p -> (view isProtected p, "jku" .= view param p)) (view jku h)
+ , fmap (\p -> (view isProtected p, "jwk" .= view param p)) (view jwk h)
+ , fmap (\p -> (view isProtected p, "kid" .= view param p)) (view kid h)
+ , fmap (\p -> (view isProtected p, "x5u" .= view param p)) (view x5u h)
+ , fmap (\p -> (view isProtected p, "x5c" .= view param p)) (view x5c h)
+ , fmap (\p -> (view isProtected p, "x5t" .= view param p)) (view x5t h)
+ , fmap (\p -> (view isProtected p, "x5t#S256" .= view param p)) (view x5tS256 h)
+ , fmap (\p -> (view isProtected p, "typ" .= view param p)) (view typ h)
+ , fmap (\p -> (view isProtected p, "cty" .= view param p)) (view cty h)
+ , fmap (\p -> (True, "crit" .= p)) (view crit h)
+ ]
+
+
+-- | JSON Web Signature data type. The payload can only be
+-- accessed by verifying the JWS.
+--
+-- Parameterised by the signature container type, the header
+-- 'ProtectionIndicator' type, and the header record type.
+--
+-- Use 'encode' and 'decode' to convert a JWS to or from JSON.
+-- When encoding a @'JWS' []@ with exactly one signature, the
+-- /flattened JWS JSON serialisation/ syntax is used, otherwise
+-- the /general JWS JSON serialisation/ is used.
+-- When decoding a @'JWS' []@ either serialisation is accepted.
+--
+-- @'JWS' 'Identity'@ uses the flattened JSON serialisation
+-- or the /JWS compact serialisation/ (see 'decodeCompact' and
+-- 'encodeCompact').
+--
+-- Use 'signJWS' to create a signed/MACed JWS.
+--
+-- Use 'verifyJWS' to verify a JWS and extract the payload.
+--
+data JWS t p a = JWS Types.Base64Octets (t (Signature p a))
+
+-- | A JWS that allows multiple signatures, and cannot use
+-- the /compact serialisation/. Headers may be 'Protected'
+-- or 'Unprotected'.
+--
+type GeneralJWS = JWS [] Protection
+
+-- | A JWS with one signature, which uses the
+-- /flattened serialisation/. Headers may be 'Protected'
+-- or 'Unprotected'.
+--
+type FlattenedJWS = JWS Identity Protection
+
+-- | A JWS with one signature which only allows protected
+-- parameters. Can use the /flattened serialisation/ or
+-- the /compact serialisation/.
+--
+type CompactJWS = JWS Identity ()
+
+instance (Eq (t (Signature p a))) => Eq (JWS t p a) where
+ JWS p sigs == JWS p' sigs' = p == p' && sigs == sigs'
+
+instance (Show (t (Signature p a))) => Show (JWS t p a) where
+ show (JWS p sigs) = "JWS " <> show p <> " " <> show sigs
+
+signatures :: Foldable t => Fold (JWS t p a) (Signature p a)
+signatures = folding (\(JWS _ sigs) -> sigs)
+
+instance (HasParams a, ProtectionIndicator p) => FromJSON (JWS [] p a) where
+ parseJSON v =
+ withObject "JWS JSON serialization" (\o -> JWS
+ <$> o .: "payload"
+ <*> o .: "signatures") v
+ <|> fmap (\(JWS p (Identity s)) -> JWS p [s]) (parseJSON v)
+
+instance (HasParams a, ProtectionIndicator p) => FromJSON (JWS Identity p a) where
+ parseJSON =
+ withObject "Flattened JWS JSON serialization" $ \o ->
+ if M.member "signatures" o
+ then fail "\"signatures\" member MUST NOT be present"
+ else (\p s -> JWS p (pure s)) <$> o .: "payload" <*> parseJSON (Object o)
+
+instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS [] p a) where
+ toJSON (JWS p [s]) = object $ "payload" .= p : Types.objectPairs (toJSON s)
+ toJSON (JWS p ss) = object ["payload" .= p, "signatures" .= ss]
+
+instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS Identity p a) where
+ toJSON (JWS p (Identity s)) = object $ "payload" .= p : Types.objectPairs (toJSON s)
+
+
+signingInput
+ :: (HasParams a, ProtectionIndicator p)
+ => Either T.Text (a p)
+ -> B.ByteString
+ -> B.ByteString
+signingInput h p = B.intercalate "."
+ [ either T.encodeUtf8 (view recons . protectedParamsEncoded) h
+ , review Types.base64url p
+ ]
+
+-- Convert JWS to compact serialization.
+--
+-- The operation is defined only when there is exactly one
+-- signature and returns Nothing otherwise
+--
+instance HasParams a => ToCompact (JWS Identity () a) where
+ toCompact (JWS (Types.Base64Octets p) (Identity (Signature raw h (Types.Base64Octets sig)))) =
+ [ view recons $ signingInput (maybe (Right h) Left raw) p
+ , review Types.base64url sig
+ ]
+
+instance HasParams a => FromCompact (JWS Identity () a) where
+ fromCompact xs = case xs of
+ [h, p, s] -> do
+ (h', p', s') <- (,,) <$> t h <*> t p <*> t s
+ let o = object [ ("payload", p'), ("protected", h'), ("signature", s') ]
+ case fromJSON o of
+ Error e -> throwError (compactErr e)
+ Success a -> pure a
+ xs' -> throwError $ compactErr $ "expected 3 parts, got " ++ show (length xs')
+ where
+ compactErr = review _CompactDecodeError
+ t = either (throwError . compactErr . show) (pure . String)
+ . T.decodeUtf8' . view recons
+
+
+-- | Create a signed or MACed JWS with the given payload by
+-- traversing a collection of @(header, key)@ pairs.
+--
+signJWS
+ :: ( Cons s s Word8 Word8
+ , HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m
+ , Traversable t
+ , ProtectionIndicator p
+ )
+ => s -- ^ Payload
+ -> t ((a p), JWK) -- ^ Traversable of header, key pairs
+ -> m (JWS t p a)
+signJWS s =
+ let s' = view recons s
+ in fmap (JWS (Types.Base64Octets s')) . traverse (uncurry (mkSignature s'))
+
+mkSignature
+ :: ( HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m
+ , ProtectionIndicator p
+ )
+ => B.ByteString -> a p -> JWK -> m (Signature p a)
+mkSignature p h k =
+ Signature Nothing h . Types.Base64Octets
+ <$> sign (view (alg . param) h) (k ^. jwkMaterial) (signingInput (Right h) p)
+
+
+-- | Validation policy.
+--
+data ValidationPolicy
+ = AnyValidated
+ -- ^ One successfully validated signature is sufficient
+ | AllValidated
+ -- ^ All signatures in all configured algorithms must be validated.
+ -- No signatures in configured algorithms is also an error.
+ deriving (Eq)
+
+-- | Validation settings:
+--
+-- * The set of acceptable signature algorithms
+-- * The validation policy
+--
+data ValidationSettings = ValidationSettings
+ (S.Set Alg)
+ ValidationPolicy
+
+class HasValidationSettings a where
+ validationSettings :: Lens' a ValidationSettings
+
+ validationSettingsAlgorithms :: Lens' a (S.Set Alg)
+ validationSettingsAlgorithms = validationSettings . go where
+ go f (ValidationSettings algs pol) =
+ (\algs' -> ValidationSettings algs' pol) <$> f algs
+
+ validationSettingsValidationPolicy :: Lens' a ValidationPolicy
+ validationSettingsValidationPolicy = validationSettings . go where
+ go f (ValidationSettings algs pol) =
+ (\pol' -> ValidationSettings algs pol') <$> f pol
+
+instance HasValidationSettings ValidationSettings where
+ validationSettings = id
+
+class HasAlgorithms s where
+ algorithms :: Lens' s (S.Set Alg)
+class HasValidationPolicy s where
+ validationPolicy :: Lens' s ValidationPolicy
+
+instance HasValidationSettings a => HasAlgorithms a where
+ algorithms = validationSettingsAlgorithms
+instance HasValidationSettings a => HasValidationPolicy a where
+ validationPolicy = validationSettingsValidationPolicy
+
+-- | The default validation settings.
+--
+-- - All algorithms except "none" are acceptable.
+-- - All signatures must be valid (and there must be at least one signature.)
+--
+defaultValidationSettings :: ValidationSettings
+defaultValidationSettings = ValidationSettings
+ ( S.fromList
+ [ HS256, HS384, HS512
+ , RS256, RS384, RS512
+ , ES256, ES384, ES512
+ , PS256, PS384, PS512
+ , EdDSA
+ ] )
+ AllValidated
+
+-- | Verify a JWS with the default validation settings.
+--
+-- See also 'defaultValidationSettings'.
+--
+verifyJWS'
+ :: ( AsError e, MonadError e m , HasJWSHeader h, HasParams h , JWKStore k
+ , Cons s s Word8 Word8, AsEmpty s
+ , Foldable t
+ , ProtectionIndicator p
+ )
+ => k -- ^ key or key store
+ -> JWS t p h -- ^ JWS
+ -> m s
+verifyJWS' = verifyJWS defaultValidationSettings
+
+-- | Verify a JWS.
+--
+-- Signatures made with an unsupported algorithms are ignored.
+-- If the validation policy is 'AnyValidated', a single successfully
+-- validated signature is sufficient. If the validation policy is
+-- 'AllValidated' then all remaining signatures (there must be at least one)
+-- must be valid.
+--
+-- Returns the payload if successfully verified.
+--
+verifyJWS
+ :: ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m
+ , HasJWSHeader h, HasParams h
+ , JWKStore k
+ , Cons s s Word8 Word8, AsEmpty s
+ , Foldable t
+ , ProtectionIndicator p
+ )
+ => a -- ^ validation settings
+ -> k -- ^ key or key store
+ -> JWS t p h -- ^ JWS
+ -> m s
+verifyJWS conf k (JWS p@(Types.Base64Octets p') sigs) =
+ let
+ algs :: S.Set Alg
+ algs = conf ^. algorithms
+ policy :: ValidationPolicy
+ policy = conf ^. validationPolicy
+ shouldValidateSig = (`elem` algs) . view (header . alg . param)
+ out = view recons p'
+ applyPolicy AnyValidated xs =
+ if or xs then pure out else throwError (review _JWSNoValidSignatures ())
+ applyPolicy AllValidated [] = throwError (review _JWSNoSignatures ())
+ applyPolicy AllValidated xs =
+ if and xs then pure out else throwError (review _JWSInvalidSignature ())
+ validate s =
+ let h = view header s
+ in anyOf (keysFor Verify h) ((== Right True) . verifySig p s) k
+ in
+ applyPolicy policy $ map validate $ filter shouldValidateSig $ toList sigs
+
+verifySig
+ :: (HasJWSHeader a, HasParams a, ProtectionIndicator p)
+ => Types.Base64Octets
+ -> Signature p a
+ -> JWK
+ -> Either Error Bool
+verifySig (Types.Base64Octets m) (Signature raw h (Types.Base64Octets s)) k =
+ verify (view (alg . param) h) (view jwkMaterial k) tbs s
+ where
+ tbs = signingInput (maybe (Right h) Left raw) m
diff --git a/src/Crypto/JOSE/JWS/Internal.hs b/src/Crypto/JOSE/JWS/Internal.hs
deleted file mode 100644
index 71911f8..0000000
--- a/src/Crypto/JOSE/JWS/Internal.hs
+++ /dev/null
@@ -1,328 +0,0 @@
--- Copyright (C) 2013, 2014, 2015 Fraser Tweedale
---
--- Licensed under the Apache License, Version 2.0 (the "License");
--- you may not use this file except in compliance with the License.
--- You may obtain a copy of the License at
---
--- http://www.apache.org/licenses/LICENSE-2.0
---
--- Unless required by applicable law or agreed to in writing, software
--- distributed under the License is distributed on an "AS IS" BASIS,
--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--- See the License for the specific language governing permissions and
--- limitations under the License.
-
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_HADDOCK hide #-}
-
-module Crypto.JOSE.JWS.Internal where
-
-import Prelude hiding (mapM)
-
-import Control.Applicative
-import Control.Monad ((>=>), when, unless)
-import Data.Bifunctor
-import Data.Maybe
-
-import Control.Lens ((^.))
-import Data.Aeson
-import qualified Data.Aeson.Parser as P
-import Data.Aeson.Types
-import qualified Data.Attoparsec.ByteString.Lazy as A
-import Data.Byteable
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.ByteString.Base64.URL as B64U
-import qualified Data.ByteString.Base64.URL.Lazy as B64UL
-import Data.Default.Class
-import Data.HashMap.Strict (member)
-import Data.List.NonEmpty (NonEmpty(..), toList)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import Data.Traversable (mapM)
-
-import Crypto.JOSE.Compact
-import Crypto.JOSE.Error
-import qualified Crypto.JOSE.JWA.JWS as JWA.JWS
-import Crypto.JOSE.JWK
-import qualified Crypto.JOSE.Types as Types
-import qualified Crypto.JOSE.Types.Internal as Types
-import Crypto.JOSE.Types.Armour
-
-
-critInvalidNames :: [T.Text]
-critInvalidNames = [
- "alg"
- , "jku"
- , "jwk"
- , "x5u"
- , "x5t"
- , "x5t#S256"
- , "x5c"
- , "kid"
- , "typ"
- , "cty"
- , "crit"
- ]
-
-newtype CritParameters = CritParameters (NonEmpty (T.Text, Value))
- deriving (Eq, Show)
-
-critObjectParser :: Object -> T.Text -> Parser (T.Text, Value)
-critObjectParser o s
- | s `elem` critInvalidNames = fail "crit key is reserved"
- | otherwise = (\v -> (s, v)) <$> o .: s
-
-parseCrit :: Object -> NonEmpty T.Text -> Parser CritParameters
-parseCrit o = fmap CritParameters . mapM (critObjectParser o)
- -- TODO fail on duplicate strings
-
-instance FromJSON CritParameters where
- parseJSON = withObject "crit" $ \o -> o .: "crit" >>= parseCrit o
-
-instance ToJSON CritParameters where
- toJSON (CritParameters m) = object $ ("crit", toJSON $ fmap fst m) : toList m
-
-
--- | JWS Header data type.
-data JWSHeader = JWSHeader
- { headerAlg :: Maybe JWA.JWS.Alg
- , headerJku :: Maybe Types.URI -- ^ JWK Set URL
- , headerJwk :: Maybe JWK
- , headerKid :: Maybe String -- ^ interpretation unspecified
- , headerX5u :: Maybe Types.URI
- , headerX5c :: Maybe (NonEmpty Types.Base64X509)
- , headerX5t :: Maybe Types.Base64SHA1
- , headerX5tS256 :: Maybe Types.Base64SHA256
- , headerTyp :: Maybe String -- ^ Content Type (of object)
- , headerCty :: Maybe String -- ^ Content Type (of payload)
- , headerCrit :: Maybe CritParameters
- }
- deriving (Eq, Show)
-
-instance FromArmour T.Text Error JWSHeader where
- parseArmour s =
- first (compactErr "header")
- (B64UL.decode (BSL.fromStrict $ Types.pad $ T.encodeUtf8 s))
- >>= first JSONDecodeError . eitherDecode
- where
- compactErr s' = CompactDecodeError . ((s' ++ " decode failed: ") ++)
-
-instance ToArmour T.Text JWSHeader where
- toArmour = T.decodeUtf8 . Types.unpad . B64U.encode . BSL.toStrict . encode
-
-instance FromJSON JWSHeader where
- parseJSON = withObject "JWS Header" $ \o -> JWSHeader
- <$> o .:? "alg"
- <*> o .:? "jku"
- <*> o .:? "jwk"
- <*> o .:? "kid"
- <*> o .:? "x5u"
- <*> o .:? "x5c"
- <*> o .:? "x5t"
- <*> o .:? "x5t#S256"
- <*> o .:? "typ"
- <*> o .:? "cty"
- <*> (o .:? "crit" >>= mapM (parseCrit o))
-
-instance ToJSON JWSHeader where
- toJSON (JWSHeader alg jku jwk kid x5u x5c x5t x5tS256 typ cty crit) =
- object $ catMaybes
- [ Just ("alg" .= alg)
- , fmap ("jku" .=) jku
- , fmap ("jwk" .=) jwk
- , fmap ("kid" .=) kid
- , fmap ("x5u" .=) x5u
- , fmap ("x5c" .=) x5c
- , fmap ("x5t" .=) x5t
- , fmap ("x5t#S256" .=) x5tS256
- , fmap ("typ" .=) typ
- , fmap ("cty" .=) cty
- ] ++ Types.objectPairs (toJSON crit)
-
-instance Default JWSHeader where
- def = JWSHeader z z z z z z z z z z z where z = Nothing
-
--- | Construct a minimal header with the given algorithm
---
-newJWSHeader :: JWA.JWS.Alg -> JWSHeader
-newJWSHeader alg = def { headerAlg = Just alg }
-
-
-data Signature = Signature
- (Maybe (Armour T.Text JWSHeader))
- (Maybe JWSHeader)
- Types.Base64Octets
- deriving (Eq, Show)
-
-algorithm :: Signature -> Maybe JWA.JWS.Alg
-algorithm (Signature h h' _) = (h >>= headerAlg . (^. value)) <|> (h' >>= headerAlg)
-
-checkHeaders :: Signature -> Either Error Signature
-checkHeaders sig@(Signature h h' _) = do
- unless (isJust h || isJust h') (Left JWSMissingHeader)
- unless (isJust $ algorithm sig) (Left JWSMissingAlg)
- when (isJust $ h' >>= headerCrit) (Left JWSCritUnprotected)
- when hasDup (Left JWSDuplicateHeaderParameter)
- return sig
- where
- isDup f = isJust (h >>= f . (^. value)) && isJust (h' >>= f)
- hasDup = or
- [ isDup headerAlg, isDup headerJku, isDup headerJwk
- , isDup headerKid, isDup headerX5u, isDup headerX5c
- , isDup headerX5t, isDup headerX5tS256, isDup headerTyp
- , isDup headerCty
- ]
-
-instance FromJSON Signature where
- parseJSON =
- withObject "signature" (\o -> Signature
- <$> o .:? "protected"
- <*> o .:? "header"
- <*> o .: "signature"
- ) >=> either (fail . show) pure . checkHeaders
-
-instance ToJSON Signature where
- toJSON (Signature h h' s) =
- object $ ("signature" .= s) :
- maybe [] (Types.objectPairs . toJSON . (^. value)) h
- ++ maybe [] (Types.objectPairs . toJSON) h'
-
-
--- | JSON Web Signature data type. Consists of a payload and a
--- (possibly empty) list of signatures.
---
-data JWS = JWS Types.Base64Octets [Signature]
- deriving (Eq, Show)
-
-instance FromJSON JWS where
- parseJSON v =
- withObject "JWS JSON serialization" (\o -> JWS
- <$> o .: "payload"
- <*> o .: "signatures") v
- <|> withObject "Flattened JWS JSON serialization" (\o ->
- if member "signatures" o
- then fail "\"signatures\" member MUST NOT be present"
- else (\p s -> JWS p [s]) <$> o .: "payload" <*> parseJSON v) v
-
-instance ToJSON JWS where
- toJSON (JWS p ss) = object ["payload" .= p, "signatures" .= ss]
-
--- | Construct a new (unsigned) JWS
---
-newJWS :: BS.ByteString -> JWS
-newJWS msg = JWS (Types.Base64Octets msg) []
-
--- | Payload of a JWS, as a lazy bytestring.
---
-jwsPayload :: JWS -> BSL.ByteString
-jwsPayload (JWS (Types.Base64Octets s) _) = BSL.fromStrict s
-
-signingInput :: Maybe (Armour T.Text JWSHeader) -> Types.Base64Octets -> BS.ByteString
-signingInput h p = BS.intercalate "."
- [ maybe "" (T.encodeUtf8 . (^. armour)) h
- , toBytes p
- ]
-
--- Convert JWS to compact serialization.
---
--- The operation is defined only when there is exactly one
--- signature and returns Nothing otherwise
---
-instance ToCompact JWS where
- toCompact (JWS p [Signature h _ s]) =
- Right [BSL.fromStrict $ signingInput h p, BSL.fromStrict $ toBytes s]
- toCompact (JWS _ xs) = Left $ CompactEncodeError $
- "cannot compact serialize JWS with " ++ show (length xs) ++ " sigs"
-
-instance FromCompact JWS where
- fromCompact xs = case xs of
- [h, p, s] -> do
- h' <- decodeArmour $ T.decodeUtf8 $ BSL.toStrict h
- p' <- decodeS "payload" p
- s' <- decodeS "signature" s
- return $ JWS p' [Signature (Just h') Nothing s']
- xs' -> Left $ compactErr "compact representation"
- $ "expected 3 parts, got " ++ show (length xs')
- where
- compactErr s = CompactDecodeError . ((s ++ " decode failed: ") ++)
- decodeS desc s =
- first (compactErr desc)
- (A.eitherResult $ A.parse P.value $ BSL.intercalate s ["\"", "\""])
- >>= first JSONDecodeError . parseEither parseJSON
-
-
--- §5.1. Message Signing or MACing
-
--- | Create a new signature on a JWS.
---
-signJWS
- :: MonadRandom m
- => JWS -- ^ JWS to sign
- -> JWSHeader -- ^ Header for signature
- -> JWK -- ^ Key with which to sign
- -> m (Either Error JWS) -- ^ JWS with new signature appended
-signJWS (JWS p sigs) h k = case headerAlg h of
- Nothing -> return $ Left JWSMissingAlg
- Just alg -> fmap appendSig <$> sign alg (k ^. jwkMaterial) (signingInput h' p)
- where
- appendSig sig = JWS p (Signature h' Nothing (Types.Base64Octets sig):sigs)
- h' = Just $ Unarmoured h
-
-
--- | Algorithms for which validation will be attempted. The default
--- value includes all algorithms except 'None'.
---
-newtype ValidationAlgorithms = ValidationAlgorithms [JWA.JWS.Alg]
-
-instance Default ValidationAlgorithms where
- def = ValidationAlgorithms
- [ JWA.JWS.HS256, JWA.JWS.HS384, JWA.JWS.HS512
- , JWA.JWS.RS256, JWA.JWS.RS384, JWA.JWS.RS512
- , JWA.JWS.ES256, JWA.JWS.ES384, JWA.JWS.ES512
- , JWA.JWS.PS256, JWA.JWS.PS384, JWA.JWS.PS512
- ]
-
--- | Validation policy. The default policy is 'AllValidated'.
---
-data ValidationPolicy
- = AnyValidated
- -- ^ One successfully validated signature is sufficient
- | AllValidated
- -- ^ All signatures for which validation is attempted must be validated
-
-instance Default ValidationPolicy where
- def = AllValidated
-
-
--- | Verify a JWS.
---
--- Verification succeeds if any signature on the JWS is successfully
--- validated with the given 'Key'.
---
--- If only specific signatures need to be validated, and the
--- 'ValidationPolicy' argument is not enough to express this,
--- the caller is responsible for removing irrelevant signatures
--- prior to calling 'verifyJWS'.
---
-verifyJWS
- :: ValidationAlgorithms
- -> ValidationPolicy
- -> JWK
- -> JWS
- -> Bool
-verifyJWS (ValidationAlgorithms algs) policy k (JWS p sigs) =
- applyPolicy policy $ map validate $ filter shouldValidateSig sigs
- where
- shouldValidateSig = maybe False (`elem` algs) . algorithm
- applyPolicy AnyValidated xs = or xs
- applyPolicy AllValidated [] = False
- applyPolicy AllValidated xs = and xs
- validate = (== Right True) . verifySig k p
-
-verifySig :: JWK -> Types.Base64Octets -> Signature -> Either Error Bool
-verifySig k m sig@(Signature h _ (Types.Base64Octets s)) = maybe
- (Left $ AlgorithmMismatch "No 'alg' header") -- shouldn't happen
- (\alg -> verify alg (k ^. jwkMaterial) (signingInput h m) s)
- (algorithm sig)
diff --git a/src/Crypto/JOSE/Legacy.hs b/src/Crypto/JOSE/Legacy.hs
deleted file mode 100644
index 69c9193..0000000
--- a/src/Crypto/JOSE/Legacy.hs
+++ /dev/null
@@ -1,119 +0,0 @@
--- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale
---
--- Licensed under the Apache License, Version 2.0 (the "License");
--- you may not use this file except in compliance with the License.
--- You may obtain a copy of the License at
---
--- http://www.apache.org/licenses/LICENSE-2.0
---
--- Unless required by applicable law or agreed to in writing, software
--- distributed under the License is distributed on an "AS IS" BASIS,
--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--- See the License for the specific language governing permissions and
--- limitations under the License.
-
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-|
-
-Types to deal with the legacy JSON Web Key formats used with
-Mozilla Persona.
-
--}
-module Crypto.JOSE.Legacy
- (
- JWK'(..)
- , genJWK'
- , toJWK
- , RSKeyParameters()
- ) where
-
-import Control.Applicative
-
-import Control.Lens hiding ((.=))
-import Crypto.Number.Basic (log2)
-import Data.Aeson
-import Data.Aeson.Types
-import qualified Data.Text as T
-import Safe (readMay)
-
-import Crypto.JOSE.JWA.JWK
-import Crypto.JOSE.JWK
-import qualified Crypto.JOSE.Types.Internal as Types
-import Crypto.JOSE.Types
-import Crypto.JOSE.TH
-
-
-newtype StringifiedInteger = StringifiedInteger Integer
-makePrisms ''StringifiedInteger
-
-instance FromJSON StringifiedInteger where
- parseJSON = withText "StringifiedInteger" $
- maybe (fail "not an stringy integer") (pure . StringifiedInteger)
- . readMay
- . T.unpack
-
-instance ToJSON StringifiedInteger where
- toJSON (StringifiedInteger n) = toJSON $ show n
-
-b64Iso :: Iso' StringifiedInteger Base64Integer
-b64Iso = _StringifiedInteger . from _Base64Integer
-
-sizedB64Iso :: Iso' StringifiedInteger SizedBase64Integer
-sizedB64Iso = iso
- ((\n -> SizedBase64Integer (size n) n) . view _StringifiedInteger)
- (\(SizedBase64Integer _ n) -> StringifiedInteger n)
- where
- size n =
- let (bytes, bits) = (log2 n + 1) `divMod` 8
- in bytes + signum bits
-
-
-$(Crypto.JOSE.TH.deriveJOSEType "RS" ["RS"])
-
-
-newtype RSKeyParameters = RSKeyParameters RSAKeyParameters
- deriving (Eq, Show)
-makePrisms ''RSKeyParameters
-
-instance FromJSON RSKeyParameters where
- parseJSON = withObject "RS" $ \o -> fmap RSKeyParameters $ RSAKeyParameters
- <$> ((o .: "algorithm" :: Parser RS) *> pure RSA)
- <*> (view sizedB64Iso <$> o .: "n")
- <*> (view b64Iso <$> o .: "e")
- <*> (fmap ((`RSAPrivateKeyParameters` Nothing) . view b64Iso) <$> (o .:? "d"))
-
-instance ToJSON RSKeyParameters where
- toJSON (RSKeyParameters k)
- = object $
- [ "algorithm" .= RS
- , "n" .= (k ^. rsaN . from sizedB64Iso)
- , "e" .= (k ^. rsaE . from b64Iso)
- ]
- ++ maybe [] (\p -> ["d" .= (rsaD p ^. from b64Iso)])
- (k ^. rsaPrivateKeyParameters)
-
-
--- | Legacy JSON Web Key data type.
---
-newtype JWK' = JWK' RSKeyParameters
- deriving (Eq, Show)
-makePrisms ''JWK'
-
-instance FromJSON JWK' where
- parseJSON = withObject "JWK'" $ \o -> JWK' <$> parseJSON (Object o)
-
-instance ToJSON JWK' where
- toJSON (JWK' k) = object $ Types.objectPairs (toJSON k)
-
-instance AsPublicKey JWK' where
- asPublicKey = prism' id (_JWK' (_RSKeyParameters (preview asPublicKey)))
-
-genJWK' :: MonadRandom m => Int -> m JWK'
-genJWK' size = JWK' . RSKeyParameters <$> genRSA size
-
-toJWK :: JWK' -> JWK
-toJWK (JWK' (RSKeyParameters k)) = fromKeyMaterial $ RSAKeyMaterial k
diff --git a/src/Crypto/JOSE/TH.hs b/src/Crypto/JOSE/TH.hs
index d2f6c59..871da99 100644
--- a/src/Crypto/JOSE/TH.hs
+++ b/src/Crypto/JOSE/TH.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2013, 2014 Fraser Tweedale
+-- Copyright (C) 2013, 2014, 2016 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -27,7 +27,6 @@ module Crypto.JOSE.TH
deriveJOSEType
) where
-import Control.Applicative
import Data.Aeson
import Data.Char
import Language.Haskell.TH.Lib
@@ -99,12 +98,14 @@ deriveJOSEType
-> Q [Dec]
deriveJOSEType s vs = sequenceQ [
let
- derive = map mkName ["Eq", "Show"]
+ derive = map mkName ["Eq", "Ord", "Show"]
in
#if ! MIN_VERSION_template_haskell(2,11,0)
dataD (cxt []) (mkName s) [] (map conQ vs) derive
-#else
+#elif ! MIN_VERSION_template_haskell(2,12,0)
dataD (cxt []) (mkName s) [] Nothing (map conQ vs) (mapM conT derive)
+#else
+ dataD (cxt []) (mkName s) [] Nothing (map conQ vs) [return (DerivClause Nothing (map ConT derive))]
#endif
, instanceD (cxt []) (aesonInstance s ''FromJSON) [parseJSONFun vs]
, instanceD (cxt []) (aesonInstance s ''ToJSON) [toJSONFun vs]
diff --git a/src/Crypto/JOSE/Types.hs b/src/Crypto/JOSE/Types.hs
index 54676ee..4fdd6f2 100644
--- a/src/Crypto/JOSE/Types.hs
+++ b/src/Crypto/JOSE/Types.hs
@@ -32,16 +32,13 @@ module Crypto.JOSE.Types
, Base64SHA256(..)
, Base64X509(..)
, URI
+ , base64url
) where
-import Control.Applicative
-
import Control.Lens
import Data.Aeson
import Data.Aeson.Types (Parser)
-import Data.Byteable
import qualified Data.ByteString as B
-import qualified Data.ByteString.Base64.URL as B64U
import Data.X509
import Network.URI (URI)
import Test.QuickCheck
@@ -116,9 +113,6 @@ checkSize n a@(SizedBase64Integer m _) = if n == m
newtype Base64Octets = Base64Octets B.ByteString
deriving (Eq, Show)
-instance Byteable Base64Octets where
- toBytes (Base64Octets s) = unpad $ B64U.encode s
-
instance FromJSON Base64Octets where
parseJSON = withText "Base64Octets" $ parseB64Url (pure . Base64Octets)
diff --git a/src/Crypto/JOSE/Types/Armour.hs b/src/Crypto/JOSE/Types/Armour.hs
deleted file mode 100644
index 624c5f1..0000000
--- a/src/Crypto/JOSE/Types/Armour.hs
+++ /dev/null
@@ -1,89 +0,0 @@
--- Copyright (C) 2014 Fraser Tweedale
---
--- Licensed under the Apache License, Version 2.0 (the "License");
--- you may not use this file except in compliance with the License.
--- You may obtain a copy of the License at
---
--- http://www.apache.org/licenses/LICENSE-2.0
---
--- Unless required by applicable law or agreed to in writing, software
--- distributed under the License is distributed on an "AS IS" BASIS,
--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--- See the License for the specific language governing permissions and
--- limitations under the License.
-
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-{-|
-
-Implementation of "armoured values" with partial decoding.
-
-For cases where a value is parsed from some representation, but the
-precise representation that was used is also needed. The original
-representation of a parsed value can be accessed using the 'armour'
-function, but it cannot be changed.
-
--}
-module Crypto.JOSE.Types.Armour
- (
- Armour(Unarmoured)
- , FromArmour(..)
- , ToArmour(..)
- , decodeArmour
- , armour
- , value
- ) where
-
-import Control.Applicative
-import Control.Monad ((>=>))
-
-import Control.Lens
-import Data.Aeson
-
-
--- | A value that can be "armoured", where the armour representation
--- is preserved when the value is parsed.
---
-data Armour a b
- = Armoured a b
- | Unarmoured b
- deriving (Show)
-
-instance Eq b => Eq (Armour a b) where
- a == b = a ^. value == b ^. value
-
--- | Lens for the unarmoured value.
---
-value :: Lens' (Armour a b) b
-value = lens (\case Armoured _ b -> b ; Unarmoured b -> b) (const Unarmoured)
-
--- | 'Getter' for the armour encoding. If the armour was
--- remembered, it is returned unchanged.
---
-armour :: ToArmour a b => Getter (Armour a b) a
-armour = to (\case Armoured a _ -> a ; Unarmoured b -> toArmour b)
-
-
--- | Decoding from armoured representation.
---
-class FromArmour a e b | a b -> e where
- parseArmour :: a -> Either e b
-
-
--- | Serialising to armoured representation.
---
-class ToArmour a b where
- toArmour :: b -> a
-
-
--- | Decode an armoured value, remembering the armour.
---
-decodeArmour :: FromArmour a e b => a -> Either e (Armour a b)
-decodeArmour a = Armoured a <$> parseArmour a
-
-
-instance (FromJSON a, Show e, FromArmour a e b) => FromJSON (Armour a b) where
- parseJSON = parseJSON >=> either (fail . show) pure . decodeArmour
diff --git a/src/Crypto/JOSE/Types/Internal.hs b/src/Crypto/JOSE/Types/Internal.hs
index 323fc40..f6a6979 100644
--- a/src/Crypto/JOSE/Types/Internal.hs
+++ b/src/Crypto/JOSE/Types/Internal.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2013, 2014 Fraser Tweedale
+-- Copyright (C) 2013, 2014, 2017 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -12,6 +12,8 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
@@ -19,12 +21,32 @@
Internal utility functions for encoding/decoding JOSE types.
-}
-module Crypto.JOSE.Types.Internal where
-
+module Crypto.JOSE.Types.Internal
+ (
+ objectPairs
+ , encodeB64
+ , parseB64
+ , encodeB64Url
+ , parseB64Url
+ , pad
+ , unpad
+ , bsToInteger
+ , integerToBS
+ , sizedIntegerToBS
+ , base64url
+ ) where
+
+import Data.Bifunctor (first)
+import Data.Char (ord)
+import Data.Monoid ((<>))
import Data.Tuple (swap)
+import Data.Word (Word8)
+import Control.Lens
+import Control.Lens.Cons.Extras
import Data.Aeson.Types
import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base64.URL as B64U
import qualified Data.HashMap.Strict as M
@@ -40,7 +62,7 @@ objectPairs _ = []
-- | Produce a parser of base64 encoded text from a bytestring parser.
--
-parseB64 :: FromJSON a => (B.ByteString -> Parser a) -> T.Text -> Parser a
+parseB64 :: (B.ByteString -> Parser a) -> T.Text -> Parser a
parseB64 f = either fail f . decodeB64
where
decodeB64 = B64.decode . E.encodeUtf8
@@ -50,25 +72,91 @@ parseB64 f = either fail f . decodeB64
encodeB64 :: B.ByteString -> Value
encodeB64 = String . E.decodeUtf8 . B64.encode
+class IsChar a where
+ fromChar :: Char -> a
+
+instance IsChar Char where
+ fromChar = id
+
+instance IsChar Word8 where
+ fromChar = fromIntegral . ord
+
-- | Add appropriate base64 '=' padding.
--
-pad :: B.ByteString -> B.ByteString
-pad s = s `B.append` B.replicate ((4 - B.length s `mod` 4) `mod` 4) 61
+pad :: (Snoc s s a a, IsChar a) => s -> s
+pad = rpad 4 (fromChar '=')
+{-# INLINE [2] pad #-}
+
+rpad :: (Snoc s s a a) => Int -> a -> s -> s
+rpad w a s =
+ let n = ((w - snocLength s `mod` w) `mod` w)
+ in foldr (.) id (replicate n (`snoc` a)) s
+{-# INLINE rpad #-}
+
+snocLength :: (Snoc s s a a) => s -> Int
+snocLength s = case unsnoc s of
+ Nothing -> 0
+ Just (s', _) -> 1 + snocLength s'
+{-# INLINE snocLength #-}
+
+padB :: B.ByteString -> B.ByteString
+padB s = s <> B.replicate ((4 - B.length s `mod` 4) `mod` 4) 61
+{-# RULES "pad/padB" pad = padB #-}
+
+padL :: L.ByteString -> L.ByteString
+padL s = s <> L.replicate ((4 - L.length s `mod` 4) `mod` 4) 61
+{-# RULES "pad/padL" pad = padL #-}
+
-- | Strip base64 '=' padding.
--
-unpad :: B.ByteString -> B.ByteString
-unpad = B.reverse . B.dropWhile (== 61) . B.reverse
+unpad :: (Snoc s s a a, IsChar a, Eq a) => s -> s
+unpad = rstrip (== fromChar '=')
+{-# INLINE [2] unpad #-}
+
+rstrip :: (Snoc s s a a) => (a -> Bool) -> s -> s
+rstrip p s = case unsnoc s of
+ Nothing -> s
+ Just (s', a) -> if p a then rstrip p s' else s
+{-# INLINE rstrip #-}
+
+unpadB :: B.ByteString -> B.ByteString
+unpadB = B.reverse . B.dropWhile (== 61) . B.reverse
+{-# RULES "unpad/unpadB" unpad = unpadB #-}
+
+unpadL :: L.ByteString -> L.ByteString
+unpadL = L.reverse . L.dropWhile (== 61) . L.reverse
+{-# RULES "unpad/unpadL" unpad = unpadL #-}
+
+
+-- | Prism for encoding / decoding base64url.
+--
+-- To encode, @'review' base64url@.
+-- To decode, @'preview' base64url@.
+--
+-- Works with any combinations of strict/lazy @ByteString@.
+--
+base64url ::
+ ( AsEmpty s1, AsEmpty s2
+ , Cons s1 s1 Word8 Word8
+ , Cons s2 s2 Word8 Word8
+ ) => Prism' s1 s2
+base64url = reconsIso . padder . b64u . reconsIso
+ where
+ padder = iso pad unpad
+ b64u = prism B64U.encode (\s -> first (const s) (B64U.decode s))
+ reconsIso = iso (view recons) (view recons)
+
-- | Produce a parser of base64url encoded text from a bytestring parser.
--
-parseB64Url :: FromJSON a => (B.ByteString -> Parser a) -> T.Text -> Parser a
-parseB64Url f = either fail f . B64U.decode . pad . E.encodeUtf8
+parseB64Url :: (B.ByteString -> Parser a) -> T.Text -> Parser a
+parseB64Url f = maybe (fail "Not valid base64url") f . preview base64url . E.encodeUtf8
-- | Convert a bytestring to a base64url encoded JSON 'String'
--
encodeB64Url :: B.ByteString -> Value
-encodeB64Url = String . E.decodeUtf8 . unpad . B64U.encode
+encodeB64Url = String . E.decodeUtf8 . review base64url
-- | Convert an unsigned big endian octet sequence to the integer
-- it represents.
diff --git a/src/Crypto/JOSE/Types/Orphans.hs b/src/Crypto/JOSE/Types/Orphans.hs
index c20147b..4864b4d 100644
--- a/src/Crypto/JOSE/Types/Orphans.hs
+++ b/src/Crypto/JOSE/Types/Orphans.hs
@@ -17,23 +17,22 @@
module Crypto.JOSE.Types.Orphans where
-import Prelude hiding (mapM)
-
-import Control.Applicative
-import Data.Traversable
-
-import Data.List.NonEmpty (NonEmpty(..), toList)
+import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Text as T
-import qualified Data.Vector as V
import Network.URI (URI, parseURI)
import Test.QuickCheck
+#if ! MIN_VERSION_aeson(0,11,1)
+import Data.Foldable (toList)
+import qualified Data.Vector as V
+#endif
+
import Data.Aeson
#if ! MIN_VERSION_aeson(0,11,1)
instance FromJSON a => FromJSON (NonEmpty a) where
- parseJSON = withArray "NonEmpty [a]" $ \v -> case V.toList v of
+ parseJSON = withArray "NonEmpty [a]" $ \v -> case toList v of
[] -> fail "Non-empty list required"
(x:xs) -> mapM parseJSON (x :| xs)
diff --git a/src/Crypto/JWT.hs b/src/Crypto/JWT.hs
index 4e70537..1c45f96 100644
--- a/src/Crypto/JWT.hs
+++ b/src/Crypto/JWT.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2013, 2014, 2015 Fraser Tweedale
+-- Copyright (C) 2013, 2014, 2015, 2016, 2017 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -12,17 +12,62 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
{-|
-JSON Web Token implementation.
+JSON Web Token implementation (RFC 7519). A JWT is a JWS
+with a payload of /claims/ to be transferred between two
+parties.
+
+JWTs use the JWS /compact serialisation/.
+See "Crypto.JOSE.Compact" for details.
+
+@
+mkClaims :: IO 'ClaimsSet'
+mkClaims = do
+ t <- 'currentTime'
+ pure $ 'emptyClaimsSet'
+ & 'claimIss' .~ Just ("alice")
+ & 'claimAud' .~ Just ('Audience' ["bob"])
+ & 'claimIat' .~ Just ('NumericDate' t)
+
+doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT')
+doJwtSign jwk claims = runExceptT $ do
+ alg \<- 'bestJWSAlg' jwk
+ 'signClaims' jwk ('newJWSHeader' ('Protected', alg)) claims
+
+doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet')
+doJwtVerify jwk jwt = runExceptT $ do
+ let config = 'defaultJWTValidationSettings' (== "bob")
+ 'verifyClaims' config jwk jwt
+@
-}
module Crypto.JWT
(
- JWT(..)
+ -- * Creating a JWT
+ signClaims
+ , JWT
+ , SignedJWT
+
+ -- * Validating a JWT and extracting claims
+ , defaultJWTValidationSettings
+ , verifyClaims
+ , HasAllowedSkew(..)
+ , HasAudiencePredicate(..)
+ , HasIssuerPredicate(..)
+ , HasCheckIssuedAt(..)
+ , JWTValidationSettings
+ , HasJWTValidationSettings(..)
+
+ -- * Claims Set
+ , ClaimsSet
, claimAud
, claimExp
, claimIat
@@ -32,86 +77,119 @@ module Crypto.JWT
, claimSub
, unregisteredClaims
, addClaim
-
- , createJWSJWT
- , validateJWSJWT
-
- , ClaimsSet(..)
, emptyClaimsSet
+ , validateClaimsSet
- , Audience(..)
+ -- * JWT errors
+ , JWTError(..)
+ , AsJWTError(..)
+ -- * Miscellaneous
+ , Audience(..)
, StringOrURI
- , fromString
- , fromURI
- , getString
- , getURI
-
+ , stringOrUri
+ , string
+ , uri
, NumericDate(..)
+
+ , module Crypto.JOSE
+
) where
import Control.Applicative
import Control.Monad
-import Data.Bifunctor
+import Control.Monad.Time (MonadTime(..))
+#if ! MIN_VERSION_monad_time(0,2,0)
+import Control.Monad.Time.Instances ()
+#endif
+import Data.Foldable (traverse_)
+import Data.Functor.Identity
import Data.Maybe
-
-import Control.Lens (makeLenses, over)
+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')
+import Control.Monad.Except (MonadError(throwError))
import Data.Aeson
-import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
-import Data.Time
-import Data.Time.Clock.POSIX
+import Data.Time (NominalDiffTime, UTCTime, addUTCTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Network.URI (parseURI)
import Crypto.JOSE
import Crypto.JOSE.Types
--- §2. Terminology
+data JWTError
+ = JWSError Error
+ -- ^ A JOSE error occurred while processing the JWT
+ | JWTClaimsSetDecodeError String
+ -- ^ The JWT payload is not a JWT Claims Set
+ | JWTExpired
+ | JWTNotYetValid
+ | JWTNotInIssuer
+ | JWTNotInAudience
+ | JWTIssuedAtFuture
+ deriving (Eq, Show)
+makeClassyPrisms ''JWTError
+
+instance AsError JWTError where
+ _Error = _JWSError
+
+
+-- RFC 7519 §2. Terminology
-- | A JSON string value, with the additional requirement that while
--- arbitrary string values MAY be used, any value containing a /:/
+-- arbitrary string values MAY be used, any value containing a @:@
-- character MUST be a URI.
--
-data StringOrURI = Arbitrary T.Text | OrURI URI deriving (Eq, Show)
-
--- | Construct a 'StringOrURI' from text
+-- __Note__: the 'IsString' instance will fail if the string
+-- contains a @:@ but does not parse as a 'URI'. Use 'stringOrUri'
+-- directly in this situation.
--
-fromString :: T.Text -> StringOrURI
-fromString s = maybe (Arbitrary s) OrURI $ parseURI $ T.unpack s
+data StringOrURI = Arbitrary String | OrURI URI deriving (Eq, Show)
--- | Construct a 'StringOrURI' from a URI
---
-fromURI :: URI -> StringOrURI
-fromURI = OrURI
+instance Data.String.IsString StringOrURI where
+ fromString = fromJust . preview stringOrUri
--- | Get the
-getString :: StringOrURI -> Maybe T.Text
-getString (Arbitrary a) = Just a
-getString (OrURI _) = Nothing
+consString :: (Cons s s Char Char, Monoid s) => Iso' s String
+consString = iso (unfoldr uncons) (foldr cons mempty)
--- | Get the uri from a 'StringOrURI'
---
-getURI :: StringOrURI -> Maybe URI
-getURI (Arbitrary _) = Nothing
-getURI (OrURI a) = Just a
+stringOrUri :: (Cons s s Char Char, Monoid s) => Prism' s StringOrURI
+stringOrUri = consString . prism' rev fwd
+ where
+ rev (Arbitrary s) = s
+ rev (OrURI x) = show x
+ fwd s = if ':' `elem` s then OrURI <$> parseURI s else pure (Arbitrary s)
+
+string :: Prism' StringOrURI String
+string = prism' Arbitrary f where
+ f (Arbitrary s) = Just s
+ f _ = Nothing
+
+uri :: Prism' StringOrURI URI
+uri = prism' OrURI f where
+ f (OrURI s) = Just s
+ f _ = Nothing
instance FromJSON StringOrURI where
- parseJSON = withText "StringOrURI" (\s ->
- if T.any (== ':') s
- then OrURI <$> parseJSON (String s)
- else pure $ Arbitrary s)
+ parseJSON = withText "StringOrURI"
+ (maybe (fail "failed to parse StringOrURI") pure . preview stringOrUri)
instance ToJSON StringOrURI where
toJSON (Arbitrary s) = toJSON s
- toJSON (OrURI uri) = toJSON $ show uri
+ toJSON (OrURI x) = toJSON $ show x
-- | A JSON numeric value representing the number of seconds from
-- 1970-01-01T0:0:0Z UTC until the specified UTC date\/time.
--
-newtype NumericDate = NumericDate UTCTime deriving (Eq, Show)
+newtype NumericDate = NumericDate UTCTime deriving (Eq, Ord, Show)
+makePrisms ''NumericDate
instance FromJSON NumericDate where
parseJSON = withScientific "NumericDate" $
@@ -128,68 +206,105 @@ instance ToJSON NumericDate where
-- /aud/ value MAY be a single case-sensitive string containing a
-- 'StringOrURI' value.
--
-data Audience = General [StringOrURI] | Special StringOrURI deriving (Eq, Show)
+-- The 'ToJSON' instance formats an 'Audience' with one value as a
+-- string (some non-compliant implementations require this.)
+--
+newtype Audience = Audience [StringOrURI] deriving (Eq, Show)
+makePrisms ''Audience
instance FromJSON Audience where
- parseJSON v = fmap General (parseJSON v) <|> fmap Special (parseJSON v)
+ parseJSON v = Audience <$> (parseJSON v <|> fmap (:[]) (parseJSON v))
instance ToJSON Audience where
- toJSON (General auds) = toJSON auds
- toJSON (Special aud) = toJSON aud
+ toJSON (Audience [aud]) = toJSON aud
+ toJSON (Audience auds) = toJSON auds
-- | The JWT Claims Set represents a JSON object whose members are
--- the claims conveyed by the JWT.
+-- the registered claims defined by RFC 7519. Unrecognised
+-- claims are gathered into the 'unregisteredClaims' map.
--
data ClaimsSet = ClaimsSet
{ _claimIss :: Maybe StringOrURI
- -- ^ The issuer claim identifies the principal that issued the
- -- JWT. The processing of this claim is generally application
- -- specific.
, _claimSub :: Maybe StringOrURI
- -- ^ The subject claim identifies the principal that is the
- -- subject of the JWT. The Claims in a JWT are normally
- -- statements about the subject. The subject value MAY be scoped
- -- to be locally unique in the context of the issuer or MAY be
- -- globally unique. The processing of this claim is generally
- -- application specific.
, _claimAud :: Maybe Audience
- -- ^ The audience claim identifies the recipients that the JWT is
- -- intended for. Each principal intended to process the JWT MUST
- -- identify itself with a value in the audience claim. If the
- -- principal processing the claim does not identify itself with a
- -- value in the /aud/ claim when this claim is present, then the
- -- JWT MUST be rejected.
, _claimExp :: Maybe NumericDate
- -- ^ The expiration time claim identifies the expiration time on
- -- or after which the JWT MUST NOT be accepted for processing.
- -- The processing of /exp/ claim requires that the current
- -- date\/time MUST be before expiration date\/time listed in the
- -- /exp/ claim. Implementers MAY provide for some small leeway,
- -- usually no more than a few minutes, to account for clock skew.
, _claimNbf :: Maybe NumericDate
- -- ^ The not before claim identifies the time before which the JWT
- -- MUST NOT be accepted for processing. The processing of the
- -- /nbf/ claim requires that the current date\/time MUST be after
- -- or equal to the not-before date\/time listed in the /nbf/
- -- claim. Implementers MAY provide for some small leeway, usually
- -- no more than a few minutes, to account for clock skew.
, _claimIat :: Maybe NumericDate
- -- ^ The issued at claim identifies the time at which the JWT was
- -- issued. This claim can be used to determine the age of the
- -- JWT.
, _claimJti :: Maybe T.Text
- -- ^ The JWT ID claim provides a unique identifier for the JWT.
- -- The identifier value MUST be assigned in a manner that ensures
- -- that there is a negligible probability that the same value will
- -- be accidentally assigned to a different data object. The /jti/
- -- claim can be used to prevent the JWT from being replayed. The
- -- /jti/ value is a case-sensitive string.
, _unregisteredClaims :: M.HashMap T.Text Value
- -- ^ Claim Names can be defined at will by those using JWTs.
}
deriving (Eq, Show)
-makeLenses ''ClaimsSet
+
+-- | The issuer claim identifies the principal that issued the
+-- JWT. The processing of this claim is generally application
+-- specific.
+claimIss :: Lens' ClaimsSet (Maybe StringOrURI)
+claimIss f h@(ClaimsSet { _claimIss = a}) =
+ fmap (\a' -> h { _claimIss = a' }) (f a)
+
+-- | The subject claim identifies the principal that is the
+-- subject of the JWT. The Claims in a JWT are normally
+-- statements about the subject. The subject value MAY be scoped
+-- to be locally unique in the context of the issuer or MAY be
+-- globally unique. The processing of this claim is generally
+-- application specific.
+claimSub :: Lens' ClaimsSet (Maybe StringOrURI)
+claimSub f h@(ClaimsSet { _claimSub = a}) =
+ fmap (\a' -> h { _claimSub = a' }) (f a)
+
+-- | The audience claim identifies the recipients that the JWT is
+-- intended for. Each principal intended to process the JWT MUST
+-- identify itself with a value in the audience claim. If the
+-- principal processing the claim does not identify itself with a
+-- value in the /aud/ claim when this claim is present, then the
+-- JWT MUST be rejected.
+claimAud :: Lens' ClaimsSet (Maybe Audience)
+claimAud f h@(ClaimsSet { _claimAud = a}) =
+ fmap (\a' -> h { _claimAud = a' }) (f a)
+
+-- | The expiration time claim identifies the expiration time on
+-- or after which the JWT MUST NOT be accepted for processing.
+-- The processing of /exp/ claim requires that the current
+-- date\/time MUST be before expiration date\/time listed in the
+-- /exp/ claim. Implementers MAY provide for some small leeway,
+-- usually no more than a few minutes, to account for clock skew.
+claimExp :: Lens' ClaimsSet (Maybe NumericDate)
+claimExp f h@(ClaimsSet { _claimExp = a}) =
+ fmap (\a' -> h { _claimExp = a' }) (f a)
+
+-- | The not before claim identifies the time before which the JWT
+-- MUST NOT be accepted for processing. The processing of the
+-- /nbf/ claim requires that the current date\/time MUST be after
+-- or equal to the not-before date\/time listed in the /nbf/
+-- claim. Implementers MAY provide for some small leeway, usually
+-- no more than a few minutes, to account for clock skew.
+claimNbf :: Lens' ClaimsSet (Maybe NumericDate)
+claimNbf f h@(ClaimsSet { _claimNbf = a}) =
+ fmap (\a' -> h { _claimNbf = a' }) (f a)
+
+-- | The issued at claim identifies the time at which the JWT was
+-- issued. This claim can be used to determine the age of the
+-- JWT.
+claimIat :: Lens' ClaimsSet (Maybe NumericDate)
+claimIat f h@(ClaimsSet { _claimIat = a}) =
+ fmap (\a' -> h { _claimIat = a' }) (f a)
+
+-- | The JWT ID claim provides a unique identifier for the JWT.
+-- The identifier value MUST be assigned in a manner that ensures
+-- that there is a negligible probability that the same value will
+-- be accidentally assigned to a different data object. The /jti/
+-- claim can be used to prevent the JWT from being replayed. The
+-- /jti/ value is a case-sensitive string.
+claimJti :: Lens' ClaimsSet (Maybe T.Text)
+claimJti f h@(ClaimsSet { _claimJti = a}) =
+ fmap (\a' -> h { _claimJti = a' }) (f a)
+
+-- | Claim Names can be defined at will by those using JWTs.
+unregisteredClaims :: Lens' ClaimsSet (M.HashMap T.Text Value)
+unregisteredClaims f h@(ClaimsSet { _unregisteredClaims = a}) =
+ fmap (\a' -> h { _unregisteredClaims = a' }) (f a)
+
-- | Return an empty claims set.
--
@@ -226,53 +341,202 @@ instance ToJSON ClaimsSet where
] ++ M.toList (filterUnregistered o)
--- | Data representing the JOSE aspects of a JWT.
---
-data JWTCrypto = JWTJWS JWS deriving (Eq, Show)
+data JWTValidationSettings = JWTValidationSettings
+ { _jwtValidationSettingsValidationSettings :: ValidationSettings
+ , _jwtValidationSettingsAllowedSkew :: NominalDiffTime
+ , _jwtValidationSettingsCheckIssuedAt :: Bool
+ -- ^ The allowed skew is interpreted in absolute terms;
+ -- a nonzero value always expands the validity period.
+ , _jwtValidationSettingsAudiencePredicate :: StringOrURI -> Bool
+ , _jwtValidationSettingsIssuerPredicate :: StringOrURI -> Bool
+ }
+makeClassy ''JWTValidationSettings
-instance FromCompact JWTCrypto where
- fromCompact = fmap JWTJWS . fromCompact
+instance HasValidationSettings JWTValidationSettings where
+ validationSettings = jwtValidationSettingsValidationSettings
-instance ToCompact JWTCrypto where
- toCompact (JWTJWS jws) = toCompact jws
+-- | Maximum allowed skew when validating the /nbf/, /exp/ and /iat/ claims.
+class HasAllowedSkew s where
+ allowedSkew :: Lens' s NominalDiffTime
+
+-- | Predicate for checking values in the /aud/ claim.
+class HasAudiencePredicate s where
+ audiencePredicate :: Lens' s (StringOrURI -> Bool)
+
+-- | Predicate for checking the /iss/ claim.
+class HasIssuerPredicate s where
+ issuerPredicate :: Lens' s (StringOrURI -> Bool)
+
+-- | Whether to check that the /iat/ claim is not in the future.
+class HasCheckIssuedAt s where
+ checkIssuedAt :: Lens' s Bool
+
+instance HasJWTValidationSettings a => HasAllowedSkew a where
+ allowedSkew = jwtValidationSettingsAllowedSkew
+instance HasJWTValidationSettings a => HasAudiencePredicate a where
+ audiencePredicate = jwtValidationSettingsAudiencePredicate
+instance HasJWTValidationSettings a => HasIssuerPredicate a where
+ issuerPredicate = jwtValidationSettingsIssuerPredicate
+instance HasJWTValidationSettings a => HasCheckIssuedAt a where
+ checkIssuedAt = jwtValidationSettingsCheckIssuedAt
+
+-- | Acquire the default validation settings.
+--
+-- <https://tools.ietf.org/html/rfc7519#section-4.1.3 RFC 7519 §4.1.3.>
+-- states that applications MUST identify itself with a value in the
+-- audience claim, therefore a predicate must be supplied.
+--
+-- The other defaults are:
+--
+-- - 'defaultValidationSettings' for JWS verification
+-- - Zero clock skew tolerance when validating /nbf/, /exp/ and /iat/ claims
+-- - /iat/ claim is checked
+-- - /issuer/ claim is not checked
+--
+defaultJWTValidationSettings :: (StringOrURI -> Bool) -> JWTValidationSettings
+defaultJWTValidationSettings p = JWTValidationSettings
+ defaultValidationSettings
+ 0
+ True
+ p
+ (const True)
+
+-- | Validate the claims made by a ClaimsSet.
+--
+-- These checks are performed by 'verifyClaims', which also
+-- validates any signatures, so you shouldn't need to use this
+-- function directly.
+--
+validateClaimsSet
+ ::
+ ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a
+ , HasIssuerPredicate a
+ , HasCheckIssuedAt a
+ , AsJWTError e, MonadError e m
+ )
+ => a
+ -> ClaimsSet
+ -> m ClaimsSet
+validateClaimsSet conf claims =
+ traverse_ (($ claims) . ($ conf))
+ [ validateExpClaim
+ , validateIatClaim
+ , validateNbfClaim
+ , validateIssClaim
+ , validateAudClaim
+ ]
+ *> pure claims
+
+validateExpClaim
+ :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m)
+ => a
+ -> ClaimsSet
+ -> m ()
+validateExpClaim conf =
+ traverse_ (\t -> do
+ now <- currentTime
+ unless (now < addUTCTime (abs (view allowedSkew conf)) (view _NumericDate t)) $
+ throwError (review _JWTExpired ()))
+ . preview (claimExp . _Just)
+
+validateIatClaim
+ :: (MonadTime m, HasCheckIssuedAt a, HasAllowedSkew a, AsJWTError e, MonadError e m)
+ => a
+ -> ClaimsSet
+ -> m ()
+validateIatClaim conf =
+ traverse_ (\t -> do
+ now <- currentTime
+ when (view checkIssuedAt conf) $
+ when ((view _NumericDate t) > addUTCTime (abs (view allowedSkew conf)) now) $
+ throwError (review _JWTIssuedAtFuture ()))
+ . preview (claimIat . _Just)
+
+validateNbfClaim
+ :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m)
+ => a
+ -> ClaimsSet
+ -> m ()
+validateNbfClaim conf =
+ traverse_ (\t -> do
+ now <- currentTime
+ unless (now >= addUTCTime (negate (abs (view allowedSkew conf))) (view _NumericDate t)) $
+ throwError (review _JWTNotYetValid ()))
+ . preview (claimNbf . _Just)
+
+validateAudClaim
+ :: (HasAudiencePredicate s, AsJWTError e, MonadError e m)
+ => s
+ -> ClaimsSet
+ -> m ()
+validateAudClaim conf =
+ traverse_
+ (\auds -> unless (or (view audiencePredicate conf <$> auds)) $
+ throwError (review _JWTNotInAudience ()))
+ . preview (claimAud . _Just . _Audience)
+
+validateIssClaim
+ :: (HasIssuerPredicate s, AsJWTError e, MonadError e m)
+ => s
+ -> ClaimsSet
+ -> m ()
+validateIssClaim conf =
+ traverse_ (\iss ->
+ unless (view issuerPredicate conf iss) $
+ throwError (review _JWTNotInIssuer ()))
+ . preview (claimIss . _Just)
-- | JSON Web Token data.
--
-data JWT = JWT
- { jwtCrypto :: JWTCrypto -- ^ JOSE aspect of the JWT.
- , jwtClaimsSet :: ClaimsSet -- ^ Claims of the JWT.
- } deriving (Eq, Show)
+newtype JWT a = JWT a
+ deriving (Eq, Show)
+
+-- | A digitally signed or MACed JWT
+--
+type SignedJWT = JWT (CompactJWS JWSHeader)
-instance FromCompact JWT where
- fromCompact = fromCompact >=> toJWT where
- toJWT (JWTJWS jws) =
- bimap CompactDecodeError (JWT (JWTJWS jws))
- $ eitherDecode $ jwsPayload jws
+instance FromCompact a => FromCompact (JWT a) where
+ fromCompact = fmap JWT . fromCompact
-instance ToCompact JWT where
- toCompact = toCompact . jwtCrypto
+instance ToCompact a => ToCompact (JWT a) where
+ toCompact (JWT a) = toCompact a
--- | Validate a JWT as a JWS (JSON Web Signature).
+-- | Cryptographically verify a JWS JWT, then validate the
+-- Claims Set, returning it if valid.
--
-validateJWSJWT
- :: ValidationAlgorithms
- -> ValidationPolicy
- -> JWK
- -> JWT
- -> Bool
-validateJWSJWT algs policy k (JWT (JWTJWS jws) _) = verifyJWS algs policy k jws
-
--- | Create a JWT that is a JWS.
+-- This is the only way to get at the claims of a JWS JWT,
+-- enforcing that the claims are cryptographically and
+-- semantically valid before the application can use them.
--
-createJWSJWT
- :: MonadRandom m
+verifyClaims
+ ::
+ ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a
+ , HasIssuerPredicate a
+ , HasCheckIssuedAt a
+ , HasValidationSettings a
+ , AsError e, AsJWTError e, MonadError e m
+ , JWKStore k
+ )
+ => a
+ -> k
+ -> SignedJWT
+ -> m ClaimsSet
+verifyClaims conf k (JWT jws) =
+ -- It is important, for security reasons, that the signature get
+ -- verified before the claims.
+ verifyJWS conf k jws
+ >>= either (throwError . review _JWTClaimsSetDecodeError) pure . eitherDecode
+ >>= validateClaimsSet conf
+
+-- | Create a JWS JWT
+--
+signClaims
+ :: (MonadRandom m, MonadError e m, AsError e)
=> JWK
- -> JWSHeader
+ -> JWSHeader ()
-> ClaimsSet
- -> m (Either Error JWT)
-createJWSJWT k h c = fmap (\jws -> JWT (JWTJWS jws) c) <$>
- signJWS (JWS payload []) h k
- where
- payload = Base64Octets $ BSL.toStrict $ encode c
+ -> m SignedJWT
+signClaims k h c =
+ JWT <$> signJWS (encode c) (Identity (h, k))
diff --git a/test/JWK.hs b/test/JWK.hs
index ebd95eb..a664fa1 100644
--- a/test/JWK.hs
+++ b/test/JWK.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2013 Fraser Tweedale
+-- Copyright (C) 2013, 2017 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -12,11 +12,17 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module JWK where
+import Data.Monoid ((<>))
+
+import Control.Lens (_Right, review, view)
+import Control.Lens.Extras (is)
import Data.Aeson
+import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Test.Hspec
@@ -34,9 +40,13 @@ spec = do
jwkAppendixBSpec
jwkAppendixC1Spec
jwsAppendixA1Spec
+ cfrgSpec
+#if MIN_VERSION_aeson(0,10,0)
+ thumbprintSpec
+#endif
jwsAppendixA1Spec :: Spec
-jwsAppendixA1Spec = describe "JWS A.1.1. JWK" $ do
+jwsAppendixA1Spec = describe "RFC 7515 A.1.1. JWK" $ do
-- can't make aeson encode JSON to exact representation used in
-- IETF doc, be we can go in reverse and then ensure that the
-- round-trip checks out
@@ -48,208 +58,251 @@ jwsAppendixA1Spec = describe "JWS A.1.1. JWK" $ do
eitherDecode (encode jwk) `shouldBe` Right jwk
where
- exampleJWK = "\
- \{\"kty\":\"oct\",\
- \ \"k\":\"AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75\
- \aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow\"\
- \}"
- jwk = JWK (OctKeyMaterial octKeyMaterial) z z z z z z z z where z = Nothing
- octKeyMaterial = OctKeyParameters Oct $ Types.Base64Octets $
- foldr B.cons B.empty
+ exampleJWK = ""
+ <> "{\"kty\":\"oct\","
+ <> "\"k\":\"AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75"
+ <> "aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow\""
+ <> "}"
+ jwk = fromOctets
[3,35,53,75,43,15,165,188,131,126,6,101,119,123,166,143,90,179,40,
230,240,84,201,40,169,15,132,178,210,80,46,191,211,251,90,146,
210,6,71,239,150,138,180,195,119,98,61,34,61,46,33,114,5,46,79,8,
192,205,154,245,103,208,128,163]
jwk3Spec :: Spec
-jwk3Spec = describe "JWK §3. Example JWK" $
+jwk3Spec = describe "RFC 7517 §3. Example JWK" $
it "successfully decodes the examples" $
- lr (eitherDecode exampleJWK :: Either String JWK) `shouldBe` R
+ (eitherDecode exampleJWK :: Either String JWK) `shouldSatisfy` is _Right
where
- exampleJWK = "\
- \{\"kty\":\"EC\",\
- \ \"crv\":\"P-256\",\
- \ \"x\":\"f83OJ3D2xF1Bg8vub9tLe1gHMzV76e8Tus9uPHvRVEU\",\
- \ \"y\":\"x_FEzRu9m36HLN_tue659LNpXW6pCyStikYjKIWI5a0\",\
- \ \"kid\":\"Public key used in JWS A.3 example\"\
- \}"
+ exampleJWK = ""
+ <> "{\"kty\":\"EC\","
+ <> " \"crv\":\"P-256\","
+ <> " \"x\":\"f83OJ3D2xF1Bg8vub9tLe1gHMzV76e8Tus9uPHvRVEU\","
+ <> " \"y\":\"x_FEzRu9m36HLN_tue659LNpXW6pCyStikYjKIWI5a0\","
+ <> " \"kid\":\"Public key used in JWS spec Appendix A.3 example\""
+ <> "}"
jwkAppendixA1Spec :: Spec
-jwkAppendixA1Spec = describe "JWK A.1. Example Public Keys" $
+jwkAppendixA1Spec = describe "RFC 7517 A.1. Example Public Keys" $
it "successfully decodes the examples" $
- lr (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldBe` R
+ (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldSatisfy` is _Right
where
- exampleEC = "\
- \ {\"kty\":\"EC\",\
- \ \"crv\":\"P-256\",\
- \ \"x\":\"MKBCTNIcKUSDii11ySs3526iDZ8AiTo7Tu6KPAqv7D4\",\
- \ \"y\":\"4Etl6SRW2YiLUrN5vfvVHuhp7x8PxltmWWlbbM4IFyM\",\
- \ \"use\":\"enc\",\
- \ \"kid\":\"1\"}"
- exampleRSA = "\
- \ {\"kty\":\"RSA\",\
- \ \"n\": \"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx\
- \4cbbfAAtVT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMs\
- \tn64tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FDW2\
- \QvzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n91CbOpbI\
- \SD08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINHaQ-G_xBniIqb\
- \w0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\",\
- \ \"e\":\"AQAB\",\
- \ \"alg\":\"RS256\",\
- \ \"kid\":\"2011-04-29\"}"
+ exampleEC = ""
+ <> "{\"kty\":\"EC\","
+ <> " \"crv\":\"P-256\","
+ <> " \"x\":\"MKBCTNIcKUSDii11ySs3526iDZ8AiTo7Tu6KPAqv7D4\","
+ <> " \"y\":\"4Etl6SRW2YiLUrN5vfvVHuhp7x8PxltmWWlbbM4IFyM\","
+ <> " \"use\":\"enc\","
+ <> " \"kid\":\"1\"}"
+ exampleRSA = ""
+ <> "{\"kty\":\"RSA\","
+ <> " \"n\": \"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx"
+ <> "4cbbfAAtVT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMs"
+ <> "tn64tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FDW2"
+ <> "QvzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n91CbOpbI"
+ <> "SD08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINHaQ-G_xBniIqb"
+ <> "w0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\","
+ <> " \"e\":\"AQAB\","
+ <> " \"alg\":\"RS256\","
+ <> " \"kid\":\"2011-04-29\"}"
exampleJWKSet = "{\"keys\": ["
`L.append` exampleEC `L.append` ","
`L.append` exampleRSA `L.append` "]}"
jwkAppendixA2Spec :: Spec
-jwkAppendixA2Spec = describe "JWK A.2. Example Private Keys" $
+jwkAppendixA2Spec = describe "RFC 7517 A.2. Example Private Keys" $
it "successfully decodes the examples" $
- lr (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldBe` R
+ (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldSatisfy` is _Right
where
- exampleJWKSet = "\
- \{\"keys\":\
- \ [\
- \ {\"kty\":\"EC\",\
- \ \"crv\":\"P-256\",\
- \ \"x\":\"MKBCTNIcKUSDii11ySs3526iDZ8AiTo7Tu6KPAqv7D4\",\
- \ \"y\":\"4Etl6SRW2YiLUrN5vfvVHuhp7x8PxltmWWlbbM4IFyM\",\
- \ \"d\":\"870MB6gfuTJ4HtUnUvYMyJpr5eUZNP4Bk43bVdj3eAE\",\
- \ \"use\":\"enc\",\
- \ \"kid\":\"1\"},\
- \\
- \ {\"kty\":\"RSA\",\
- \ \"n\":\"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx4\
- \cbbfAAtVT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMst\
- \n64tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FDW2Q\
- \vzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n91CbOpbIS\
- \D08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINHaQ-G_xBniIqbw\
- \0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\",\
- \ \"e\":\"AQAB\",\
- \ \"d\":\"X4cTteJY_gn4FYPsXB8rdXix5vwsg1FLN5E3EaG6RJoVH-HLLKD9\
- \M7dx5oo7GURknchnrRweUkC7hT5fJLM0WbFAKNLWY2vv7B6NqXSzUvxT0_YSfqij\
- \wp3RTzlBaCxWp4doFk5N2o8Gy_nHNKroADIkJ46pRUohsXywbReAdYaMwFs9tv8d\
- \_cPVY3i07a3t8MN6TNwm0dSawm9v47UiCl3Sk5ZiG7xojPLu4sbg1U2jx4IBTNBz\
- \nbJSzFHK66jT8bgkuqsk0GjskDJk19Z4qwjwbsnn4j2WBii3RL-Us2lGVkY8fkFz\
- \me1z0HbIkfz0Y6mqnOYtqc0X4jfcKoAC8Q\",\
- \ \"p\":\"83i-7IvMGXoMXCskv73TKr8637FiO7Z27zv8oj6pbWUQyLPQBQxtPV\
- \nwD20R-60eTDmD2ujnMt5PoqMrm8RfmNhVWDtjjMmCMjOpSXicFHj7XOuVIYQyqV\
- \WlWEh6dN36GVZYk93N8Bc9vY41xy8B9RzzOGVQzXvNEvn7O0nVbfs\",\
- \ \"q\":\"3dfOR9cuYq-0S-mkFLzgItgMEfFzB2q3hWehMuG0oCuqnb3vobLyum\
- \qjVZQO1dIrdwgTnCdpYzBcOfW5r370AFXjiWft_NGEiovonizhKpo9VVS78TzFgx\
- \kIdrecRezsZ-1kYd_s1qDbxtkDEgfAITAG9LUnADun4vIcb6yelxk\",\
- \ \"dp\":\"G4sPXkc6Ya9y8oJW9_ILj4xuppu0lzi_H7VTkS8xj5SdX3coE0oim\
- \YwxIi2emTAue0UOa5dpgFGyBJ4c8tQ2VF402XRugKDTP8akYhFo5tAA77Qe_Nmtu\
- \YZc3C3m3I24G2GvR5sSDxUyAN2zq8Lfn9EUms6rY3Ob8YeiKkTiBj0\",\
- \ \"dq\":\"s9lAH9fggBsoFR8Oac2R_E2gw282rT2kGOAhvIllETE1efrA6huUU\
- \vMfBcMpn8lqeW6vzznYY5SSQF7pMdC_agI3nG8Ibp1BUb0JUiraRNqUfLhcQb_d9\
- \GF4Dh7e74WbRsobRonujTYN1xCaP6TO61jvWrX-L18txXw494Q_cgk\",\
- \ \"qi\":\"GyM_p6JrXySiz1toFgKbWV-JdI3jQ4ypu9rbMWx3rQJBfmt0FoYzg\
- \UIZEVFEcOqwemRN81zoDAaa-Bk0KWNGDjJHZDdDmFhW3AN7lI-puxk_mHZGJ11rx\
- \yR8O55XLSe3SPmRfKwZI6yU24ZxvQKFYItdldUKGzO6Ia6zTKhAVRU\",\
- \ \"alg\":\"RS256\",\
- \ \"kid\":\"2011-04-29\"}\
- \ ]\
- \}"
+ exampleJWKSet = ""
+ <> "{\"keys\":"
+ <> " ["
+ <> " {\"kty\":\"EC\","
+ <> " \"crv\":\"P-256\","
+ <> " \"x\":\"MKBCTNIcKUSDii11ySs3526iDZ8AiTo7Tu6KPAqv7D4\","
+ <> " \"y\":\"4Etl6SRW2YiLUrN5vfvVHuhp7x8PxltmWWlbbM4IFyM\","
+ <> " \"d\":\"870MB6gfuTJ4HtUnUvYMyJpr5eUZNP4Bk43bVdj3eAE\","
+ <> " \"use\":\"enc\","
+ <> " \"kid\":\"1\"},"
+ <> ""
+ <> " {\"kty\":\"RSA\","
+ <> " \"n\":\"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx4"
+ <> "cbbfAAtVT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMst"
+ <> "n64tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FDW2Q"
+ <> "vzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n91CbOpbIS"
+ <> "D08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINHaQ-G_xBniIqbw"
+ <> "0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\","
+ <> " \"e\":\"AQAB\","
+ <> " \"d\":\"X4cTteJY_gn4FYPsXB8rdXix5vwsg1FLN5E3EaG6RJoVH-HLLKD9"
+ <> "M7dx5oo7GURknchnrRweUkC7hT5fJLM0WbFAKNLWY2vv7B6NqXSzUvxT0_YSfqij"
+ <> "wp3RTzlBaCxWp4doFk5N2o8Gy_nHNKroADIkJ46pRUohsXywbReAdYaMwFs9tv8d"
+ <> "_cPVY3i07a3t8MN6TNwm0dSawm9v47UiCl3Sk5ZiG7xojPLu4sbg1U2jx4IBTNBz"
+ <> "nbJSzFHK66jT8bgkuqsk0GjskDJk19Z4qwjwbsnn4j2WBii3RL-Us2lGVkY8fkFz"
+ <> "me1z0HbIkfz0Y6mqnOYtqc0X4jfcKoAC8Q\","
+ <> " \"p\":\"83i-7IvMGXoMXCskv73TKr8637FiO7Z27zv8oj6pbWUQyLPQBQxtPV"
+ <> "nwD20R-60eTDmD2ujnMt5PoqMrm8RfmNhVWDtjjMmCMjOpSXicFHj7XOuVIYQyqV"
+ <> "WlWEh6dN36GVZYk93N8Bc9vY41xy8B9RzzOGVQzXvNEvn7O0nVbfs\","
+ <> " \"q\":\"3dfOR9cuYq-0S-mkFLzgItgMEfFzB2q3hWehMuG0oCuqnb3vobLyum"
+ <> "qjVZQO1dIrdwgTnCdpYzBcOfW5r370AFXjiWft_NGEiovonizhKpo9VVS78TzFgx"
+ <> "kIdrecRezsZ-1kYd_s1qDbxtkDEgfAITAG9LUnADun4vIcb6yelxk\","
+ <> " \"dp\":\"G4sPXkc6Ya9y8oJW9_ILj4xuppu0lzi_H7VTkS8xj5SdX3coE0oim"
+ <> "YwxIi2emTAue0UOa5dpgFGyBJ4c8tQ2VF402XRugKDTP8akYhFo5tAA77Qe_Nmtu"
+ <> "YZc3C3m3I24G2GvR5sSDxUyAN2zq8Lfn9EUms6rY3Ob8YeiKkTiBj0\","
+ <> " \"dq\":\"s9lAH9fggBsoFR8Oac2R_E2gw282rT2kGOAhvIllETE1efrA6huUU"
+ <> "vMfBcMpn8lqeW6vzznYY5SSQF7pMdC_agI3nG8Ibp1BUb0JUiraRNqUfLhcQb_d9"
+ <> "GF4Dh7e74WbRsobRonujTYN1xCaP6TO61jvWrX-L18txXw494Q_cgk\","
+ <> " \"qi\":\"GyM_p6JrXySiz1toFgKbWV-JdI3jQ4ypu9rbMWx3rQJBfmt0FoYzg"
+ <> "UIZEVFEcOqwemRN81zoDAaa-Bk0KWNGDjJHZDdDmFhW3AN7lI-puxk_mHZGJ11rx"
+ <> "yR8O55XLSe3SPmRfKwZI6yU24ZxvQKFYItdldUKGzO6Ia6zTKhAVRU\","
+ <> " \"alg\":\"RS256\","
+ <> " \"kid\":\"2011-04-29\"}"
+ <> " ]"
+ <> "}"
jwkAppendixA3Spec :: Spec
-jwkAppendixA3Spec = describe "JWK A.3. Example Symmetric Keys" $
+jwkAppendixA3Spec = describe "RFC 7517 A.3. Example Symmetric Keys" $
it "successfully decodes the examples" $
- lr (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldBe` R
+ (eitherDecode exampleJWKSet :: Either String JWKSet) `shouldSatisfy` is _Right
where
- exampleJWKSet = "\
- \{\"keys\":\
- \ [\
- \ {\"kty\":\"oct\",\
- \ \"alg\":\"A128KW\",\
- \ \"k\":\"GawgguFyGrWKav7AX4VKUg\"},\
- \\
- \ {\"kty\":\"oct\",\
- \ \"k\":\"AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75\
- \aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow\",\
- \ \"kid\":\"HMAC key used in JWS A.1 example\"}\
- \ ]\
- \}"
+ exampleJWKSet = ""
+ <> "{\"keys\":"
+ <> " ["
+ <> " {\"kty\":\"oct\","
+ <> " \"alg\":\"A128KW\","
+ <> " \"k\":\"GawgguFyGrWKav7AX4VKUg\"},"
+ <> ""
+ <> " {\"kty\":\"oct\","
+ <> " \"k\":\"AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75"
+ <> "aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow\","
+ <> " \"kid\":\"HMAC key used in JWS spec Appendix A.1 example\"}"
+ <> " ]"
+ <> "}"
jwkAppendixBSpec :: Spec
jwkAppendixBSpec = describe "JWK B. Example Use of \"x5c\" (X.509 Certificate Chain) Parameter" $
it "successfully decodes the example" $
- lr (eitherDecode exampleJWK :: Either String JWK) `shouldBe` R
+ (eitherDecode exampleJWK :: Either String JWK) `shouldSatisfy` is _Right
where
- exampleJWK = "\
- \{\"kty\":\"RSA\",\
- \ \"use\":\"sig\",\
- \ \"kid\":\"1b94c\",\
- \ \"n\":\"vrjOfz9Ccdgx5nQudyhdoR17V-IubWMeOZCwX_jj0hgAsz2J_pqYW08\
- \PLbK_PdiVGKPrqzmDIsLI7sA25VEnHU1uCLNwBuUiCO11_-7dYbsr4iJmG0Q\
- \u2j8DsVyT1azpJC_NG84Ty5KKthuCaPod7iI7w0LK9orSMhBEwwZDCxTWq4a\
- \YWAchc8t-emd9qOvWtVMDC2BXksRngh6X5bUYLy6AyHKvj-nUy1wgzjYQDwH\
- \MTplCoLtU-o-8SNnZ1tmRoGE9uJkBLdh5gFENabWnU5m1ZqZPdwS-qo-meMv\
- \VfJb6jJVWRpl2SUtCnYG2C32qvbWbjZ_jBPD5eunqsIo1vQ\",\
- \ \"e\":\"AQAB\",\
- \ \"x5c\":\
- \ [\"MIIDQjCCAiqgAwIBAgIGATz/FuLiMA0GCSqGSIb3DQEBBQUAMGIxCzAJB\
- \gNVBAYTAlVTMQswCQYDVQQIEwJDTzEPMA0GA1UEBxMGRGVudmVyMRwwGgYD\
- \VQQKExNQaW5nIElkZW50aXR5IENvcnAuMRcwFQYDVQQDEw5CcmlhbiBDYW1\
- \wYmVsbDAeFw0xMzAyMjEyMzI5MTVaFw0xODA4MTQyMjI5MTVaMGIxCzAJBg\
- \NVBAYTAlVTMQswCQYDVQQIEwJDTzEPMA0GA1UEBxMGRGVudmVyMRwwGgYDV\
- \QQKExNQaW5nIElkZW50aXR5IENvcnAuMRcwFQYDVQQDEw5CcmlhbiBDYW1w\
- \YmVsbDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAL64zn8/QnH\
- \YMeZ0LncoXaEde1fiLm1jHjmQsF/449IYALM9if6amFtPDy2yvz3YlRij66\
- \s5gyLCyO7ANuVRJx1NbgizcAblIgjtdf/u3WG7K+IiZhtELto/A7Fck9Ws6\
- \SQvzRvOE8uSirYbgmj6He4iO8NCyvaK0jIQRMMGQwsU1quGmFgHIXPLfnpn\
- \fajr1rVTAwtgV5LEZ4Iel+W1GC8ugMhyr4/p1MtcIM42EA8BzE6ZQqC7VPq\
- \PvEjZ2dbZkaBhPbiZAS3YeYBRDWm1p1OZtWamT3cEvqqPpnjL1XyW+oyVVk\
- \aZdklLQp2Btgt9qr21m42f4wTw+Xrp6rCKNb0CAwEAATANBgkqhkiG9w0BA\
- \QUFAAOCAQEAh8zGlfSlcI0o3rYDPBB07aXNswb4ECNIKG0CETTUxmXl9KUL\
- \+9gGlqCz5iWLOgWsnrcKcY0vXPG9J1r9AqBNTqNgHq2G03X09266X5CpOe1\
- \zFo+Owb1zxtp3PehFdfQJ610CDLEaS9V9Rqp17hCyybEpOGVwe8fnk+fbEL\
- \2Bo3UPGrpsHzUoaGpDftmWssZkhpBJKVMJyf/RuP2SmmaIzmnw9JiSlYhzo\
- \4tpzd5rFXhjRbg4zW9C+2qok+2+qDM1iJ684gPHMIY8aLWrdgQTxkumGmTq\
- \gawR+N5MDtdPTEQ0XfIBc2cJEUyMTY5MPvACWpkA6SdS4xSvdXK3IVfOWA==\"]\
- \}"
+ exampleJWK = ""
+ <> "{\"kty\":\"RSA\","
+ <> " \"use\":\"sig\","
+ <> " \"kid\":\"1b94c\","
+ <> " \"n\":\"vrjOfz9Ccdgx5nQudyhdoR17V-IubWMeOZCwX_jj0hgAsz2J_pqYW08"
+ <> "PLbK_PdiVGKPrqzmDIsLI7sA25VEnHU1uCLNwBuUiCO11_-7dYbsr4iJmG0Q"
+ <> "u2j8DsVyT1azpJC_NG84Ty5KKthuCaPod7iI7w0LK9orSMhBEwwZDCxTWq4a"
+ <> "YWAchc8t-emd9qOvWtVMDC2BXksRngh6X5bUYLy6AyHKvj-nUy1wgzjYQDwH"
+ <> "MTplCoLtU-o-8SNnZ1tmRoGE9uJkBLdh5gFENabWnU5m1ZqZPdwS-qo-meMv"
+ <> "VfJb6jJVWRpl2SUtCnYG2C32qvbWbjZ_jBPD5eunqsIo1vQ\","
+ <> " \"e\":\"AQAB\","
+ <> " \"x5c\":"
+ <> " [\"MIIDQjCCAiqgAwIBAgIGATz/FuLiMA0GCSqGSIb3DQEBBQUAMGIxCzAJB"
+ <> "gNVBAYTAlVTMQswCQYDVQQIEwJDTzEPMA0GA1UEBxMGRGVudmVyMRwwGgYD"
+ <> "VQQKExNQaW5nIElkZW50aXR5IENvcnAuMRcwFQYDVQQDEw5CcmlhbiBDYW1"
+ <> "wYmVsbDAeFw0xMzAyMjEyMzI5MTVaFw0xODA4MTQyMjI5MTVaMGIxCzAJBg"
+ <> "NVBAYTAlVTMQswCQYDVQQIEwJDTzEPMA0GA1UEBxMGRGVudmVyMRwwGgYDV"
+ <> "QQKExNQaW5nIElkZW50aXR5IENvcnAuMRcwFQYDVQQDEw5CcmlhbiBDYW1w"
+ <> "YmVsbDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAL64zn8/QnH"
+ <> "YMeZ0LncoXaEde1fiLm1jHjmQsF/449IYALM9if6amFtPDy2yvz3YlRij66"
+ <> "s5gyLCyO7ANuVRJx1NbgizcAblIgjtdf/u3WG7K+IiZhtELto/A7Fck9Ws6"
+ <> "SQvzRvOE8uSirYbgmj6He4iO8NCyvaK0jIQRMMGQwsU1quGmFgHIXPLfnpn"
+ <> "fajr1rVTAwtgV5LEZ4Iel+W1GC8ugMhyr4/p1MtcIM42EA8BzE6ZQqC7VPq"
+ <> "PvEjZ2dbZkaBhPbiZAS3YeYBRDWm1p1OZtWamT3cEvqqPpnjL1XyW+oyVVk"
+ <> "aZdklLQp2Btgt9qr21m42f4wTw+Xrp6rCKNb0CAwEAATANBgkqhkiG9w0BA"
+ <> "QUFAAOCAQEAh8zGlfSlcI0o3rYDPBB07aXNswb4ECNIKG0CETTUxmXl9KUL"
+ <> "+9gGlqCz5iWLOgWsnrcKcY0vXPG9J1r9AqBNTqNgHq2G03X09266X5CpOe1"
+ <> "zFo+Owb1zxtp3PehFdfQJ610CDLEaS9V9Rqp17hCyybEpOGVwe8fnk+fbEL"
+ <> "2Bo3UPGrpsHzUoaGpDftmWssZkhpBJKVMJyf/RuP2SmmaIzmnw9JiSlYhzo"
+ <> "4tpzd5rFXhjRbg4zW9C+2qok+2+qDM1iJ684gPHMIY8aLWrdgQTxkumGmTq"
+ <> "gawR+N5MDtdPTEQ0XfIBc2cJEUyMTY5MPvACWpkA6SdS4xSvdXK3IVfOWA==\"]"
+ <> "}"
jwkAppendixC1Spec :: Spec
-jwkAppendixC1Spec = describe "JWK C.1. Plaintext RSA Private Key" $
+jwkAppendixC1Spec = describe "RFC 7517 C.1. Plaintext RSA Private Key" $
it "successfully decodes the example" $
- lr (eitherDecode exampleJWK :: Either String JWK) `shouldBe` R
+ (eitherDecode exampleJWK :: Either String JWK) `shouldSatisfy` is _Right
where
- exampleJWK = "\
- \{\
- \ \"kty\":\"RSA\",\
- \ \"kid\":\"juliet@capulet.lit\",\
- \ \"use\":\"enc\",\
- \ \"n\":\"t6Q8PWSi1dkJj9hTP8hNYFlvadM7DflW9mWepOJhJ66w7nyoK1gPNqFMSQRy\
- \O125Gp-TEkodhWr0iujjHVx7BcV0llS4w5ACGgPrcAd6ZcSR0-Iqom-QFcNP\
- \8Sjg086MwoqQU_LYywlAGZ21WSdS_PERyGFiNnj3QQlO8Yns5jCtLCRwLHL0\
- \Pb1fEv45AuRIuUfVcPySBWYnDyGxvjYGDSM-AqWS9zIQ2ZilgT-GqUmipg0X\
- \OC0Cc20rgLe2ymLHjpHciCKVAbY5-L32-lSeZO-Os6U15_aXrk9Gw8cPUaX1\
- \_I8sLGuSiVdt3C_Fn2PZ3Z8i744FPFGGcG1qs2Wz-Q\",\
- \ \"e\":\"AQAB\",\
- \ \"d\":\"GRtbIQmhOZtyszfgKdg4u_N-R_mZGU_9k7JQ_jn1DnfTuMdSNprTeaSTyWfS\
- \NkuaAwnOEbIQVy1IQbWVV25NY3ybc_IhUJtfri7bAXYEReWaCl3hdlPKXy9U\
- \vqPYGR0kIXTQRqns-dVJ7jahlI7LyckrpTmrM8dWBo4_PMaenNnPiQgO0xnu\
- \ToxutRZJfJvG4Ox4ka3GORQd9CsCZ2vsUDmsXOfUENOyMqADC6p1M3h33tsu\
- \rY15k9qMSpG9OX_IJAXmxzAh_tWiZOwk2K4yxH9tS3Lq1yX8C1EWmeRDkK2a\
- \hecG85-oLKQt5VEpWHKmjOi_gJSdSgqcN96X52esAQ\",\
- \ \"p\":\"2rnSOV4hKSN8sS4CgcQHFbs08XboFDqKum3sc4h3GRxrTmQdl1ZK9uw-PIHf\
- \QP0FkxXVrx-WE-ZEbrqivH_2iCLUS7wAl6XvARt1KkIaUxPPSYB9yk31s0Q8\
- \UK96E3_OrADAYtAJs-M3JxCLfNgqh56HDnETTQhH3rCT5T3yJws\",\
- \ \"q\":\"1u_RiFDP7LBYh3N4GXLT9OpSKYP0uQZyiaZwBtOCBNJgQxaj10RWjsZu0c6I\
- \edis4S7B_coSKB0Kj9PaPaBzg-IySRvvcQuPamQu66riMhjVtG6TlV8CLCYK\
- \rYl52ziqK0E_ym2QnkwsUX7eYTB7LbAHRK9GqocDE5B0f808I4s\",\
- \ \"dp\":\"KkMTWqBUefVwZ2_Dbj1pPQqyHSHjj90L5x_MOzqYAJMcLMZtbUtwKqvVDq3\
- \tbEo3ZIcohbDtt6SbfmWzggabpQxNxuBpoOOf_a_HgMXK_lhqigI4y_kqS1w\
- \Y52IwjUn5rgRrJ-yYo1h41KR-vz2pYhEAeYrhttWtxVqLCRViD6c\",\
- \ \"dq\":\"AvfS0-gRxvn0bwJoMSnFxYcK1WnuEjQFluMGfwGitQBWtfZ1Er7t1xDkbN9\
- \GQTB9yqpDoYaN06H7CFtrkxhJIBQaj6nkF5KKS3TQtQ5qCzkOkmxIe3KRbBy\
- \mXxkb5qwUpX5ELD5xFc6FeiafWYY63TmmEAu_lRFCOJ3xDea-ots\",\
- \ \"qi\":\"lSQi-w9CpyUReMErP1RsBLk7wNtOvs5EQpPqmuMvqW57NBUczScEoPwmUqq\
- \abu9V0-Py4dQ57_bapoKRu1R90bvuFnU63SHWEFglZQvJDMeAvmj4sm-Fp0o\
- \Yu_neotgQ0hzbI5gry7ajdYy9-2lNx_76aBZoOUu9HCJ-UsfSOI8\"\
- \}"
-
-data LR = L | R deriving (Eq, Show)
-
-lr :: Either a b -> LR
-lr (Left _) = L
-lr _ = R
+ exampleJWK = ""
+ <> "{"
+ <> " \"kty\":\"RSA\","
+ <> " \"kid\":\"juliet@capulet.lit\","
+ <> " \"use\":\"enc\","
+ <> " \"n\":\"t6Q8PWSi1dkJj9hTP8hNYFlvadM7DflW9mWepOJhJ66w7nyoK1gPNqFMSQRy"
+ <> "O125Gp-TEkodhWr0iujjHVx7BcV0llS4w5ACGgPrcAd6ZcSR0-Iqom-QFcNP"
+ <> "8Sjg086MwoqQU_LYywlAGZ21WSdS_PERyGFiNnj3QQlO8Yns5jCtLCRwLHL0"
+ <> "Pb1fEv45AuRIuUfVcPySBWYnDyGxvjYGDSM-AqWS9zIQ2ZilgT-GqUmipg0X"
+ <> "OC0Cc20rgLe2ymLHjpHciCKVAbY5-L32-lSeZO-Os6U15_aXrk9Gw8cPUaX1"
+ <> "_I8sLGuSiVdt3C_Fn2PZ3Z8i744FPFGGcG1qs2Wz-Q\","
+ <> " \"e\":\"AQAB\","
+ <> " \"d\":\"GRtbIQmhOZtyszfgKdg4u_N-R_mZGU_9k7JQ_jn1DnfTuMdSNprTeaSTyWfS"
+ <> "NkuaAwnOEbIQVy1IQbWVV25NY3ybc_IhUJtfri7bAXYEReWaCl3hdlPKXy9U"
+ <> "vqPYGR0kIXTQRqns-dVJ7jahlI7LyckrpTmrM8dWBo4_PMaenNnPiQgO0xnu"
+ <> "ToxutRZJfJvG4Ox4ka3GORQd9CsCZ2vsUDmsXOfUENOyMqADC6p1M3h33tsu"
+ <> "rY15k9qMSpG9OX_IJAXmxzAh_tWiZOwk2K4yxH9tS3Lq1yX8C1EWmeRDkK2a"
+ <> "hecG85-oLKQt5VEpWHKmjOi_gJSdSgqcN96X52esAQ\","
+ <> " \"p\":\"2rnSOV4hKSN8sS4CgcQHFbs08XboFDqKum3sc4h3GRxrTmQdl1ZK9uw-PIHf"
+ <> "QP0FkxXVrx-WE-ZEbrqivH_2iCLUS7wAl6XvARt1KkIaUxPPSYB9yk31s0Q8"
+ <> "UK96E3_OrADAYtAJs-M3JxCLfNgqh56HDnETTQhH3rCT5T3yJws\","
+ <> " \"q\":\"1u_RiFDP7LBYh3N4GXLT9OpSKYP0uQZyiaZwBtOCBNJgQxaj10RWjsZu0c6I"
+ <> "edis4S7B_coSKB0Kj9PaPaBzg-IySRvvcQuPamQu66riMhjVtG6TlV8CLCYK"
+ <> "rYl52ziqK0E_ym2QnkwsUX7eYTB7LbAHRK9GqocDE5B0f808I4s\","
+ <> " \"dp\":\"KkMTWqBUefVwZ2_Dbj1pPQqyHSHjj90L5x_MOzqYAJMcLMZtbUtwKqvVDq3"
+ <> "tbEo3ZIcohbDtt6SbfmWzggabpQxNxuBpoOOf_a_HgMXK_lhqigI4y_kqS1w"
+ <> "Y52IwjUn5rgRrJ-yYo1h41KR-vz2pYhEAeYrhttWtxVqLCRViD6c\","
+ <> " \"dq\":\"AvfS0-gRxvn0bwJoMSnFxYcK1WnuEjQFluMGfwGitQBWtfZ1Er7t1xDkbN9"
+ <> "GQTB9yqpDoYaN06H7CFtrkxhJIBQaj6nkF5KKS3TQtQ5qCzkOkmxIe3KRbBy"
+ <> "mXxkb5qwUpX5ELD5xFc6FeiafWYY63TmmEAu_lRFCOJ3xDea-ots\","
+ <> " \"qi\":\"lSQi-w9CpyUReMErP1RsBLk7wNtOvs5EQpPqmuMvqW57NBUczScEoPwmUqq"
+ <> "abu9V0-Py4dQ57_bapoKRu1R90bvuFnU63SHWEFglZQvJDMeAvmj4sm-Fp0o"
+ <> "Yu_neotgQ0hzbI5gry7ajdYy9-2lNx_76aBZoOUu9HCJ-UsfSOI8\""
+ <> "}"
+
+cfrgSpec :: Spec
+cfrgSpec = describe "RFC 8037 test vectors" $ do
+ let
+ _A2_jwkJson = ""
+ <> "{\"kty\":\"OKP\",\"crv\":\"Ed25519\","
+ <> "\"x\":\"11qYAYKxCrfVS_7TyWQHOg7hcvPapiMlrwIaaPcHURo\"}"
+ _A1_result = eitherDecode rfc8037_A1_jwkJson :: Either String JWK
+ _A2_result = eitherDecode _A2_jwkJson
+ describe "A.1. Ed25519 Private Key" $
+ it "successfully decodes the example" $ _A1_result `shouldSatisfy` is _Right
+ describe "A.2. Ed25519 Public Key" $ do
+ it "successfully decodes the example" $ _A2_result `shouldSatisfy` is _Right
+ it "corresponds to A.1. private key" $ Right True == do
+ sk <- _A1_result
+ pk <- _A2_result
+ pure $ maybe False (== pk) (view asPublicKey sk)
+
+rfc8037_A1_jwkJson = ""
+ <> "{\"kty\":\"OKP\",\"crv\":\"Ed25519\","
+ <> "\"d\":\"nWGxne_9WmC6hEr0kuwsxERJxWl7MmkZcDusAxyuf2A\","
+ <> "\"x\":\"11qYAYKxCrfVS_7TyWQHOg7hcvPapiMlrwIaaPcHURo\"}"
+
+
+#if MIN_VERSION_aeson(0,10,0)
+thumbprintSpec :: Spec
+thumbprintSpec = describe "JWK Thumbprint" $ do
+ describe "RFC 7638 §3.1. Example JWK Thumbprint Computation" $ do
+ let
+ Just k = decode $ ""
+ <> "{"
+ <> " \"kty\": \"RSA\","
+ <> " \"n\": \"0vx7agoebGcQSuuPiLJXZptN9nndrQmbXEps2aiAFbWhM78LhWx4cbbfAAt"
+ <> "VT86zwu1RK7aPFFxuhDR1L6tSoc_BJECPebWKRXjBZCiFV4n3oknjhMstn6"
+ <> "4tZ_2W-5JsGY4Hc5n9yBXArwl93lqt7_RN5w6Cf0h4QyQ5v-65YGjQR0_FD"
+ <> "W2QvzqY368QQMicAtaSqzs8KJZgnYb9c7d0zgdAZHzu6qMQvRL5hajrn1n9"
+ <> "1CbOpbISD08qNLyrdkt-bFTWhAI4vMQFh6WeZu0fM4lFd2NcRwr3XPksINH"
+ <> "aQ-G_xBniIqbw0Ls1jF44-csFCur-kEgU8awapJzKnqDKgw\","
+ <> " \"e\": \"AQAB\","
+ <> " \"alg\": \"RS256\","
+ <> " \"kid\": \"2011-04-29\""
+ <> "}"
+ it "correctly computes thumbprint of RSA key" $
+ review (base64url . digest) (view thumbprint k :: Digest SHA256)
+ `shouldBe` ("NzbLsXh8uDCcd-6MNwXF4W_7noWXFZAfHkxZsRGC9Xs" :: B.ByteString)
+ describe "RFC 8037 A.3. JWK Thumbprint Canonicalization" $ do
+ let Just k = decode rfc8037_A1_jwkJson
+ it "correctly computes thumbprint of Ed25519 key" $
+ review (base64url . digest) (view thumbprint k :: Digest SHA256)
+ `shouldBe` ("kPrK_qmxVWaYVA9wwBF6Iuo3vVzz7TxHCTwXBygrS4k" :: B.ByteString)
+#endif
diff --git a/test/JWS.hs b/test/JWS.hs
index d5c94a9..f8bbf71 100644
--- a/test/JWS.hs
+++ b/test/JWS.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2013, 2014, 2015 Fraser Tweedale
+-- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -17,23 +17,25 @@
module JWS where
import Data.Maybe
+import Data.Monoid ((<>))
-import Control.Lens
+import Control.Lens hiding ((.=))
+import Control.Lens.Extras (is)
+import Control.Lens.Cons.Extras (recons)
+import Control.Monad.Except (runExceptT)
import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Base64.URL as B64U
-import Data.Default.Class
import Test.Hspec
import Crypto.JOSE.Compact
+import Crypto.JOSE.Error (Error)
import Crypto.JOSE.JWA.JWK
import Crypto.JOSE.JWK
import Crypto.JOSE.JWS
-import Crypto.JOSE.JWS.Internal
import qualified Crypto.JOSE.JWA.JWS as JWA.JWS
import qualified Crypto.JOSE.Types as Types
-import Crypto.JOSE.Types.Armour
drg :: ChaChaDRG
@@ -41,91 +43,191 @@ drg = drgNewTest (1,2,3,4,5)
spec :: Spec
spec = do
- critSpec
- critSpec'
headerSpec
appendixA1Spec
appendixA2Spec
appendixA3Spec
appendixA5Spec
appendixA6Spec
+ cfrgSpec
-critSpec :: Spec
-critSpec = describe "JWS §4.1.10. \"crit\" Header Parameter; parsing" $
- it "parses from JSON correctly" $ do
- decode good `shouldBe`
- Just (CritParameters $ return ("exp", Number 1363284000))
- decode "{}" `shouldBe` (Nothing :: Maybe CritParameters)
- decode missingParam `shouldBe` (Nothing :: Maybe CritParameters)
- decode critNotArray `shouldBe` (Nothing :: Maybe CritParameters)
- decode critEmptyArray `shouldBe` (Nothing :: Maybe CritParameters)
- decode critValueNotString `shouldBe` (Nothing :: Maybe CritParameters)
- decode critValueNotValid `shouldBe` (Nothing :: Maybe CritParameters)
- where
- good = "{\"alg\":\"ES256\",\"crit\":[\"exp\"],\"exp\":1363284000}"
- missingParam = "{\"alg\":\"ES256\",\"crit\":[\"nope\"]}"
- critNotArray = "{\"alg\":\"ES256\",\"crit\":\"exp\"}"
- critEmptyArray = "{\"alg\":\"ES256\",\"crit\":[]}"
- critValueNotString = "{\"alg\":\"ES256\",\"crit\":[1234]}"
- critValueNotValid = "{\"alg\":\"ES256\",\"crit\":[\"crit\"]}"
-
-critSpec' :: Spec
-critSpec' = describe "JWS §4.1.10. \"crit\" Header Parameter; full example" $
- it "parses from JSON correctly" $
- decode s `shouldBe` Just ((newJWSHeader JWA.JWS.ES256) { headerCrit = Just critValue })
- where
- s = "{\"alg\":\"ES256\",\"crit\":[\"exp\"],\"exp\":1363284000}"
- critValue = CritParameters $ return ("exp", Number 1363284000)
+-- Extension of JWSHeader to test "crit" behaviour
+--
+newtype JWSHeader' p = JWSHeader' { unJWSHeader' :: JWSHeader p }
+ deriving (Eq, Show)
+_JWSHeader' :: Iso' (JWSHeader' p) (JWSHeader p)
+_JWSHeader' = iso unJWSHeader' JWSHeader'
+instance HasJWSHeader JWSHeader' where
+ jwsHeader = _JWSHeader'
+instance HasParams JWSHeader' where
+ parseParamsFor proxy hp hu = JWSHeader' <$> parseParamsFor proxy hp hu
+ params (JWSHeader' h) = params h
+ extensions = const ["foo"]
+
+-- More elaborate extension of JWSHeader to test parsing behaviour
+--
+data ACMEHeader p = ACMEHeader
+ { _acmeJwsHeader :: JWSHeader p
+ , _acmeNonce :: Types.Base64Octets
+ } deriving (Show)
+acmeJwsHeader :: Lens' (ACMEHeader p) (JWSHeader p)
+acmeJwsHeader f s@(ACMEHeader { _acmeJwsHeader = a}) =
+ fmap (\a' -> s { _acmeJwsHeader = a'}) (f a)
+acmeNonce :: Lens' (ACMEHeader p) Types.Base64Octets
+acmeNonce f s@(ACMEHeader { _acmeNonce = a}) =
+ fmap (\a' -> s { _acmeNonce = a'}) (f a)
+instance HasJWSHeader ACMEHeader where
+ jwsHeader = acmeJwsHeader
+instance HasParams ACMEHeader where
+ parseParamsFor proxy hp hu = ACMEHeader
+ <$> parseParamsFor proxy hp hu
+ <*> headerRequiredProtected "nonce" hp hu
+ params h =
+ (True, "nonce" .= view acmeNonce h)
+ : params (view acmeJwsHeader h)
+ extensions = const ["nonce"]
-headerSpec :: Spec
-headerSpec = describe "(unencoded) Header" $ do
- it "parses from JSON correctly" $
- let
- headerJSON = "{\"typ\":\"JWT\",\r\n \"alg\":\"HS256\"}"
- typValue = Just "JWT"
- in
- eitherDecode headerJSON
- `shouldBe` Right ((newJWSHeader JWA.JWS.HS256) { headerTyp = typValue })
- it "parses signature correctly" $
+headerSpec :: Spec
+headerSpec = describe "JWS Header" $ do
+ it "parses signature correctly" $ do
let
sigJSON =
"{\"protected\":\"eyJhbGciOiJSUzI1NiJ9\",\
\ \"header\":{\"kid\":\"2010-12-29\"},\
\ \"signature\":\"\"}"
- h = def { headerAlg = Just JWA.JWS.RS256 }
- h' = def { headerKid = Just "2010-12-29" }
- sig = Signature (Just $ Unarmoured h) (Just h') (Types.Base64Octets "")
+ h = newJWSHeader (Protected, JWA.JWS.RS256)
+ & kid .~ Just (HeaderParam Unprotected "2010-12-29")
+ sig = eitherDecode sigJSON
+ sig ^? _Right . header `shouldBe` Just h
+ sig ^? _Right . signature `shouldBe` Just ("" :: BS.ByteString)
+
+ it "rejects duplicate headers" $
+ let
+ -- protected header: {"kid":""}
+ s = "{\"protected\":\"eyJraWQiOiIifQ\",\"header\":{\"alg\":\"none\",\"kid\":\"\"},\"signature\":\"\"}"
in
- eitherDecode sigJSON `shouldBe` Right sig
+ (eitherDecode s :: Either String (Signature Protection JWSHeader))
+ `shouldSatisfy` is _Left
+ it "rejects reserved crit parameters" $
+ let
+ -- protected header: {"crit":["kid"],"kid":""}
+ s = "{\"protected\":\"eyJjcml0IjpbImtpZCJdLCJraWQiOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection JWSHeader))
+ `shouldSatisfy` is _Left
-examplePayload :: Types.Base64Octets
-examplePayload = Types.Base64Octets "\
+ it "rejects unknown crit parameters" $
+ let
+ -- protected header: {"crit":["foo"],"foo":""}
+ s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdLCJmb28iOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection JWSHeader))
+ `shouldSatisfy` is _Left
+
+ it "accepts known crit parameter in protected header" $
+ let
+ -- protected header: {"crit":["foo"],"foo":""}
+ s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdLCJmb28iOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection JWSHeader'))
+ `shouldSatisfy` is _Right
+
+ it "accepts known crit parameter in unprotected header" $
+ let
+ -- protected header: {"crit":["foo"]}
+ s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdfQ\",\"header\":{\"alg\":\"none\",\"foo\":\"\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection JWSHeader'))
+ `shouldSatisfy` is _Right
+
+ it "rejects known crit parameter that does not appear in JOSE header" $
+ let
+ -- protected header: {"crit":["foo"]}
+ s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdfQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection JWSHeader'))
+ `shouldSatisfy` is _Left
+
+ it "rejects unprotected crit parameters" $
+ let
+ s = "{\"header\":{\"alg\":\"none\",\"crit\":[\"foo\"],\"foo\":\"\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection JWSHeader'))
+ `shouldSatisfy` is _Left
+
+ it "rejects empty crit parameters" $
+ let
+ -- protected header: {"crit":[]}
+ s = "{\"protected\":\"eyJjcml0IjpbXX0\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection JWSHeader'))
+ `shouldSatisfy` is _Left
+
+ it "parses required protected header when present in protected header" $
+ let
+ -- protected header: {"crit":["nonce"],"nonce":"bm9uY2U"}
+ s = "{\"protected\":\"eyJjcml0IjpbIm5vbmNlIl0sIm5vbmNlIjoiYm05dVkyVSJ9\""
+ <>",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection ACMEHeader))
+ `shouldSatisfy` is _Right
+
+ it "rejects required protected header when present in unprotected header" $
+ let
+ s = "{\"header\":{\"alg\":\"none\"},\"nonce\":\"bm9uY2U\",\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection ACMEHeader))
+ `shouldSatisfy` is _Left
+
+ it "accepts unprotected \"alg\" param with 'Protection' protection indicator" $
+ let
+ s = "{\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature Protection JWSHeader))
+ `shouldSatisfy` is _Right
+
+ it "rejects unprotected \"alg\" param with '()' protection indicator" $
+ let
+ s = "{\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"
+ in
+ (eitherDecode s :: Either String (Signature () JWSHeader))
+ `shouldSatisfy` is _Left
+
+
+examplePayloadBytes :: BS.ByteString
+examplePayloadBytes = "\
\{\"iss\":\"joe\",\r\n\
\ \"exp\":1300819380,\r\n\
\ \"http://example.com/is_root\":true}"
+examplePayload :: Types.Base64Octets
+examplePayload = Types.Base64Octets examplePayloadBytes
+
appendixA1Spec :: Spec
-appendixA1Spec = describe "JWS A.1. Example JWS using HMAC SHA-256" $ do
+appendixA1Spec = describe "RFC 7515 A.1. Example JWS using HMAC SHA-256" $ do
-- can't make aeson encode JSON to exact representation used in
-- IETF doc, be we can go in reverse and then ensure that the
-- round-trip checks out
--
- it "decodes the example to the correct value" $
- decodeCompact compactJWS `shouldBe` Right jws
+ it "decodes the example to the correct value" $ do
+ jws ^? _Right . signatures . signature `shouldBe` Just mac
+ jws ^? _Right . signatures . header `shouldBe` Just h
- it "round-trips correctly" $
- (encodeCompact jws >>= decodeCompact) `shouldBe` Right jws
+ it "serialises the decoded JWS back to the original data" $
+ fmap encodeCompact jws `shouldBe` Right compactJWS
it "computes the HMAC correctly" $
- fst (withDRG drg $ sign alg (jwk ^. jwkMaterial) (L.toStrict signingInput'))
- `shouldBe` Right (BS.pack macOctets)
+ fst (withDRG drg $
+ runExceptT (sign alg (jwk ^. jwkMaterial) (signingInput' ^. recons)))
+ `shouldBe` (Right mac :: Either Error BS.ByteString)
it "validates the JWS correctly" $
- fmap (verifyJWS def def jwk) (decodeCompact compactJWS) `shouldBe` Right True
+ (jws >>= verifyJWS defaultValidationSettings jwk)
+ `shouldBe` Right examplePayloadBytes
where
signingInput' = "\
@@ -133,21 +235,16 @@ appendixA1Spec = describe "JWS A.1. Example JWS using HMAC SHA-256" $ do
\.\
\eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\
\cGxlLmNvbS9pc19yb290Ijp0cnVlfQ"
- compactJWS = signingInput' `L.append` "\
- \.\
- \dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"
- jws = JWS examplePayload [signature]
- signature = Signature (Just $ Unarmoured h) Nothing (Types.Base64Octets mac)
+ compactJWS = signingInput' <> ".dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"
+ jws = decodeCompact compactJWS :: Either Error (CompactJWS JWSHeader)
alg = JWA.JWS.HS256
- h = def { headerAlg = Just alg, headerTyp = Just "JWT" }
- mac = foldr BS.cons BS.empty macOctets
- macOctets =
+ h = newJWSHeader ((), alg)
+ & typ .~ Just (HeaderParam () "JWT")
+ mac = view recons
[116, 24, 223, 180, 151, 153, 224, 37, 79, 250, 96, 125, 216, 173,
187, 186, 22, 212, 37, 77, 105, 214, 191, 240, 91, 88, 5, 88, 83,
132, 141, 121]
- jwk = JWK (OctKeyMaterial octKeyMaterial) z z z z z z z z where z = Nothing
- octKeyMaterial = OctKeyParameters Oct $ Types.Base64Octets $
- foldr BS.cons BS.empty
+ jwk = fromOctets
[3,35,53,75,43,15,165,188,131,126,6,101,119,123,166,143,90,179,40,
230,240,84,201,40,169,15,132,178,210,80,46,191,211,251,90,146,
210,6,71,239,150,138,180,195,119,98,61,34,61,46,33,114,5,46,79,8,
@@ -155,13 +252,14 @@ appendixA1Spec = describe "JWS A.1. Example JWS using HMAC SHA-256" $ do
appendixA2Spec :: Spec
-appendixA2Spec = describe "JWS A.2. Example JWS using RSASSA-PKCS-v1_5 SHA-256" $ do
+appendixA2Spec = describe "RFC 7515 A.2. Example JWS using RSASSA-PKCS-v1_5 SHA-256" $ do
it "computes the signature correctly" $
- fst (withDRG drg $ sign JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput')
- `shouldBe` Right sig
+ fst (withDRG drg $ runExceptT (sign JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput'))
+ `shouldBe` (Right sig :: Either Error BS.ByteString)
it "validates the signature correctly" $
- verify JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput' sig `shouldBe` Right True
+ verify JWA.JWS.RS256 (jwk ^. jwkMaterial) signingInput' sig
+ `shouldBe` (Right True :: Either Error Bool)
where
signingInput' = "\
@@ -208,9 +306,10 @@ appendixA2Spec = describe "JWS A.2. Example JWS using RSASSA-PKCS-v1_5 SHA-256"
appendixA3Spec :: Spec
-appendixA3Spec = describe "JWS A.3. Example JWS using ECDSA P-256 SHA-256" $
+appendixA3Spec = describe "RFC 7515 A.3. Example JWS using ECDSA P-256 SHA-256" $
it "validates the signature correctly" $
- verify JWA.JWS.ES256 (jwk ^. jwkMaterial) signingInput' sig `shouldBe` Right True
+ verify JWA.JWS.ES256 (jwk ^. jwkMaterial) signingInput' sig
+ `shouldBe` (Right True :: Either Error Bool)
where
signingInput' = "\
\eyJhbGciOiJFUzI1NiJ9\
@@ -233,16 +332,17 @@ appendixA3Spec = describe "JWS A.3. Example JWS using ECDSA P-256 SHA-256" $
143, 63, 127, 138, 131, 163, 84, 213]
appendixA5Spec :: Spec
-appendixA5Spec = describe "JWS A.5. Example Plaintext JWS" $ do
+appendixA5Spec = describe "RFC 7515 A.5. Example Unsecured JWS" $ do
it "encodes the correct JWS" $
- (jws >>= encodeCompact) `shouldBe` Right exampleJWS
+ fmap encodeCompact jws `shouldBe` Right exampleJWS
it "decodes the correct JWS" $
decodeCompact exampleJWS `shouldBe` jws
where
- jws = fst $ withDRG drg $
- signJWS (JWS examplePayload []) (newJWSHeader JWA.JWS.None) undefined
+ jws = fst $ withDRG drg $ runExceptT $
+ signJWS examplePayloadBytes (Identity (newJWSHeader ((), JWA.JWS.None), undefined))
+ :: Either Error (CompactJWS JWSHeader)
exampleJWS = "eyJhbGciOiJub25lIn0\
\.\
\eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\
@@ -251,19 +351,47 @@ appendixA5Spec = describe "JWS A.5. Example Plaintext JWS" $ do
appendixA6Spec :: Spec
-appendixA6Spec = describe "JWS A.6. Example JWS Using JWS JSON Serialization" $
- it "decodes the correct JWS" $ do
- eitherDecode exampleJWS `shouldBe` Right jws
- eitherDecode exampleJWS' `shouldBe` Right jws'
- lr (eitherDecode exampleFlatJWSWithSignatures :: Either String JWS) `shouldBe` L
+appendixA6Spec = describe "RFC 7515 A.6. Example JWS Using General JSON Serialization" $ do
+ it "decodes JWS with multiple signatures correctly" $ do
+ let jws = eitherDecode exampleJWSTwoSigs :: Either String (GeneralJWS JWSHeader)
+ lengthOf (_Right . signatures) jws `shouldBe` 2
+ jws ^? _Right . signatures . header `shouldBe` Just h1'
+ jws ^? _Right . signatures . signature `shouldBe` Just mac1
+ jws ^? _Right . dropping 1 signatures . header `shouldBe` Just h2'
+ jws ^? _Right . dropping 1 signatures . signature `shouldBe` Just mac2
+
+ it "decodes single-sig Generalised JWS correctly" $ do
+ let jws = eitherDecode exampleJWSOneSig :: Either String (GeneralJWS JWSHeader)
+ lengthOf (_Right . signatures) jws `shouldBe` 1
+ jws ^? _Right . signatures . header `shouldBe` Just h2'
+ jws ^? _Right . signatures . signature `shouldBe` Just mac2
+
+ it "fails to decode single-sig Generalised JWS to 'JWS Identity'" $ do
+ (eitherDecode exampleJWSOneSig :: Either String (FlattenedJWS JWSHeader))
+ `shouldSatisfy` is _Left
+
+ it "decodes flattened JWS to 'JWS []' correctly" $ do
+ let jws = eitherDecode exampleJWSFlat :: Either String (GeneralJWS JWSHeader)
+ lengthOf (_Right . signatures) jws `shouldBe` 1
+ jws ^? _Right . signatures . header `shouldBe` Just h2'
+ jws ^? _Right . signatures . signature `shouldBe` Just mac2
+
+ it "decodes flattened JWS to 'JWS Identity' correctly" $ do
+ let jws = eitherDecode exampleJWSFlat :: Either String (FlattenedJWS JWSHeader)
+ lengthOf (_Right . signatures) jws `shouldBe` 1
+ jws ^? _Right . signatures . header `shouldBe` Just h2'
+ jws ^? _Right . signatures . signature `shouldBe` Just mac2
+
+ it "fails to decode flattened JWS when \"signatures\" key is present" $ do
+ (eitherDecode exampleFlatJWSWithSignatures :: Either String (GeneralJWS JWSHeader))
+ `shouldSatisfy` is _Left
+ (eitherDecode exampleFlatJWSWithSignatures :: Either String (FlattenedJWS JWSHeader))
+ `shouldSatisfy` is _Left
where
- jws = JWS examplePayload [sig1, sig2]
- jws' = JWS examplePayload [sig2]
- sig1 = Signature (Just $ Unarmoured h1) (Just h1') (Types.Base64Octets mac1)
- h1 = def { headerAlg = Just JWA.JWS.RS256 }
- h1' = def { headerKid = Just "2010-12-29" }
- mac1 = foldr BS.cons BS.empty
+ h1 = newJWSHeader (Protected, JWA.JWS.RS256)
+ h1' = h1 & kid .~ Just (HeaderParam Unprotected "2010-12-29")
+ mac1 = view recons
[112, 46, 33, 137, 67, 232, 143, 209, 30, 181, 216, 45, 191, 120, 69,
243, 65, 6, 174, 27, 129, 255, 247, 115, 17, 22, 173, 209, 113, 125,
131, 101, 109, 66, 10, 253, 60, 150, 238, 221, 115, 162, 102, 62, 81,
@@ -281,15 +409,14 @@ appendixA6Spec = describe "JWS A.6. Example JWS Using JWS JSON Serialization" $
34, 165, 68, 200, 242, 122, 122, 45, 184, 6, 99, 209, 108, 247, 202,
234, 86, 222, 64, 92, 178, 33, 90, 69, 178, 194, 85, 102, 181, 90,
193, 167, 72, 160, 112, 223, 200, 163, 42, 70, 149, 67, 208, 25, 238,
- 251, 71]
- sig2 = Signature (Just $ Unarmoured h2) (Just h2') (Types.Base64Octets mac2)
- h2 = def { headerAlg = Just JWA.JWS.ES256 }
- h2' = def { headerKid = Just "e9bc097a-ce51-4036-9562-d2ade882db0d" }
+ 251, 71] :: BS.ByteString
+ h2 = newJWSHeader (Protected, JWA.JWS.ES256)
+ h2' = h2 & kid .~ Just (HeaderParam Unprotected "e9bc097a-ce51-4036-9562-d2ade882db0d")
mac2 = B64U.decodeLenient
"DtEhU3ljbEg8L38VWAfUAqOyKAM6-Xx-F4GawxaepmXFCgfTjDxw5djxLa8ISlSA\
\pmWQxfKTUJqPP3-Kg6NU1Q"
- exampleJWS = "\
+ exampleJWSTwoSigs = "\
\{\"payload\":\
\ \"eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGF\
\tcGxlLmNvbS9pc19yb290Ijp0cnVlfQ\",\
@@ -311,7 +438,19 @@ appendixA6Spec = describe "JWS A.6. Example JWS Using JWS JSON Serialization" $
\ \"DtEhU3ljbEg8L38VWAfUAqOyKAM6-Xx-F4GawxaepmXFCgfTjDxw5djxLa8IS\
\lSApmWQxfKTUJqPP3-Kg6NU1Q\"}]\
\}"
- exampleJWS' = "\
+ exampleJWSOneSig = "\
+ \{\"payload\":\
+ \ \"eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGF\
+ \tcGxlLmNvbS9pc19yb290Ijp0cnVlfQ\",\
+ \ \"signatures\":[\
+ \ {\"protected\":\"eyJhbGciOiJFUzI1NiJ9\",\
+ \ \"header\":\
+ \ {\"kid\":\"e9bc097a-ce51-4036-9562-d2ade882db0d\"},\
+ \ \"signature\":\
+ \ \"DtEhU3ljbEg8L38VWAfUAqOyKAM6-Xx-F4GawxaepmXFCgfTjDxw5djxLa8IS\
+ \lSApmWQxfKTUJqPP3-Kg6NU1Q\"}]\
+ \}"
+ exampleJWSFlat = "\
\{\
\ \"payload\":\
\ \"eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGF\
@@ -337,8 +476,23 @@ appendixA6Spec = describe "JWS A.6. Example JWS Using JWS JSON Serialization" $
\ \"signatures\":\"bogus\"\
\}"
-data LR = L | R deriving (Eq, Show)
-
-lr :: Either a b -> LR
-lr (Left _) = L
-lr _ = R
+cfrgSpec :: Spec
+cfrgSpec = describe "RFC 8037 signature/validation test vectors" $ do
+ let
+ jwk = fromJust $ decode "\
+ \{\"kty\":\"OKP\",\"crv\":\"Ed25519\",\
+ \\"d\":\"nWGxne_9WmC6hEr0kuwsxERJxWl7MmkZcDusAxyuf2A\",\
+ \\"x\":\"11qYAYKxCrfVS_7TyWQHOg7hcvPapiMlrwIaaPcHURo\"}"
+ sigOctets =
+ [0x86,0x0c,0x98,0xd2,0x29,0x7f,0x30,0x60,0xa3,0x3f,0x42,0x73,0x96,0x72,0xd6,0x1b
+ ,0x53,0xcf,0x3a,0xde,0xfe,0xd3,0xd3,0xc6,0x72,0xf3,0x20,0xdc,0x02,0x1b,0x41,0x1e
+ ,0x9d,0x59,0xb8,0x62,0x8d,0xc3,0x51,0xe2,0x48,0xb8,0x8b,0x29,0x46,0x8e,0x0e,0x41
+ ,0x85,0x5b,0x0f,0xb7,0xd8,0x3b,0xb1,0x5b,0xe9,0x02,0xbf,0xcc,0xb8,0xcd,0x0a,0x02]
+ sig = BS.pack sigOctets
+ signingInput = "eyJhbGciOiJFZERTQSJ9.RXhhbXBsZSBvZiBFZDI1NTE5IHNpZ25pbmc"
+ it "computes the correct signature" $
+ fst (withDRG drg $ runExceptT (sign JWA.JWS.EdDSA (view jwkMaterial jwk) signingInput))
+ `shouldBe` (Right sig :: Either Error BS.ByteString)
+ it "validates signatures correctly" $
+ verify JWA.JWS.EdDSA (view jwkMaterial jwk) signingInput sig
+ `shouldBe` (Right True :: Either Error Bool)
diff --git a/test/JWT.hs b/test/JWT.hs
index fa25d6f..a8352ed 100644
--- a/test/JWT.hs
+++ b/test/JWT.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2013, 2014 Fraser Tweedale
+-- Copyright (C) 2013, 2014, 2015, 2016 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -12,37 +12,53 @@
-- See the License for the specific language governing permissions and
-- limitations under the License.
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module JWT where
import Data.Maybe
+import Data.Monoid ((<>))
import Control.Lens
-import Data.Aeson
-import Data.Default.Class (def)
+import Control.Lens.Extras (is)
+import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
+import Control.Monad.State (execState)
+import Control.Monad.Time (MonadTime(..))
+import Data.Aeson hiding ((.=))
+import Data.Functor.Identity (runIdentity)
import Data.HashMap.Strict (insert)
+import qualified Data.Set as S
import Data.Time
import Network.URI (parseURI)
import Safe (headMay)
import Test.Hspec
-import Crypto.JOSE
import Crypto.JWT
intDate :: String -> Maybe NumericDate
intDate = fmap NumericDate . parseTimeM True defaultTimeLocale "%F %T"
+utcTime :: String -> UTCTime
+utcTime = fromJust . parseTimeM True defaultTimeLocale "%F %T"
+
exampleClaimsSet :: ClaimsSet
exampleClaimsSet = emptyClaimsSet
- & claimIss .~ Just (fromString "joe")
+ & claimIss .~ preview stringOrUri ("joe" :: String)
& claimExp .~ intDate "2011-03-22 18:43:00"
& over unregisteredClaims (insert "http://example.com/is_root" (Bool True))
& addClaim "http://example.com/is_root" (Bool True)
+instance Monad m => MonadTime (ReaderT UTCTime m) where
+ currentTime = ask
+
spec :: Spec
spec = do
+ let conf = set algorithms (S.singleton None)
+ (defaultJWTValidationSettings (const False))
+
describe "JWT Claims Set" $ do
it "parses from JSON correctly" $
let
@@ -56,10 +72,192 @@ spec = do
it "formats to a parsable and equal value" $
decode (encode exampleClaimsSet) `shouldBe` Just exampleClaimsSet
+ describe "with an Expiration Time claim" $ do
+ describe "when the current time is prior to the Expiration Time" $ do
+ let now = utcTime "2010-01-01 00:00:00"
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf exampleClaimsSet) now
+ `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)
+
+ describe "when the current time is exactly the Expiration Time" $ do
+ let now = utcTime "2011-03-22 18:43:00"
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf exampleClaimsSet) now
+ `shouldBe` Left JWTExpired
+
+ describe "when the current time is after the Expiration Time" $ do
+ let now = utcTime "2011-03-22 18:43:01" -- 1s after expiry
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf exampleClaimsSet) now
+ `shouldBe` Left JWTExpired
+ it "cannot be validated if nonzero skew tolerance < delta" $
+ let conf' = set allowedSkew 1 conf
+ in runReaderT (validateClaimsSet conf' exampleClaimsSet) now
+ `shouldBe` Left JWTExpired
+ it "can be validated if nonzero skew tolerance = delta" $
+ let conf' = set allowedSkew 2 conf
+ in runReaderT (validateClaimsSet conf' exampleClaimsSet) now
+ `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)
+ it "can be validated if nonzero skew tolerance > delta" $
+ let conf' = set allowedSkew 3 conf
+ in runReaderT (validateClaimsSet conf' exampleClaimsSet) now
+ `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)
+ it "can be validated if negative skew tolerance = -delta" $
+ let conf' = set allowedSkew (-2) conf
+ in runReaderT (validateClaimsSet conf' exampleClaimsSet) now
+ `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)
+
+ describe "with an Issued At claim" $ do
+ let claimsSetWithIat = set claimIat (intDate "2011-02-22 18:43:00") emptyClaimsSet
+
+ describe "when the current time is after to the Issued At" $ do
+ let now = utcTime "2011-03-01 00:00:00"
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf claimsSetWithIat) now
+ `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet)
+
+ describe "when the current time is exactly the Issued At" $ do
+ let now = utcTime "2011-02-22 18:43:00"
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf claimsSetWithIat) now
+ `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet)
+
+ describe "when the current time is prior to the Issued At" $ do
+ let now = utcTime "2011-02-22 18:42:59" -- 1s before issued at
+ it "cannot be validated if nonzero skew tolerance < delta" $
+ let conf' = set allowedSkew 0 conf
+ in runReaderT (validateClaimsSet conf' claimsSetWithIat) now
+ `shouldBe` Left JWTIssuedAtFuture
+ it "can be validated if nonzero skew tolerance < delta but validation is off" $
+ let conf' = set checkIssuedAt False conf
+ in runReaderT (validateClaimsSet conf' claimsSetWithIat) now
+ `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet)
+ it "can be validated if nonzero skew tolerance = delta" $
+ let conf' = set allowedSkew 1 conf
+ in runReaderT (validateClaimsSet conf' claimsSetWithIat) now
+ `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet)
+ it "can be validated if nonzero skew tolerance > delta" $
+ let conf' = set allowedSkew 2 conf
+ in runReaderT (validateClaimsSet conf' claimsSetWithIat) now
+ `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet)
+ it "can be validated if negative skew tolerance = -delta" $
+ let conf' = set allowedSkew (-1) conf
+ in runReaderT (validateClaimsSet conf' claimsSetWithIat) now
+ `shouldBe` (Right claimsSetWithIat :: Either JWTError ClaimsSet)
+
+ describe "with a Not Before claim" $ do
+ let
+ claimsSet = emptyClaimsSet & claimNbf .~ intDate "2016-07-05 17:37:22"
+ describe "when the current time is prior to the Not Before claim" $ do
+ let now = utcTime "2016-07-05 17:37:20" -- 2s before nbf
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf claimsSet) now
+ `shouldBe` Left JWTNotYetValid
+ it "cannot be validated if nonzero skew tolerance < delta" $
+ let conf' = set allowedSkew 1 conf
+ in runReaderT (validateClaimsSet conf' claimsSet) now
+ `shouldBe` Left JWTNotYetValid
+ it "can be validated if nonzero skew tolerance = delta" $
+ let conf' = set allowedSkew 2 conf
+ in runReaderT (validateClaimsSet conf' claimsSet) now
+ `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)
+ it "can be validated if nonzero skew tolerance > delta" $
+ let conf' = set allowedSkew 3 conf
+ in runReaderT (validateClaimsSet conf' claimsSet) now
+ `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)
+ it "can be validated if negative skew tolerance = -delta" $
+ let conf' = set allowedSkew (-2) conf
+ in runReaderT (validateClaimsSet conf' claimsSet) now
+ `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)
+
+ describe "when the current time is exactly equal to the Not Before claim" $
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf claimsSet) (utcTime "2016-07-05 17:37:22")
+ `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)
+
+ describe "when the current time is after the Not Before claim" $
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf claimsSet) (utcTime "2017-01-01 00:00:00")
+ `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)
+
+ describe "with Expiration Time and Not Before claims" $ do
+ let
+ claimsSet = emptyClaimsSet & claimExp .~ intDate "2011-03-22 18:43:00"
+ & claimNbf .~ intDate "2011-03-20 17:37:22"
+ describe "when the current time is prior to the Not Before claim" $
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-18 00:00:00")
+ `shouldBe` Left JWTNotYetValid
+ describe "when the current time is exactly equal to the Not Before claim" $
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-20 17:37:22")
+ `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)
+ describe "when the current time is between the Not Before and Expiration Time claims" $
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-21 18:00:00")
+ `shouldBe` (Right claimsSet :: Either JWTError ClaimsSet)
+ describe "when the current time is exactly the Expiration Time" $
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-22 18:43:00")
+ `shouldBe` Left JWTExpired
+ describe "when the current time is after the Expiration Time claim" $
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-24 00:00:00")
+ `shouldBe` Left JWTExpired
+
+ describe "with an Audience claim" $ do
+ let now = utcTime "2001-01-01 00:00:00"
+ let conf' = set audiencePredicate (== "baz") conf
+ let conf'' = set audiencePredicate (const True) conf
+ describe "when claim is nonempty, and default predicate is used" $ do
+ let claims = emptyClaimsSet & set claimAud (Just (Audience ["foo"]))
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf claims) now
+ `shouldBe` Left JWTNotInAudience
+ describe "when claim is nonempty but predicate does not match any value" $ do
+ let claims = emptyClaimsSet & set claimAud (Just (Audience ["foo", "bar"]))
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf' claims) now
+ `shouldBe` Left JWTNotInAudience
+ describe "when claim is nonempty and predicate matches a value" $ do
+ let claims = emptyClaimsSet & set claimAud (Just (Audience ["foo", "bar", "baz"]))
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf' claims) now
+ `shouldBe` (Right claims :: Either JWTError ClaimsSet)
+ describe "when claim is empty, and predicate is unconditionally true" $ do
+ let claims = emptyClaimsSet & set claimAud (Just (Audience []))
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf'' claims) now
+ `shouldBe` Left JWTNotInAudience
+
+ describe "when claim has one value" $ do
+ let claims = emptyClaimsSet & set claimAud (Just (Audience ["foo"]))
+ it "serialises to string" $ encode claims `shouldBe` "{\"aud\":\"foo\"}"
+ it "round trips" $ decode (encode claims) `shouldBe` Just claims
+
+ describe "with an Issuer claim" $ do
+ let now = utcTime "2001-01-01 00:00:00"
+ let conf' = set issuerPredicate (== "baz") conf
+ describe "when issuer is nonempty, and predicate is matched" $ do
+ let claims = emptyClaimsSet & set claimIss (Just "baz")
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf' claims) now
+ `shouldBe` (Right claims :: Either JWTError ClaimsSet)
+ describe "when issuer is nonempty but predicate is not matched" $ do
+ let claims = emptyClaimsSet & set claimIss (Just "bar")
+ it "cannot be validated" $
+ runReaderT (validateClaimsSet conf' claims) now
+ `shouldBe` Left JWTNotInIssuer
+ describe "when claim is empty, and default predicate is unconditionally true" $ do
+ let claims = emptyClaimsSet & set claimIss (Just "")
+ it "can be validated" $
+ runReaderT (validateClaimsSet conf claims) now
+ `shouldBe` (Right claims :: Either JWTError ClaimsSet)
+
describe "StringOrURI" $
it "parses from JSON correctly" $ do
- (decode "[\"foo\"]" >>= headMay >>= getString) `shouldBe` Just "foo"
- (decode "[\"http://example.com\"]" >>= headMay >>= getURI)
+ (decode "[\"foo\"]" >>= headMay >>= preview string) `shouldBe` Just "foo"
+ (decode "[\"http://example.com\"]" >>= headMay >>= preview uri)
`shouldBe` parseURI "http://example.com"
decode "[\":\"]" `shouldBe` (Nothing :: Maybe [StringOrURI])
decode "[12345]" `shouldBe` (Nothing :: Maybe [StringOrURI])
@@ -70,17 +268,29 @@ spec = do
decode "[1382245921]" `shouldBe` fmap (:[]) (intDate "2013-10-20 05:12:01")
decode "[\"notnum\"]" `shouldBe` (Nothing :: Maybe [NumericDate])
- describe "§6.1. Example Unsecured JWT" $
- it "can be decoded and validated" $
- let
- exampleJWT = "eyJhbGciOiJub25lIn0\
- \.\
- \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\
- \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ\
- \."
- jwt = decodeCompact exampleJWT
- k = fromJust $ decode "{\"kty\":\"oct\",\"k\":\"\"}"
- in do
- fmap jwtClaimsSet jwt `shouldBe` Right exampleClaimsSet
- fmap (validateJWSJWT algs def k) jwt `shouldBe` Right True
- where algs = ValidationAlgorithms [None]
+ describe "RFC 7519 §6.1. Example Unsecured JWT" $ do
+ let
+ exampleJWT = "eyJhbGciOiJub25lIn0\
+ \.\
+ \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\
+ \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ\
+ \."
+ jwt = decodeCompact exampleJWT
+ k = fromJust $ decode "{\"kty\":\"oct\",\"k\":\"\"}" :: JWK
+
+ describe "when the current time is prior to the Expiration Time" $
+ it "can be decoded and validated" $ do
+ runReaderT (jwt >>= verifyClaims conf k) (utcTime "2010-01-01 00:00:00")
+ `shouldBe` (Right exampleClaimsSet :: Either JWTError ClaimsSet)
+
+ describe "when the current time is after the Expiration Time" $
+ it "can be decoded, but not validated" $ do
+ runReaderT (jwt >>= verifyClaims conf k) (utcTime "2012-01-01 00:00:00")
+ `shouldBe` Left JWTExpired
+
+ describe "when signature is invalid and token is expired" $
+ it "fails on sig validation (claim validation not reached)" $ do
+ let jwt' = decodeCompact (exampleJWT <> "badsig")
+ (runReaderT (jwt' >>= verifyClaims conf k) (utcTime "2012-01-01 00:00:00")
+ :: Either JWTError ClaimsSet)
+ `shouldSatisfy` is (_Left . _JWSInvalidSignature)
diff --git a/test/Properties.hs b/test/Properties.hs
index f8bcf6d..4833dd3 100644
--- a/test/Properties.hs
+++ b/test/Properties.hs
@@ -1,4 +1,4 @@
--- Copyright (C) 2015 Fraser Tweedale
+-- Copyright (C) 2015, 2016 Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -17,16 +17,17 @@
module Properties where
import Control.Applicative
+import Control.Monad.Except (runExceptT)
import Data.Aeson
import qualified Data.ByteString as B
-import Data.Default.Class
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.QuickCheck.Monadic
import Test.QuickCheck.Instances ()
+import Crypto.JOSE.Error (Error(..))
import Crypto.JOSE.Types
import Crypto.JOSE.JWK
import Crypto.JOSE.JWS
@@ -35,9 +36,8 @@ properties = testGroup "Properties"
[ testProperty "SizedBase64Integer round-trip"
(prop_roundTrip :: SizedBase64Integer -> Bool)
, testProperty "JWK round-trip" (prop_roundTrip :: JWK -> Bool)
- , testProperty "ECDSA gen, sign and verify" prop_ecSignAndVerify
- , testProperty "HMAC gen, sign and verify" prop_hmacSignAndVerify
, testProperty "RSA gen, sign and verify" prop_rsaSignAndVerify
+ , testProperty "gen, sign with best alg, verify" prop_bestJWSAlg
]
prop_roundTrip :: (Eq a, ToJSON a, FromJSON a) => a -> Bool
@@ -54,32 +54,29 @@ debugRoundTrip f = monadicIO $ do
"JSON: \n" ++ show encoded ++ "\n\nDecoded: \n" ++ show (decode encoded :: Maybe [a])
assert $ f a
-prop_ecSignAndVerify :: Crv -> B.ByteString -> Property
-prop_ecSignAndVerify crv msg = monadicIO $ do
- k :: JWK <- run $ genJWK (ECGenParam crv)
- let alg = case crv of P_256 -> ES256 ; P_384 -> ES384 ; P_521 -> ES512
- wp (signJWS (newJWS msg) (newJWSHeader alg) k) (checkSignJWS k)
-
-prop_hmacSignAndVerify :: B.ByteString -> Property
-prop_hmacSignAndVerify msg = monadicIO $ do
- (alg, minLen) <-
- pick $ oneof $ pure <$> [(HS256, 32), (HS384, 48), (HS512, 64)]
- keylen <- (+ minLen) <$> pick arbitrarySizedNatural
- k :: JWK <- run $ genJWK (OctGenParam keylen)
- wp (signJWS (newJWS msg) (newJWSHeader alg) k) (checkSignJWS k)
-
prop_rsaSignAndVerify :: B.ByteString -> Property
prop_rsaSignAndVerify msg = monadicIO $ do
- keylen <- pick $ oneof $ pure . (`div` 8) <$> [2048, 3072, 4096]
+ keylen <- pick $ elements ((`div` 8) <$> [2048, 3072, 4096])
k :: JWK <- run $ genJWK (RSAGenParam keylen)
- alg <- pick $ oneof $ pure <$> [RS256, RS384, RS512, PS256, PS384, PS512]
- wp (signJWS (newJWS msg) (newJWSHeader alg) k) (checkSignJWS k)
+ alg <- pick $ elements [RS256, RS384, RS512, PS256, PS384, PS512]
+ monitor (collect alg)
+ wp (runExceptT (signJWS msg [(newJWSHeader (Protected, alg), k)]
+ >>= verifyJWS defaultValidationSettings k)) (checkSignVerifyResult msg)
+
+prop_bestJWSAlg :: B.ByteString -> Property
+prop_bestJWSAlg msg = monadicIO $ do
+ genParam <- pick arbitrary
+ k <- run $ genJWK genParam
+ case bestJWSAlg k of
+ Left (KeyMismatch _) -> pre False -- skip non-signing keys
+ Left _ -> assert False
+ Right alg -> do
+ monitor (collect alg)
+ let
+ go = do
+ jws <- signJWS msg [(newJWSHeader (Protected, alg), k)]
+ verifyJWS defaultValidationSettings k jws
+ wp (runExceptT go) (checkSignVerifyResult msg)
-checkSignJWS :: (Monad m, Show e) => JWK -> Either e JWS -> PropertyM m ()
-checkSignJWS k signResult = case signResult of
- Left e -> do
- monitor (counterexample $ "Failed to sign: " ++ show e)
- assert False
- Right jws -> do
- monitor (counterexample "Failed to verify")
- assert (verifyJWS def def k jws)
+checkSignVerifyResult :: Monad m => B.ByteString -> Either Error B.ByteString -> PropertyM m ()
+checkSignVerifyResult msg = assert . either (const False) (== msg)