jose 0.4.0.4 → 0.5.0.0

raw patch · 21 files changed

+1231/−607 lines, 21 filesdep +containersdep +josedep +monad-timedep −data-default-classdep ~aesondep ~basedep ~bifunctorsnew-component:exe:example

Dependencies added: containers, jose, monad-time

Dependencies removed: data-default-class

Dependency ranges changed: aeson, base, bifunctors, bytestring, lens, mtl, semigroups, template-haskell

Files

• example/Main.hs +73/−0
• jose.cabal +33/−9
• src/Crypto/JOSE/Compact.hs +6/−5
• src/Crypto/JOSE/Error.hs +25/−3
• src/Crypto/JOSE/Header.hs +157/−0
• src/Crypto/JOSE/JWA/JWE.hs +0/−1
• src/Crypto/JOSE/JWA/JWK.hs +53/−31
• src/Crypto/JOSE/JWE.hs +83/−96
• src/Crypto/JOSE/JWK.hs +52/−5
• src/Crypto/JOSE/JWS.hs +14/−2
• src/Crypto/JOSE/JWS/Internal.hs +204/−199
• src/Crypto/JOSE/Legacy.hs +0/−2
• src/Crypto/JOSE/TH.hs +2/−3
• src/Crypto/JOSE/Types.hs +0/−2
• src/Crypto/JOSE/Types/Armour.hs +0/−89
• src/Crypto/JOSE/Types/Internal.hs +57/−6
• src/Crypto/JOSE/Types/Orphans.hs +7/−8
• src/Crypto/JWT.hs +162/−29
• test/JWS.hs +113/−71
• test/JWT.hs +165/−17
• test/Properties.hs +25/−29

@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++import System.Environment (getArgs)+import System.Exit (exitFailure, exitSuccess)++import qualified Data.ByteString.Lazy as L+import Data.Aeson (decode, encode)++import Control.Monad.Except (runExceptT)+import Crypto.JOSE.JWK (KeyMaterialGenParam(..), Crv(..), genJWK, bestJWSAlg)+import Crypto.JWT+  ( createJWSJWT, validateJWSJWT+  , defaultJWTValidationSettings, JWTError)+import Crypto.JOSE.Compact (decodeCompact, encodeCompact)+import Crypto.JOSE.JWS (Protection(Protected), newJWSHeader)++import Crypto.JOSE.Error (Error)++main :: IO ()+main = do+  args <- getArgs+  case head args of+    "jwk-gen" -> doGen (tail args)+    "jwt-sign" -> doJwtSign (tail args)+    "jwt-verify" -> doJwtVerify (tail args)++doGen :: [String] -> IO ()+doGen [kty] = do+  let+    param = case kty of+      "oct" -> OctGenParam 32+      "rsa" -> RSAGenParam 256+      "ec" -> ECGenParam P_256+  jwk <- genJWK param+  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+    let header = newJWSHeader (Protected, alg)+    createJWSJWT jwk header claims >>= encodeCompact+  case result of+    Left e -> print (e :: Error) >> exitFailure+    Right jwtData -> L.putStr jwtData+++-- | Validate a JWT.  Args are:+--+-- 1. filename of JWK+-- 2. filename of a claims object+--+-- Exit code indicates validity.+--+doJwtVerify :: [String] -> IO ()+doJwtVerify [jwkFilename, jwtFilename] = do+  Just jwk <- decode <$> L.readFile jwkFilename+  jwtData <- L.readFile jwtFilename+  result <- runExceptT (+    decodeCompact jwtData+    >>= validateJWSJWT defaultJWTValidationSettings jwk)+  case result of+    Left e -> print (e :: JWTError) >> exitFailure+    Right _ -> exitSuccess

@@ -1,5 +1,5 @@ name:                jose-version:             0.4.0.4+version:             0.5.0.0 synopsis:   Javascript Object Signing and Encryption and JSON Web Token library description:@@ -38,6 +38,7 @@     Crypto.JOSE     Crypto.JOSE.Compact     Crypto.JOSE.Error+    Crypto.JOSE.Header     Crypto.JOSE.JWE     Crypto.JOSE.JWK     Crypto.JOSE.JWS@@ -53,7 +54,6 @@     Crypto.JOSE.JWA.JWE.Alg     Crypto.JOSE.JWS.Internal     Crypto.JOSE.TH-    Crypto.JOSE.Types.Armour     Crypto.JOSE.Types.Internal     Crypto.JOSE.Types.Orphans @@ -61,16 +61,15 @@     base == 4.*     , attoparsec     , base64-bytestring == 1.0.*-    , bifunctors >= 4.0     , byteable == 0.1.*+    , containers >= 0.5     , cryptonite >= 0.7-    , data-default-class     , lens >= 4.3     , memory >= 0.7+    , monad-time >= 0.1     , mtl >= 2     , template-haskell >= 2.4     , safe >= 0.3-    , semigroups >= 0.15     , aeson >= 0.8.0.1     , unordered-containers == 0.2.*     , bytestring == 0.10.*@@ -82,7 +81,14 @@     , x509 >= 1.4     , vector -  ghc-options:    -Wall+  if impl(ghc < 7.10)+    build-depends:+        bifunctors >= 4.0+  if impl(ghc < 8)+    build-depends:+        semigroups >= 0.15++  ghc-options:    -Wall -O2   hs-source-dirs: src  source-repository head@@ -105,16 +111,15 @@     base     , attoparsec     , base64-bytestring-    , bifunctors     , byteable+    , containers     , cryptonite-    , data-default-class     , lens     , memory+    , monad-time     , mtl     , template-haskell     , safe-    , semigroups     , aeson     , unordered-containers     , bytestring@@ -130,3 +135,22 @@     , hspec     , QuickCheck     , quickcheck-instances++  if impl(ghc < 7.10)+    build-depends:+        bifunctors >= 4.0+  if impl(ghc < 8)+    build-depends:+        semigroups >= 0.15++executable example+  hs-source-dirs: example+  main-is:  Main.hs+  ghc-options:    -Wall+  build-depends:+    base+    , aeson+    , bytestring+    , lens+    , mtl+    , jose

@@ -23,28 +23,29 @@ -} 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 :: (AsError e, MonadError e m) => a -> m [L.ByteString]  -- | Encode data to a compact representation. ---encodeCompact :: ToCompact a => a -> Either Error L.ByteString+encodeCompact :: (ToCompact a, AsError e, MonadError e m) => a -> m L.ByteString encodeCompact = fmap (L.intercalate ".") . toCompact

@@ -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 @@ 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. --@@ -38,8 +47,21 @@   | 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   deriving (Eq, Show)+makeClassyPrisms ''Error+++instance (+    MonadRandom m+  , MonadTrans t+  , Functor (t m)+  , Monad (t m)+  ) => MonadRandom (t m) where+    getRandomBytes = lift . getRandomBytes

@@ -0,0 +1,157 @@+-- Copyright (C) 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 ScopedTypeVariables #-}++{-|++Types and functions for working with JOSE header parameters.++-}+module Crypto.JOSE.Header+  (+    HasParams(..)+  , parseParams+  , protectedParamsEncoded+  , unprotectedParams++  , parseCrit++  , Protection(..)+  , HeaderParam(..)+  , protection+  , param+  , headerRequired+  , headerOptional+  , headerOptionalProtected+  ) where+++import Data.Proxy (Proxy(..))++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 Crypto.JOSE.Types.Orphans ()+import Crypto.JOSE.Types.Internal (unpad)+++class HasParams a where+  params :: a -> [(Protection, Pair)]++  extensions :: Proxy a -> [T.Text]+  extensions = const []++  parseParamsFor :: HasParams b => Proxy b -> Maybe Object -> Maybe Object -> Parser a++parseParams :: forall a. HasParams a => Maybe Object -> Maybe Object -> Parser a+parseParams = parseParamsFor (Proxy :: Proxy a)++protectedParams :: HasParams a => a -> Maybe Value {- ^ Object -}+protectedParams h =+  case (map snd . filter ((== Protected) . fst) . params) h of+    [] -> Nothing+    xs -> Just (object xs)++protectedParamsEncoded :: HasParams a => a -> L.ByteString+protectedParamsEncoded =+  maybe mempty (unpad . B64UL.encode . encode) . protectedParams++unprotectedParams :: HasParams a => a -> Maybe Value {- ^ Object -}+unprotectedParams h =+  case (map snd . filter ((== Unprotected) . fst) . params) h of+    [] -> Nothing+    xs -> Just (object xs)+++data Protection = Protected | Unprotected+  deriving (Eq, Show)++data HeaderParam a = HeaderParam Protection a+  deriving (Eq, Show)++protection :: HeaderParam a -> Protection+protection (HeaderParam b _) = b++param :: HeaderParam a -> a+param (HeaderParam _ a) = a+++-- | Parse an optional parameter that may be carried in either+-- the protected or the unprotected header.+--+headerOptional+  :: FromJSON a+  => T.Text+  -> Maybe Object+  -> Maybe Object+  -> Parser (Maybe (HeaderParam a))+headerOptional k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of+  (Just _, Just _)    -> fail $ "duplicate header " ++ show k+  (Just v, Nothing)   -> Just . HeaderParam Protected <$> parseJSON v+  (Nothing, Just v)   -> Just . HeaderParam Unprotected <$> parseJSON v+  (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 _) -> 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+  => T.Text+  -> Maybe Object+  -> Maybe Object+  -> Parser (HeaderParam a)+headerRequired k hp hu = case (hp >>= M.lookup k, hu >>= M.lookup k) of+  (Just _, Just _)    -> fail $ "duplicate header " ++ show k+  (Just v, Nothing)   -> HeaderParam Protected <$> parseJSON v+  (Nothing, Just v)   -> HeaderParam Unprotected <$> parseJSON v+  (Nothing, Nothing)  -> fail $ "missing required 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++parseCrit+  :: (Foldable t0, Foldable t1, Traversable t2, Traversable t3, Monad m)+  => t0 T.Text+  -> t1 T.Text+  -> Object+  -> t2 (t3 T.Text)+  -> m (t2 (t3 T.Text))+parseCrit reserved exts o = mapM (mapM (critObjectParser reserved exts o))+  -- TODO fail on duplicate strings

@@ -22,7 +22,6 @@ -} module Crypto.JOSE.JWA.JWE where -import Control.Applicative import Data.Maybe (catMaybes)  import qualified Data.HashMap.Strict as M

@@ -43,6 +43,7 @@   , RSAPrivateKeyOptionalParameters(..)   , RSAPrivateKeyParameters(..)   , RSAKeyParameters(RSAKeyParameters)+  , toRSAKeyParameters   , rsaE   , rsaKty   , rsaN@@ -53,9 +54,12 @@   -- * Parameters for Symmetric Keys   , OctKeyParameters(..) +  -- * Key generation   , KeyMaterialGenParam(..)   , KeyMaterial(..)   , genKeyMaterial++  -- * Signing and verification   , sign   , verify @@ -63,10 +67,12 @@   ) where  import Control.Applicative+import Control.Monad.Except (MonadError(throwError)) import Data.Bifunctor import Data.Maybe+import Data.Monoid ((<>)) -import Control.Lens hiding ((.=))+import Control.Lens hiding ((.=), elements) import Crypto.Hash import Crypto.MAC.HMAC import qualified Crypto.PubKey.ECC.ECDSA as ECDSA@@ -81,7 +87,7 @@ import qualified Data.ByteString as B import qualified Data.HashMap.Strict as M import Data.List.NonEmpty-import Test.QuickCheck+import Test.QuickCheck (Arbitrary(..), arbitrarySizedNatural, elements, oneof)  import Crypto.JOSE.Error import qualified Crypto.JOSE.JWA.JWS as JWA.JWS@@ -238,20 +244,21 @@         ]  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)@@ -322,10 +329,12 @@     <*> 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 RSA     ( Types.SizedBase64Integer s n )     ( i e )     ( Just (RSAPrivateKeyParameters (i d)@@ -333,14 +342,15 @@         (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@@ -352,14 +362,15 @@ verifyPKCS15 h k m = Right . PKCS15.verify (Just h) (rsaPublicKey k) m  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)@@ -377,7 +388,7 @@   (Types.Base64Integer e)   (Just (RSAPrivateKeyParameters (Types.Base64Integer d) opt)))   | isJust (opt >>= rsaOth) = Left OtherPrimesNotSupported-  | n < 2 ^ (2040 :: Integer) = Left KeySizeTooSmall+  | size < 2048 `div` 8 = Left KeySizeTooSmall   | otherwise = Right $     RSA.PrivateKey (RSA.PublicKey size n e) d       (opt' rsaP) (opt' rsaQ) (opt' rsaDp) (opt' rsaDq) (opt' rsaQi)@@ -412,15 +423,15 @@   arbitrary = OctKeyParameters Oct <$> 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+  -> 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)   -- | Key material sum type.@@ -451,9 +462,20 @@ -- 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/.+  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])+    ]+ genKeyMaterial :: MonadRandom m => KeyMaterialGenParam -> m KeyMaterial genKeyMaterial (ECGenParam crv) = do   let@@ -469,12 +491,12 @@   OctKeyMaterial . OctKeyParameters Oct . Types.Base64Octets <$> getRandomBytes n  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,11 +506,11 @@ 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 h k = \_ -> throwError (review _AlgorithmMismatch+  (show h <> "cannot be used with " <> showKeyType k <> " key"))  verify   :: JWA.JWS.Alg

@@ -24,22 +24,18 @@   , 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 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 +48,11 @@  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 +63,110 @@ 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   { _jweAlg :: Maybe AlgWithParams-  , _jweEnc :: Maybe Enc+  , _jweEnc :: HeaderParam 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 Types.URI)+  , _jweJwk :: Maybe (HeaderParam JWK)+  , _jweKid :: Maybe (HeaderParam String)+  , _jweX5u :: Maybe (HeaderParam Types.URI)+  , _jweX5c :: Maybe (HeaderParam (NonEmpty Types.Base64X509))+  , _jweX5t :: Maybe (HeaderParam Types.Base64SHA1)+  , _jweX5tS256 :: Maybe (HeaderParam Types.Base64SHA256)+  , _jweTyp :: Maybe (HeaderParam String)  -- ^ Content Type (of object)+  , _jweCty :: Maybe (HeaderParam String)  -- ^ Content Type (of payload)+  , _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+newJWEHeader :: AlgWithParams -> Enc -> JWEHeader+newJWEHeader alg enc =+  JWEHeader (Just alg) (HeaderParam Unprotected enc) z z z z z z z z z z z+  where z = Nothing -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+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 (protection enc,      "enc" .= param enc)+      , fmap (\p -> (Protected,    "zip" .= p)) zip'+      , fmap (\p -> (protection p, "jku" .= param p)) jku+      , fmap (\p -> (protection p, "jwk" .= param p)) jwk+      , fmap (\p -> (protection p, "kid" .= param p)) kid+      , fmap (\p -> (protection p, "x5u" .= param p)) x5u+      , fmap (\p -> (protection p, "x5c" .= param p)) x5c+      , fmap (\p -> (protection p, "x5t" .= param p)) x5t+      , fmap (\p -> (protection p, "x5t#S256" .= param p)) x5tS256+      , fmap (\p -> (protection p, "typ" .= param p)) typ+      , fmap (\p -> (protection p, "cty" .= param p)) cty+      , fmap (\p -> (Protected,    "crit" .= p)) crit       ]-      ++ 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 = JWERecipient+  { _jweHeader :: a   , _jweEncryptedKey :: Maybe Types.Base64Octets  -- ^ JWE Encrypted Key   } -instance FromJSON JWERecipient where+instance FromJSON (JWERecipient a) 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 => Maybe Object -> Maybe Object -> Value -> Parser (JWERecipient a)+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 = 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]   } -instance FromJSON JWE where-  parseJSON =-    withObject "JWE JSON Serialization" $ \o -> JWE-      <$> o .:? "protected"-      <*> o .:? "unprotected"+instance HasParams a => FromJSON (JWE a) 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  

@@ -40,8 +40,14 @@   , fromKeyMaterial   , genJWK +  , fromRSA++  , JWKAlg(..)+   , JWKSet(..) +  , bestJWSAlg+   , module Crypto.JOSE.JWA.JWK   ) where @@ -49,11 +55,15 @@ import Data.Maybe (catMaybes)  import Control.Lens hiding ((.=))+import Control.Monad.Except (MonadError(throwError))+import qualified Crypto.PubKey.RSA as RSA import Data.Aeson+import qualified Data.ByteString as B import Data.List.NonEmpty  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,15 +72,20 @@ 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 @@ -95,7 +110,7 @@     _jwkMaterial :: Crypto.JOSE.JWA.JWK.KeyMaterial   , _jwkUse :: Maybe KeyUse   , _jwkKeyOps :: Maybe [KeyOp]-  , _jwkAlg :: Maybe Alg+  , _jwkAlg :: Maybe JWKAlg   , _jwkKid :: Maybe String   , _jwkX5u :: Maybe Types.URI   , _jwkX5c :: Maybe (NonEmpty Types.Base64X509)@@ -149,6 +164,12 @@ 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++ instance AsPublicKey JWK where   asPublicKey = prism' id (jwkMaterial (preview asPublicKey)) @@ -159,3 +180,29 @@  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 size _ = view rsaN k+    in+      if size >= 2048 `div` 8+      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 ())

@@ -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.@@ -23,18 +23,30 @@   (     Alg(..) +  , HasJWSHeader(..)   , JWSHeader(..)   , newJWSHeader +  , Signature+  , header+   , JWS(..)   , newJWS   , jwsPayload   , signJWS -  , ValidationAlgorithms(..)+  , HasValidationSettings(..)+  , HasAlgorithms(..)+  , HasValidationPolicy(..)+   , ValidationPolicy(..)+  , ValidationSettings+  , defaultValidationSettings   , verifyJWS++  , module Crypto.JOSE.Header   ) where  import Crypto.JOSE.JWA.JWS import Crypto.JOSE.JWS.Internal+import Crypto.JOSE.Header

@@ -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.@@ -12,47 +12,41 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} {-# 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.Applicative ((<|>))+import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid ((<>)) -import Control.Lens ((^.))+import Control.Lens hiding ((.=))+import Control.Monad.Except (MonadError(throwError)) 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.HashMap.Strict as M+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T-import 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 Crypto.JOSE.Header import qualified Crypto.JOSE.Types as Types import qualified Crypto.JOSE.Types.Internal as Types-import Crypto.JOSE.Types.Armour  -critInvalidNames :: [T.Text]-critInvalidNames = [+jwsCritInvalidNames :: [T.Text]+jwsCritInvalidNames = [   "alg"   , "jku"   , "jwk"@@ -66,162 +60,147 @@   , "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+  { _jwsHeaderAlg :: HeaderParam JWA.JWS.Alg+  , _jwsHeaderJku :: Maybe (HeaderParam Types.URI)  -- ^ JWK Set URL+  , _jwsHeaderJwk :: Maybe (HeaderParam JWK)+  , _jwsHeaderKid :: Maybe (HeaderParam String)  -- ^ interpretation unspecified+  , _jwsHeaderX5u :: Maybe (HeaderParam Types.URI)+  , _jwsHeaderX5c :: Maybe (HeaderParam (NonEmpty Types.Base64X509))+  , _jwsHeaderX5t :: Maybe (HeaderParam Types.Base64SHA1)+  , _jwsHeaderX5tS256 :: Maybe (HeaderParam Types.Base64SHA256)+  , _jwsHeaderTyp :: Maybe (HeaderParam String)  -- ^ Content Type (of object)+  , _jwsHeaderCty :: Maybe (HeaderParam String)  -- ^ Content Type (of payload)+  , _jwsHeaderCrit :: Maybe (NonEmpty T.Text)   }   deriving (Eq, Show)--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+makeClassy ''JWSHeader  -- | Construct a minimal header with the given algorithm ---newJWSHeader :: JWA.JWS.Alg -> JWSHeader-newJWSHeader alg = def { headerAlg = Just alg }+newJWSHeader :: (Protection, JWA.JWS.Alg) -> JWSHeader+newJWSHeader alg = JWSHeader (uncurry HeaderParam alg) z z z z z z z z z z+  where z = Nothing  -data Signature = Signature-  (Maybe (Armour T.Text JWSHeader))-  (Maybe JWSHeader)-  Types.Base64Octets-  deriving (Eq, Show)+data Signature a = Signature+  { _protectedRaw :: (Maybe T.Text)      -- ^ Encoded protected header, if available+  , _header :: a                      -- ^ Header+  , _signature :: Types.Base64Octets  -- ^ Signature+  }+  deriving (Show)+makeLenses ''Signature -algorithm :: Signature -> Maybe JWA.JWS.Alg-algorithm (Signature h h' _) = (h >>= headerAlg . (^. value)) <|> (h' >>= headerAlg)+instance (Eq a, HasParams a) => Eq (Signature a) where+  Signature r h s == Signature r' h' s' =+    h == h' && s == s' && f r r'+    where+    f Nothing Nothing = True+    f (Just t) (Just t') = t == t'+    f Nothing (Just t') = BSL.toStrict (protectedParamsEncoded h) == T.encodeUtf8 t'+    f (Just t) Nothing = T.encodeUtf8 t == BSL.toStrict (protectedParamsEncoded h') -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 HasParams a => FromJSON (Signature a) where+  parseJSON = withObject "signature" (\o -> Signature+    <$> (Just <$> (o .: "protected" <|> pure ""))  -- raw protected header+    <*> do+      hpB64 <- o .:? "protected"+      hp <- maybe+        (pure Nothing)+        (withText "base64url-encoded header params"+          (Types.parseB64Url (maybe+            (fail "protected header contains invalid JSON")+            pure . decode . BSL.fromStrict)))+        hpB64+      hu <- o .:? "header"+      parseParams hp hu+    <*> o .: "signature"+    ) -instance FromJSON Signature where-  parseJSON =-    withObject "signature" (\o -> Signature-      <$> o .:? "protected"-      <*> o .:? "header"-      <*> o .: "signature"-    ) >=> either (fail . show) pure . checkHeaders+instance HasParams a => ToJSON (Signature a) where+  toJSON (Signature _ h sig) =+    let+      pro = case protectedParamsEncoded h of+        "" -> id+        bs -> ("protected" .= String (T.decodeUtf8 (BSL.toStrict bs)) :)+      unp = case unprotectedParams h of+        Nothing -> id+        Just o -> ("header" .= o :)+    in+      object $ (pro . unp) [("signature" .= sig)] -instance ToJSON Signature where-  toJSON (Signature h h' s) =-    object $ ("signature" .= s) :-      maybe [] (Types.objectPairs . toJSON . (^. value)) h-      ++ maybe [] (Types.objectPairs . toJSON) h' +instance HasParams JWSHeader where+  parseParamsFor proxy hp hu = JWSHeader+    <$> headerRequired "alg" hp hu+    <*> headerOptional "jku" hp hu+    <*> headerOptional "jwk" hp hu+    <*> headerOptional "kid" hp hu+    <*> headerOptional "x5u" hp hu+    <*> headerOptional "x5t" hp hu+    <*> headerOptional "x5t#S256" hp hu+    <*> headerOptional "x5c" hp hu+    <*> headerOptional "typ" hp hu+    <*> headerOptional "cty" hp hu+    <*> (headerOptionalProtected "crit" hp hu+      >>= parseCrit jwsCritInvalidNames (extensions proxy)+        (fromMaybe mempty hp <> fromMaybe mempty hu))+  params (JWSHeader alg jku jwk kid x5u x5c x5t x5tS256 typ cty crit) =+    catMaybes+      [ Just (protection alg,      "alg" .= param alg)+      , fmap (\p -> (protection p, "jku" .= param p)) jku+      , fmap (\p -> (protection p, "jwk" .= param p)) jwk+      , fmap (\p -> (protection p, "kid" .= param p)) kid+      , fmap (\p -> (protection p, "x5u" .= param p)) x5u+      , fmap (\p -> (protection p, "x5c" .= param p)) x5c+      , fmap (\p -> (protection p, "x5t" .= param p)) x5t+      , fmap (\p -> (protection p, "x5t#S256" .= param p)) x5tS256+      , fmap (\p -> (protection p, "typ" .= param p)) typ+      , fmap (\p -> (protection p, "cty" .= param p)) cty+      , fmap (\p -> (Protected,    "crit" .= p)) crit+      ] + -- | JSON Web Signature data type.  Consists of a payload and a -- (possibly empty) list of signatures. ---data JWS = JWS Types.Base64Octets [Signature]+-- Parameterised by the header type.+--+data JWS a = JWS Types.Base64Octets [Signature a]   deriving (Eq, Show) -instance FromJSON JWS where+instance HasParams a => FromJSON (JWS a) where   parseJSON v =     withObject "JWS JSON serialization" (\o -> JWS       <$> o .: "payload"       <*> o .: "signatures") v     <|> withObject "Flattened JWS JSON serialization" (\o ->-      if member "signatures" o+      if M.member "signatures" o       then fail "\"signatures\" member MUST NOT be present"       else (\p s -> JWS p [s]) <$> o .: "payload" <*> parseJSON v) v -instance ToJSON JWS where+instance HasParams a => ToJSON (JWS a) where   toJSON (JWS p ss) = object ["payload" .= p, "signatures" .= ss]  -- | Construct a new (unsigned) JWS ---newJWS :: BS.ByteString -> JWS+newJWS :: BS.ByteString -> JWS a newJWS msg = JWS (Types.Base64Octets msg) []  -- | Payload of a JWS, as a lazy bytestring. ---jwsPayload :: JWS -> BSL.ByteString+jwsPayload :: JWS a -> BSL.ByteString jwsPayload (JWS (Types.Base64Octets s) _) = BSL.fromStrict s -signingInput :: Maybe (Armour T.Text JWSHeader) -> Types.Base64Octets -> BS.ByteString+signingInput+  :: HasParams a+  => Either T.Text a+  -> Types.Base64Octets+  -> BS.ByteString signingInput h p = BS.intercalate "."-  [ maybe "" (T.encodeUtf8 . (^. armour)) h+  [ either T.encodeUtf8 (BSL.toStrict . protectedParamsEncoded) h   , toBytes p   ] @@ -230,27 +209,31 @@ -- 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 HasParams a => ToCompact (JWS a) where+  toCompact (JWS p [Signature raw h sig]) =+    case unprotectedParams h of+      Nothing -> pure+        [ BSL.fromStrict $ signingInput (maybe (Right h) Left raw) p+        , BSL.fromStrict $ toBytes sig+        ]+      Just _ -> throwError $ review _CompactEncodeError $+        "cannot encode a compact JWS with unprotected headers"+  toCompact (JWS _ sigs) = throwError $ review _CompactEncodeError $+    "cannot compact serialize JWS with " ++ show (length sigs) ++ " sigs" -instance FromCompact JWS where+instance HasParams a => FromCompact (JWS a) 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')+      (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 s = CompactDecodeError . ((s ++ " decode failed: ") ++)-      decodeS desc s =-        first (compactErr desc)-          (A.eitherResult $ A.parse P.value $ BSL.intercalate s ["\"", "\""])-        >>= first JSONDecodeError . parseEither parseJSON+      compactErr = review _CompactDecodeError+      t = either (throwError . compactErr . show) (pure . String)+        . T.decodeUtf8' . BSL.toStrict   -- §5.1. Message Signing or MACing@@ -258,44 +241,53 @@ -- | Create a new signature on a JWS. -- signJWS-  :: MonadRandom m-  => JWS      -- ^ JWS to sign-  -> JWSHeader  -- ^ Header for signature+  :: (HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m)+  => JWS a    -- ^ JWS to sign+  -> a        -- ^ Header for signature   -> JWK      -- ^ Key with which to sign-  -> m (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+  -> m (JWS a) -- ^ JWS with new signature appended+signJWS (JWS p sigs) h k =+  (\sig -> JWS p (Signature Nothing h (Types.Base64Octets sig):sigs))+  <$> sign (param (view jwsHeaderAlg h)) (k ^. jwkMaterial) (signingInput (Right h) p)  --- | 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'.+-- | Validation policy. -- data ValidationPolicy   = AnyValidated   -- ^ One successfully validated signature is sufficient   | AllValidated-  -- ^ All signatures for which validation is attempted must be validated+  -- ^ All signatures in all configured algorithms must be validated.+  -- No signatures in configured algorithms is also an error.+  deriving (Eq) -instance Default ValidationPolicy where-  def = AllValidated+data ValidationSettings = ValidationSettings+  { _validationSettingsAlgorithms :: S.Set JWA.JWS.Alg+  , _validationSettingsValidationPolicy :: ValidationPolicy+  }+makeClassy ''ValidationSettings +class HasAlgorithms s where+  algorithms :: Lens' s (S.Set JWA.JWS.Alg)+class HasValidationPolicy s where+  validationPolicy :: Lens' s ValidationPolicy +instance HasValidationSettings a => HasAlgorithms a where+  algorithms = validationSettingsAlgorithms+instance HasValidationSettings a => HasValidationPolicy a where+  validationPolicy = validationSettingsValidationPolicy++defaultValidationSettings :: ValidationSettings+defaultValidationSettings = ValidationSettings+  ( S.fromList+    [ JWA.JWS.HS256, JWA.JWS.HS384, JWA.JWS.HS512+    , JWA.JWS.RS256, JWA.JWS.RS384, JWA.JWS.RS512+    , JWA.JWS.ES256, JWA.JWS.ES384, JWA.JWS.ES512+    , JWA.JWS.PS256, JWA.JWS.PS384, JWA.JWS.PS512+    ] )+  AllValidated++ -- | Verify a JWS. -- -- Verification succeeds if any signature on the JWS is successfully@@ -307,22 +299,35 @@ -- prior to calling 'verifyJWS'. -- verifyJWS-  :: ValidationAlgorithms-  -> ValidationPolicy+  ::  ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m+      , HasJWSHeader h, HasParams h)+  => a   -> 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+  -> JWS h+  -> m ()+verifyJWS conf k (JWS p sigs) =+  let+    algs :: S.Set JWA.JWS.Alg+    algs = conf ^. algorithms+    policy :: ValidationPolicy+    policy = conf ^. validationPolicy+    shouldValidateSig = (`elem` algs) . param . view (header . jwsHeaderAlg)+    applyPolicy AnyValidated xs =+      if or xs then pure () else throwError (review _JWSNoValidSignatures ())+    applyPolicy AllValidated [] = throwError (review _JWSNoSignatures ())+    applyPolicy AllValidated xs =+      if and xs then pure () else throwError (review _JWSInvalidSignature ())+    validate = (== Right True) . verifySig k p+  in+    applyPolicy policy $ map validate $ filter shouldValidateSig sigs -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)+verifySig+  :: (HasJWSHeader a, HasParams a)+  => JWK+  -> Types.Base64Octets+  -> Signature a+  -> Either Error Bool+verifySig k m (Signature raw h (Types.Base64Octets s)) =+  verify (param (view jwsHeaderAlg h)) (view jwkMaterial k) tbs s+  where+  tbs = signingInput (maybe (Right h) Left raw) m

@@ -31,8 +31,6 @@   , RSKeyParameters()   ) where -import Control.Applicative- import Control.Lens hiding ((.=)) import Crypto.Number.Basic (log2) import Data.Aeson

@@ -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 @@     deriveJOSEType   ) where -import Control.Applicative import Data.Aeson import Data.Char import Language.Haskell.TH.Lib@@ -99,7 +98,7 @@   -> 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

@@ -34,8 +34,6 @@   , URI   ) where -import Control.Applicative- import Control.Lens import Data.Aeson import Data.Aeson.Types (Parser)

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

@@ -21,10 +21,15 @@ -} module Crypto.JOSE.Types.Internal where +import Data.Char (ord)+import Data.Monoid ((<>)) import Data.Tuple (swap)+import Data.Word (Word8) +import Control.Lens 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 +45,7 @@  -- | 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,19 +55,65 @@ 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 #-}+ -- | Produce a parser of base64url encoded text from a bytestring parser. ---parseB64Url :: FromJSON a => (B.ByteString -> Parser a) -> T.Text -> Parser a+parseB64Url :: (B.ByteString -> Parser a) -> T.Text -> Parser a parseB64Url f = either fail f . B64U.decode . pad . E.encodeUtf8  -- | Convert a bytestring to a base64url encoded JSON 'String'

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

@@ -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.@@ -12,8 +12,11 @@ -- See the License for the specific language governing permissions and -- limitations under the License. +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}  {-| @@ -23,6 +26,20 @@ module Crypto.JWT   (     JWT(..)++  , JWTError(..)+  , AsJWTError(..)++  , JWTValidationSettings+  , defaultJWTValidationSettings+  , HasJWTValidationSettings(..)+  , HasAllowedSkew(..)+  , HasAudiencePredicate(..)++  , createJWSJWT+  , validateJWSJWT++  , ClaimsSet(..) -- TODO hide fields   , claimAud   , claimExp   , claimIat@@ -32,12 +49,8 @@   , claimSub   , unregisteredClaims   , addClaim--  , createJWSJWT-  , validateJWSJWT--  , ClaimsSet(..)   , emptyClaimsSet+  , validateClaimsSet    , Audience(..) @@ -52,22 +65,41 @@  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.Maybe+import qualified Data.String -import Control.Lens (makeLenses, over)+import Control.Lens (+  makeClassy, makeClassyPrisms, makeLenses, makePrisms,+  Lens', _Just, over, preview, review, view)+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  +data JWTError+  = JWSError Error+  | JWTExpired+  | JWTNotYetValid+  | JWTNotInAudience+  deriving (Eq, Show)+makeClassyPrisms ''JWTError++instance AsError JWTError where+  _Error = _JWSError++ -- §2.  Terminology  -- | A JSON string value, with the additional requirement that while@@ -76,6 +108,9 @@ -- data StringOrURI = Arbitrary T.Text | OrURI URI deriving (Eq, Show) +instance Data.String.IsString StringOrURI where+  fromString = Arbitrary . T.pack+ -- | Construct a 'StringOrURI' from text -- fromString :: T.Text -> StringOrURI@@ -86,7 +121,7 @@ fromURI :: URI -> StringOrURI fromURI = OrURI --- | Get the +-- | Get the getString :: StringOrURI -> Maybe T.Text getString (Arbitrary a) = Just a getString (OrURI _) = Nothing@@ -111,7 +146,8 @@ -- | 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,14 +164,14 @@ -- /aud/ value MAY be a single case-sensitive string containing a -- 'StringOrURI' value. ---data Audience = General [StringOrURI] | Special StringOrURI deriving (Eq, Show)+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 auds) = toJSON auds   -- | The JWT Claims Set represents a JSON object whose members are@@ -226,9 +262,97 @@     ] ++ M.toList (filterUnregistered o)  +data JWTValidationSettings = JWTValidationSettings+  { _jwtValidationSettingsValidationSettings :: ValidationSettings+  , _jwtValidationSettingsAllowedSkew :: NominalDiffTime+  -- ^ The allowed skew is interpreted in absolute terms;+  --   a nonzero value always expands the validity period.+  , _jwtValidationSettingsAudiencePredicate :: StringOrURI -> Bool+  }+makeClassy ''JWTValidationSettings++instance HasValidationSettings JWTValidationSettings where+  validationSettings = jwtValidationSettingsValidationSettings++class HasAllowedSkew s where+  allowedSkew :: Lens' s NominalDiffTime+class HasAudiencePredicate s where+  audiencePredicate :: Lens' s (StringOrURI -> Bool)++instance HasJWTValidationSettings a => HasAllowedSkew a where+  allowedSkew = jwtValidationSettingsAllowedSkew+instance HasJWTValidationSettings a => HasAudiencePredicate a where+  audiencePredicate = jwtValidationSettingsAudiencePredicate++defaultJWTValidationSettings :: JWTValidationSettings+defaultJWTValidationSettings = JWTValidationSettings+  defaultValidationSettings+  0+  (const False)++-- | Validate the claims made by a ClaimsSet. Currently only inspects+-- the /exp/ and /nbf/ claims. N.B. These checks are also performed by+-- 'validateJWSJWT', which also validates any signatures, so you+-- shouldn’t need to use this directly in the normal course of things.+--+validateClaimsSet+  ::+    ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a+    , AsJWTError e, MonadError e m+    )+  => a+  -> ClaimsSet+  -> m ()+validateClaimsSet conf claims =+  sequence_+    [ validateExpClaim conf claims+    , validateNbfClaim conf claims+    , validateAudClaim conf claims+    ]++validateExpClaim+  :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m)+  => a+  -> ClaimsSet+  -> m ()+validateExpClaim conf (ClaimsSet _ _ _ (Just e) _ _ _ _) = do+  now <- currentTime+  if now < addUTCTime (abs (view allowedSkew conf)) (view _NumericDate e)+    then pure ()+    else throwError (review _JWTExpired ())+validateExpClaim _ _ = pure ()++validateNbfClaim+  :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m)+  => a+  -> ClaimsSet+  -> m ()+validateNbfClaim conf (ClaimsSet _ _ _ _ (Just n) _ _ _) = do+  now <- currentTime+  if now >= addUTCTime (negate (abs (view allowedSkew conf))) (view _NumericDate n)+    then pure ()+    else throwError (review _JWTNotYetValid ())+validateNbfClaim _ _ = pure ()++validateAudClaim+  :: (HasAudiencePredicate s, AsJWTError e, MonadError e m)+  => s+  -> ClaimsSet+  -> m ()+validateAudClaim conf claims =+  maybe+    (pure ())+    (\auds ->+      if or (view audiencePredicate conf <$> auds)+      then pure ()+      else throwError (review _JWTNotInAudience ())+      )+    (preview (claimAud . _Just . _Audience) claims)++ -- | Data representing the JOSE aspects of a JWT. ---data JWTCrypto = JWTJWS JWS deriving (Eq, Show)+data JWTCrypto = JWTJWS (JWS JWSHeader) deriving (Eq, Show)  instance FromCompact JWTCrypto where   fromCompact = fmap JWTJWS . fromCompact@@ -246,33 +370,42 @@  instance FromCompact JWT where   fromCompact = fromCompact >=> toJWT where-    toJWT (JWTJWS jws) =-      bimap CompactDecodeError (JWT (JWTJWS jws))-        $ eitherDecode $ jwsPayload jws+    toJWT (JWTJWS jws) = either+      (throwError . review _CompactDecodeError)+      (pure . JWT (JWTJWS jws))+      (eitherDecode $ jwsPayload jws)  instance ToCompact JWT where   toCompact = toCompact . jwtCrypto  --- | Validate a JWT as a JWS (JSON Web Signature).+-- | Validate a JWT as a JWS (JSON Web Signature), then as a Claims+-- Set. -- validateJWSJWT-  :: ValidationAlgorithms-  -> ValidationPolicy+  ::+    ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a+    , HasValidationSettings a+    , AsError e, AsJWTError e, MonadError e m+    )+  => a   -> JWK   -> JWT-  -> Bool-validateJWSJWT algs policy k (JWT (JWTJWS jws) _) = verifyJWS algs policy k jws+  -> m ()+validateJWSJWT conf k (JWT (JWTJWS jws) c) = do+  -- It is important, for security reasons, that the signature get+  -- verified before the claims.+  verifyJWS conf k jws >> validateClaimsSet conf c  -- | Create a JWT that is a JWS. -- createJWSJWT-  :: MonadRandom m+  :: (MonadRandom m, MonadError e m, AsError e)   => JWK   -> JWSHeader   -> ClaimsSet-  -> m (Either Error JWT)-createJWSJWT k h c = fmap (\jws -> JWT (JWTJWS jws) c) <$>-  signJWS (JWS payload []) h k+  -> m JWT+createJWSJWT k h c =+  (\jws -> JWT (JWTJWS jws) c) <$> signJWS (JWS payload []) h k   where     payload = Base64Octets $ BSL.toStrict $ encode c

@@ -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.Extras (is)+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 Crypto.JOSE.JWS.Internal (Signature(Signature)) import qualified Crypto.JOSE.JWA.JWS as JWA.JWS import qualified Crypto.JOSE.Types as Types-import Crypto.JOSE.Types.Armour   drg :: ChaChaDRG@@ -41,8 +43,6 @@  spec :: Spec spec = do-  critSpec-  critSpec'   headerSpec   appendixA1Spec   appendixA2Spec@@ -50,57 +50,99 @@   appendixA5Spec   appendixA6Spec -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' = JWSHeader' { unJWSHeader' :: JWSHeader }+  deriving (Eq, Show)+_JWSHeader' :: Iso' JWSHeader' JWSHeader+_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"]   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 })-+headerSpec = describe "JWS Header" $ do   it "parses signature correctly" $     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)+        & jwsHeaderKid .~ Just (HeaderParam Unprotected "2010-12-29")+      sig = Signature (Just "eyJhbGciOiJSUzI1NiJ9") h (Types.Base64Octets "")     in       eitherDecode sigJSON `shouldBe` Right sig +  it "rejects duplicate headers" $+    let+      -- protected header: {"kid":""}+      s = "{\"protected\":\"eyJraWQiOiIifQ\",\"header\":{\"alg\":\"none\",\"kid\":\"\"},\"signature\":\"\"}"+    in+      (eitherDecode s :: Either String (Signature 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 JWSHeader))+        `shouldSatisfy` is _Left++  it "rejects unknown crit parameters" $+    let+      -- protected header: {"crit":["foo"],"foo":""}+      s = "{\"protected\":\"eyJjcml0IjpbImZvbyJdLCJmb28iOiIifQ\",\"header\":{\"alg\":\"none\"},\"signature\":\"\"}"+    in+      (eitherDecode s :: Either String (Signature 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 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 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 JWSHeader'))+        `shouldSatisfy` is _Left++  it "rejects unprotected crit parameters" $+    let+      s = "{\"header\":{\"alg\":\"none\",\"crit\":[\"foo\"],\"foo\":\"\"},\"signature\":\"\"}"+    in+      (eitherDecode s :: Either String (Signature JWSHeader'))+        `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 JWSHeader'))+        `shouldSatisfy` is _Left++ examplePayload :: Types.Base64Octets examplePayload = Types.Base64Octets "\   \{\"iss\":\"joe\",\r\n\@@ -115,17 +157,22 @@   -- round-trip checks out   --   it "decodes the example to the correct value" $-    decodeCompact compactJWS `shouldBe` Right jws+    decodeCompact compactJWS+      `shouldBe` (Right jws :: Either Error (JWS JWSHeader))    it "round-trips correctly" $-    (encodeCompact jws >>= decodeCompact) `shouldBe` Right jws+    (encodeCompact jws >>= decodeCompact)+      `shouldBe` (Right jws :: Either Error (JWS JWSHeader))    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) (L.toStrict signingInput')))+      `shouldBe` (Right (BS.pack macOctets) :: Either Error BS.ByteString)    it "validates the JWS correctly" $-    fmap (verifyJWS def def jwk) (decodeCompact compactJWS) `shouldBe` Right True+    ( (decodeCompact compactJWS :: Either Error (JWS JWSHeader))+      >>= verifyJWS defaultValidationSettings jwk+    ) `shouldSatisfy` is _Right    where     signingInput' = "\@@ -133,13 +180,13 @@       \.\       \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\       \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ"-    compactJWS = signingInput' `L.append` "\-      \.\-      \dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"+    compactJWS = signingInput' <> ".dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"     jws = JWS examplePayload [signature]-    signature = Signature (Just $ Unarmoured h) Nothing (Types.Base64Octets mac)+    signature = Signature encodedProtectedHeader h (Types.Base64Octets mac)+    encodedProtectedHeader = Just "eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9"     alg = JWA.JWS.HS256-    h = def { headerAlg = Just alg, headerTyp = Just "JWT" }+    h = newJWSHeader (Protected, alg)+        & jwsHeaderTyp .~ Just (HeaderParam Protected "JWT")     mac = foldr BS.cons BS.empty macOctets     macOctets =       [116, 24, 223, 180, 151, 153, 224, 37, 79, 250, 96, 125, 216, 173,@@ -157,8 +204,8 @@ appendixA2Spec :: Spec appendixA2Spec = describe "JWS 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@@ -235,14 +282,14 @@ appendixA5Spec :: Spec appendixA5Spec = describe "JWS A.5.  Example Plaintext JWS" $ do   it "encodes the correct JWS" $-    (jws >>= encodeCompact) `shouldBe` Right exampleJWS+    (jws >>= encodeCompact) `shouldBe` (Right exampleJWS :: Either Error L.ByteString)    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 (JWS examplePayload []) (newJWSHeader (Protected, JWA.JWS.None)) undefined     exampleJWS = "eyJhbGciOiJub25lIn0\       \.\       \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\@@ -255,14 +302,15 @@   it "decodes the correct JWS" $ do     eitherDecode exampleJWS `shouldBe` Right jws     eitherDecode exampleJWS' `shouldBe` Right jws'-    lr (eitherDecode exampleFlatJWSWithSignatures :: Either String JWS) `shouldBe` L+    (eitherDecode exampleFlatJWSWithSignatures :: Either String (JWS 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" }+    sig1 = Signature Nothing h1' (Types.Base64Octets mac1)+    h1 = newJWSHeader (Protected, JWA.JWS.RS256)+    h1' = h1 & jwsHeaderKid .~ Just (HeaderParam Unprotected "2010-12-29")     mac1 = foldr BS.cons BS.empty       [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,@@ -282,9 +330,9 @@       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" }+    sig2 = Signature Nothing h2' (Types.Base64Octets mac2)+    h2 = newJWSHeader (Protected, JWA.JWS.ES256)+    h2' = h2 & jwsHeaderKid .~ Just (HeaderParam Unprotected "e9bc097a-ce51-4036-9562-d2ade882db0d")     mac2 = B64U.decodeLenient       "DtEhU3ljbEg8L38VWAfUAqOyKAM6-Xx-F4GawxaepmXFCgfTjDxw5djxLa8ISlSA\       \pmWQxfKTUJqPP3-Kg6NU1Q"@@ -336,9 +384,3 @@          \lSApmWQxfKTUJqPP3-Kg6NU1Q\",\       \ \"signatures\":\"bogus\"\       \}"--data LR = L | R deriving (Eq, Show)--lr :: Either a b -> LR-lr (Left _) = L-lr _ = R

@@ -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,16 +12,24 @@ -- 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)@@ -34,6 +42,9 @@ 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")@@ -41,8 +52,13 @@   & 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+   describe "JWT Claims Set" $ do     it "parses from JSON correctly" $       let@@ -56,6 +72,126 @@     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 () :: Either JWTError ())++      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 () :: Either JWTError ())+        it "can be validated if nonzero skew tolerance > delta" $+          let conf' = set allowedSkew 3 conf+          in runReaderT (validateClaimsSet conf' exampleClaimsSet) now+            `shouldBe` (Right () :: Either JWTError ())+        it "can be validated if negative skew tolerance = -delta" $+          let conf' = set allowedSkew (-2) conf+          in runReaderT (validateClaimsSet conf' exampleClaimsSet) now+            `shouldBe` (Right () :: Either JWTError ())++    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 () :: Either JWTError ())+        it "can be validated if nonzero skew tolerance > delta" $+          let conf' = set allowedSkew 3 conf+          in runReaderT (validateClaimsSet conf' claimsSet) now+            `shouldBe` (Right () :: Either JWTError ())+        it "can be validated if negative skew tolerance = -delta" $+          let conf' = set allowedSkew (-2) conf+          in runReaderT (validateClaimsSet conf' claimsSet) now+            `shouldBe` (Right () :: Either JWTError ())++      describe "when the current time is exactly equal to the Not Before claim" $+        it "can be validated" $+          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2016-07-05 17:37:22")+            `shouldBe` (Right () :: Either JWTError ())++      describe "when the current time is after the Not Before claim" $+        it "can be validated" $+          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2017-01-01 00:00:00")+            `shouldBe` (Right () :: Either JWTError ())++    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 () :: Either JWTError ())+      describe "when the current time is between the Not Before and Expiration Time claims" $+        it "can be validated" $+          runReaderT (validateClaimsSet conf claimsSet) (utcTime "2011-03-21 18:00:00")+            `shouldBe` (Right () :: Either JWTError ())+      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 () :: Either JWTError ())+      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 "StringOrURI" $     it "parses from JSON correctly" $ do       (decode "[\"foo\"]" >>= headMay >>= getString) `shouldBe` Just "foo"@@ -70,17 +206,29 @@       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 "§6.1.  Example Unsecured JWT" $ do+    let+      exampleJWT = "eyJhbGciOiJub25lIn0\+        \.\+        \eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFt\+        \cGxlLmNvbS9pc19yb290Ijp0cnVlfQ\+        \."+      jwt = decodeCompact exampleJWT+      k = fromJust $ decode "{\"kty\":\"oct\",\"k\":\"\"}"++    describe "when the current time is prior to the Expiration Time" $+      it "can be decoded and validated" $ do+        runReaderT (jwt >>= validateJWSJWT conf k) (utcTime "2010-01-01 00:00:00")+          `shouldBe` (Right () :: Either JWTError ())++    describe "when the current time is after the Expiration Time" $+      it "can be decoded, but not validated" $ do+        runReaderT (jwt >>= validateJWSJWT conf k) (utcTime "2012-01-01 00:00:00")+          `shouldBe` Left JWTExpired++    describe "when signature is invalid and token is expired" $+      it "fails on sig validation (claim validation not reached)" $ do+        let jwt' = decodeCompact (exampleJWT <> "badsig")+        (runReaderT (jwt' >>= validateJWSJWT conf k) (utcTime "2012-01-01 00:00:00")+          :: Either JWTError ())+          `shouldSatisfy` is (_Left . _JWSInvalidSignature)

@@ -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 @@   [ 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,28 @@     "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 (newJWS msg) (newJWSHeader (Protected, alg)) k+    >>= verifyJWS defaultValidationSettings k)) checkSignVerifyResult -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)+prop_bestJWSAlg :: B.ByteString -> Property+prop_bestJWSAlg msg = monadicIO $ do+  genParam <- pick arbitrary+  k <- run $ genJWK genParam+  case bestJWSAlg k of+    Left (_ :: Error) -> assert False+    Right alg -> do+      monitor (collect alg)+      let+        go = do+          jws <- signJWS (newJWS msg) (newJWSHeader (Protected, alg)) k+          verifyJWS defaultValidationSettings k jws+      wp (runExceptT go) checkSignVerifyResult++checkSignVerifyResult :: Monad m => Either Error a -> PropertyM m ()+checkSignVerifyResult = assert . either (const False) (const True)