--   This Source Code Form is subject to the terms of the Mozilla Public
--   License, v. 2.0. If a copy of the MPL was not distributed with this
--   file, You can obtain one at http://mozilla.org/MPL/2.0/.

{-# OPTIONS_HADDOCK show-extensions #-}

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}

-- | Validation of JWT claims

module Libjwt.JwtValidation
  ( ValidationSettings(..)
  , defaultValidationSettings
  , runValidation
  , ValidationNEL
  , Valid
  , Check
  , JwtValidation
  , validation
  , invalid
  , valid
  , checkIssuer
  , checkSubject
  , checkAge
  , checkIssuedAfter
  , checkJwtId
  , checkClaim
  , check
  , ValidationFailure(..)
  )
where

import           Libjwt.NumericDate
import           Libjwt.Payload
import           Libjwt.PrivateClaims
import           Libjwt.RegisteredClaims

import           Control.Monad.Time

import           Control.Monad.Trans.Reader

import           Data.Coerce                    ( coerce )

import           Data.Either.Validation         ( Validation(..) )

import           Data.List.NonEmpty             ( NonEmpty(..) )
import           Data.Monoid                    ( Ap(..) )

import           Data.Time.Clock

import           Data.UUID                      ( UUID )

import           Prelude                 hiding ( exp )

type ValidationNEL a b = Validation (NonEmpty a) b

data ValidationEnv = Env { ValidationEnv -> NumericDate
timestamp :: NumericDate
                         , ValidationEnv -> ValidationSettings
settings :: ValidationSettings
                         }

-- | User-defined parameters of an validation
data ValidationSettings = Settings { ValidationSettings -> NominalDiffTime
leeway :: NominalDiffTime -- ^ extends the token validity period to /['nbf' - leeway, 'exp' + leeway)/ (also works for 'iat' checks such as 'checkAge')
                                   , ValidationSettings -> Maybe String
appName :: Maybe String -- ^ used for 'aud' checks: if 'aud' claim is present, it must contain the value of this param
                                   }
  deriving stock Int -> ValidationSettings -> ShowS
[ValidationSettings] -> ShowS
ValidationSettings -> String
(Int -> ValidationSettings -> ShowS)
-> (ValidationSettings -> String)
-> ([ValidationSettings] -> ShowS)
-> Show ValidationSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationSettings] -> ShowS
$cshowList :: [ValidationSettings] -> ShowS
show :: ValidationSettings -> String
$cshow :: ValidationSettings -> String
showsPrec :: Int -> ValidationSettings -> ShowS
$cshowsPrec :: Int -> ValidationSettings -> ShowS
Show

-- | 'ValidationSettings' with 'leeway' set to @0@ and 'appName' set to @Nothing@
defaultValidationSettings :: ValidationSettings
defaultValidationSettings :: ValidationSettings
defaultValidationSettings = Settings :: NominalDiffTime -> Maybe String -> ValidationSettings
Settings { leeway :: NominalDiffTime
leeway = NominalDiffTime
0, appName :: Maybe String
appName = Maybe String
forall a. Maybe a
Nothing }

-- | Reasons for rejecting a JWT token
data ValidationFailure -- | User check failed 
                       = InvalidClaim String
                       -- | /exp/ check failed: the current time was after or equal to the expiration time (plus possible 'leeway')
                       | TokenExpired NominalDiffTime
                       -- | /nbf/ check failed: the current time was before the not-before time (minus possible 'leeway')
                       | TokenNotReady NominalDiffTime
                       -- | /aud/ check failed: the application processing this claim did not identify itself ('appName') with a value in the /aud/ claim
                       | WrongRecipient
                       -- | /iat/ check failed: the current time minus the time the JWT was issued (plus possible 'leeway') was greater than expected
                       | TokenTooOld NominalDiffTime
  deriving stock (Int -> ValidationFailure -> ShowS
[ValidationFailure] -> ShowS
ValidationFailure -> String
(Int -> ValidationFailure -> ShowS)
-> (ValidationFailure -> String)
-> ([ValidationFailure] -> ShowS)
-> Show ValidationFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationFailure] -> ShowS
$cshowList :: [ValidationFailure] -> ShowS
show :: ValidationFailure -> String
$cshow :: ValidationFailure -> String
showsPrec :: Int -> ValidationFailure -> ShowS
$cshowsPrec :: Int -> ValidationFailure -> ShowS
Show, ValidationFailure -> ValidationFailure -> Bool
(ValidationFailure -> ValidationFailure -> Bool)
-> (ValidationFailure -> ValidationFailure -> Bool)
-> Eq ValidationFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationFailure -> ValidationFailure -> Bool
$c/= :: ValidationFailure -> ValidationFailure -> Bool
== :: ValidationFailure -> ValidationFailure -> Bool
$c== :: ValidationFailure -> ValidationFailure -> Bool
Eq)

data Valid = Valid
  deriving stock Int -> Valid -> ShowS
[Valid] -> ShowS
Valid -> String
(Int -> Valid -> ShowS)
-> (Valid -> String) -> ([Valid] -> ShowS) -> Show Valid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Valid] -> ShowS
$cshowList :: [Valid] -> ShowS
show :: Valid -> String
$cshow :: Valid -> String
showsPrec :: Int -> Valid -> ShowS
$cshowsPrec :: Int -> Valid -> ShowS
Show

instance Semigroup Valid where
  Valid
Valid <> :: Valid -> Valid -> Valid
<> Valid
Valid = Valid
Valid

type Check pc ns = Payload pc ns -> ValidationNEL ValidationFailure Valid

type CheckAp pc ns
  = Payload pc ns -> Ap (Validation (NonEmpty ValidationFailure)) Valid

-- | Construct validation from function
validation :: Check pc any -> JwtValidation pc any
validation :: Check pc any -> JwtValidation pc any
validation = Ap (Reader ValidationEnv) (CheckAp pc any) -> JwtValidation pc any
forall (pc :: [Claim *]) (any :: Namespace).
Ap (Reader ValidationEnv) (CheckAp pc any) -> JwtValidation pc any
MkValidation (Ap (Reader ValidationEnv) (CheckAp pc any)
 -> JwtValidation pc any)
-> (Check pc any -> Ap (Reader ValidationEnv) (CheckAp pc any))
-> Check pc any
-> JwtValidation pc any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reader ValidationEnv (CheckAp pc any)
-> Ap (Reader ValidationEnv) (CheckAp pc any)
forall k (f :: k -> *) (a :: k). f a -> Ap f a
Ap (Reader ValidationEnv (CheckAp pc any)
 -> Ap (Reader ValidationEnv) (CheckAp pc any))
-> (Check pc any -> Reader ValidationEnv (CheckAp pc any))
-> Check pc any
-> Ap (Reader ValidationEnv) (CheckAp pc any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckAp pc any -> Reader ValidationEnv (CheckAp pc any)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckAp pc any -> Reader ValidationEnv (CheckAp pc any))
-> (Check pc any -> CheckAp pc any)
-> Check pc any
-> Reader ValidationEnv (CheckAp pc any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Check pc any -> CheckAp pc any
coerce

-- | Validation that is always valid
valid :: ValidationNEL ValidationFailure Valid
valid :: ValidationNEL ValidationFailure Valid
valid = Valid -> ValidationNEL ValidationFailure Valid
forall e a. a -> Validation e a
Success Valid
Valid

-- | Validation that always fails and signals @reason@
invalid
  :: ValidationFailure -- ^ reason
  -> ValidationNEL ValidationFailure Valid
invalid :: ValidationFailure -> ValidationNEL ValidationFailure Valid
invalid ValidationFailure
reason = NonEmpty ValidationFailure -> ValidationNEL ValidationFailure Valid
forall e a. e -> Validation e a
Failure (NonEmpty ValidationFailure
 -> ValidationNEL ValidationFailure Valid)
-> NonEmpty ValidationFailure
-> ValidationNEL ValidationFailure Valid
forall a b. (a -> b) -> a -> b
$ ValidationFailure
reason ValidationFailure
-> [ValidationFailure] -> NonEmpty ValidationFailure
forall a. a -> [a] -> NonEmpty a
:| []

newtype JwtValidation pc any = MkValidation { JwtValidation pc any -> Ap (Reader ValidationEnv) (CheckAp pc any)
rules :: Ap (Reader ValidationEnv) (CheckAp pc any) }
  deriving newtype (b -> JwtValidation pc any -> JwtValidation pc any
NonEmpty (JwtValidation pc any) -> JwtValidation pc any
JwtValidation pc any
-> JwtValidation pc any -> JwtValidation pc any
(JwtValidation pc any
 -> JwtValidation pc any -> JwtValidation pc any)
-> (NonEmpty (JwtValidation pc any) -> JwtValidation pc any)
-> (forall b.
    Integral b =>
    b -> JwtValidation pc any -> JwtValidation pc any)
-> Semigroup (JwtValidation pc any)
forall (pc :: [Claim *]) (any :: Namespace).
NonEmpty (JwtValidation pc any) -> JwtValidation pc any
forall (pc :: [Claim *]) (any :: Namespace).
JwtValidation pc any
-> JwtValidation pc any -> JwtValidation pc any
forall (pc :: [Claim *]) (any :: Namespace) b.
Integral b =>
b -> JwtValidation pc any -> JwtValidation pc any
forall b.
Integral b =>
b -> JwtValidation pc any -> JwtValidation pc any
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> JwtValidation pc any -> JwtValidation pc any
$cstimes :: forall (pc :: [Claim *]) (any :: Namespace) b.
Integral b =>
b -> JwtValidation pc any -> JwtValidation pc any
sconcat :: NonEmpty (JwtValidation pc any) -> JwtValidation pc any
$csconcat :: forall (pc :: [Claim *]) (any :: Namespace).
NonEmpty (JwtValidation pc any) -> JwtValidation pc any
<> :: JwtValidation pc any
-> JwtValidation pc any -> JwtValidation pc any
$c<> :: forall (pc :: [Claim *]) (any :: Namespace).
JwtValidation pc any
-> JwtValidation pc any -> JwtValidation pc any
Semigroup)

instance Monoid (JwtValidation any1 any2) where
  mempty :: JwtValidation any1 any2
mempty = Check any1 any2 -> JwtValidation any1 any2
forall (pc :: [Claim *]) (any :: Namespace).
Check pc any -> JwtValidation pc any
validation (Check any1 any2 -> JwtValidation any1 any2)
-> Check any1 any2 -> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ ValidationNEL ValidationFailure Valid -> Check any1 any2
forall a b. a -> b -> a
const ValidationNEL ValidationFailure Valid
valid

-- | Run checks against the @payload@.
--
--   The exact set of checks is: @ defaultValidationRules <> v @, where @v@ is passed to this function and @defaultValidationRules@ is:
--
--    * check /exp/ claim against the current time (minus possible 'leeway'),
--    * check /nbf/ claim against the current time (plus possible 'leeway'),
--    * check /aud/ claim against 'appName'
--
--   See the docs of 'ValidationFailure' for a list of possible errors.
runValidation
  :: (MonadTime m)
  => ValidationSettings -- ^ /leeway/ and /appName/
  -> JwtValidation pc any -- ^ v
  -> Payload pc any -- ^ payload
  -> m (ValidationNEL ValidationFailure Valid)
runValidation :: ValidationSettings
-> JwtValidation pc any
-> Payload pc any
-> m (ValidationNEL ValidationFailure Valid)
runValidation ValidationSettings
settings JwtValidation pc any
v Payload pc any
payload =
  let MkValidation { Ap (Reader ValidationEnv) (CheckAp pc any)
rules :: Ap (Reader ValidationEnv) (CheckAp pc any)
rules :: forall (pc :: [Claim *]) (any :: Namespace).
JwtValidation pc any -> Ap (Reader ValidationEnv) (CheckAp pc any)
rules } = JwtValidation pc any
forall (any1 :: [Claim *]) (any2 :: Namespace).
JwtValidation any1 any2
defaultValidationRules JwtValidation pc any
-> JwtValidation pc any -> JwtValidation pc any
forall a. Semigroup a => a -> a -> a
<> JwtValidation pc any
v
      applyRules :: ValidationEnv -> CheckAp pc any
applyRules             = Reader ValidationEnv (CheckAp pc any)
-> ValidationEnv -> CheckAp pc any
forall r a. Reader r a -> r -> a
runReader (Ap (Reader ValidationEnv) (CheckAp pc any)
-> Reader ValidationEnv (CheckAp pc any)
forall k (f :: k -> *) (a :: k). Ap f a -> f a
getAp Ap (Reader ValidationEnv) (CheckAp pc any)
rules)
  in  do
        NumericDate
timestamp <- m NumericDate
forall (m :: * -> *). MonadTime m => m NumericDate
now
        let env :: ValidationEnv
env = Env :: NumericDate -> ValidationSettings -> ValidationEnv
Env { NumericDate
timestamp :: NumericDate
timestamp :: NumericDate
timestamp, ValidationSettings
settings :: ValidationSettings
settings :: ValidationSettings
settings }
        ValidationNEL ValidationFailure Valid
-> m (ValidationNEL ValidationFailure Valid)
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationNEL ValidationFailure Valid
 -> m (ValidationNEL ValidationFailure Valid))
-> ValidationNEL ValidationFailure Valid
-> m (ValidationNEL ValidationFailure Valid)
forall a b. (a -> b) -> a -> b
$ Ap (Validation (NonEmpty ValidationFailure)) Valid
-> ValidationNEL ValidationFailure Valid
forall k (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap (Validation (NonEmpty ValidationFailure)) Valid
 -> ValidationNEL ValidationFailure Valid)
-> Ap (Validation (NonEmpty ValidationFailure)) Valid
-> ValidationNEL ValidationFailure Valid
forall a b. (a -> b) -> a -> b
$ ValidationEnv -> CheckAp pc any
applyRules ValidationEnv
env Payload pc any
payload

defaultValidationRules :: JwtValidation any1 any2
defaultValidationRules :: JwtValidation any1 any2
defaultValidationRules = JwtValidation any1 any2
forall (any1 :: [Claim *]) (any2 :: Namespace).
JwtValidation any1 any2
_checkExp JwtValidation any1 any2
-> JwtValidation any1 any2 -> JwtValidation any1 any2
forall a. Semigroup a => a -> a -> a
<> JwtValidation any1 any2
forall (any1 :: [Claim *]) (any2 :: Namespace).
JwtValidation any1 any2
_checkNbf JwtValidation any1 any2
-> JwtValidation any1 any2 -> JwtValidation any1 any2
forall a. Semigroup a => a -> a -> a
<> JwtValidation any1 any2
forall (any1 :: [Claim *]) (any2 :: Namespace).
JwtValidation any1 any2
_checkAud

using
  :: (ValidationEnv -> a) -> (a -> JwtValidation pc any) -> JwtValidation pc any
using :: (ValidationEnv -> a)
-> (a -> JwtValidation pc any) -> JwtValidation pc any
using ValidationEnv -> a
get a -> JwtValidation pc any
v = Reader ValidationEnv (CheckAp pc any) -> JwtValidation pc any
coerce (Ap (Reader ValidationEnv) (CheckAp pc any)
-> Reader ValidationEnv (CheckAp pc any)
forall k (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap (Reader ValidationEnv) (CheckAp pc any)
 -> Reader ValidationEnv (CheckAp pc any))
-> (a -> Ap (Reader ValidationEnv) (CheckAp pc any))
-> a
-> Reader ValidationEnv (CheckAp pc any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JwtValidation pc any -> Ap (Reader ValidationEnv) (CheckAp pc any)
forall (pc :: [Claim *]) (any :: Namespace).
JwtValidation pc any -> Ap (Reader ValidationEnv) (CheckAp pc any)
rules (JwtValidation pc any
 -> Ap (Reader ValidationEnv) (CheckAp pc any))
-> (a -> JwtValidation pc any)
-> a
-> Ap (Reader ValidationEnv) (CheckAp pc any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> JwtValidation pc any
v (a -> Reader ValidationEnv (CheckAp pc any))
-> Reader ValidationEnv a -> Reader ValidationEnv (CheckAp pc any)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ValidationEnv -> a) -> Reader ValidationEnv a
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ValidationEnv -> a
get)

-- | Check the property @prop@ of a payload with the predicate @p@
--
--   If @p@ is @False@, then signal @'InvalidClaim' claim@
check
  :: String -- ^ claim
  -> (a -> Bool) -- ^ p
  -> (Payload pc any -> a) -- ^ prop
  -> JwtValidation pc any
check :: String
-> (a -> Bool) -> (Payload pc any -> a) -> JwtValidation pc any
check String
claim a -> Bool
p Payload pc any -> a
prop =
  Check pc any -> JwtValidation pc any
forall (pc :: [Claim *]) (any :: Namespace).
Check pc any -> JwtValidation pc any
validation
    (Check pc any -> JwtValidation pc any)
-> Check pc any -> JwtValidation pc any
forall a b. (a -> b) -> a -> b
$ (\a
a -> if a -> Bool
p a
a then ValidationNEL ValidationFailure Valid
valid else ValidationFailure -> ValidationNEL ValidationFailure Valid
invalid (ValidationFailure -> ValidationNEL ValidationFailure Valid)
-> ValidationFailure -> ValidationNEL ValidationFailure Valid
forall a b. (a -> b) -> a -> b
$ String -> ValidationFailure
InvalidClaim String
claim)
    (a -> ValidationNEL ValidationFailure Valid)
-> (Payload pc any -> a) -> Check pc any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload pc any -> a
prop

-- | Check that /iss/ is present and equal to @issuer@. If not, then signal @'InvalidClaim' "iss"@
checkIssuer
  :: String -- ^ issuer
  -> JwtValidation any1 any2
checkIssuer :: String -> JwtValidation any1 any2
checkIssuer String
issuer = String
-> (Iss -> Bool)
-> (Payload any1 any2 -> Iss)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
String
-> (a -> Bool) -> (Payload pc any -> a) -> JwtValidation pc any
check String
"iss" (Iss -> Iss -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String -> Iss
Iss (String -> Maybe String
forall a. a -> Maybe a
Just String
issuer)) Payload any1 any2 -> Iss
forall (pc :: [Claim *]) (ns :: Namespace). Payload pc ns -> Iss
iss

-- | Check that /sub/ is present and equal to @subject@. If not, then signal @'InvalidClaim' "sub"@
checkSubject
  :: String -- ^ subject 
  -> JwtValidation any1 any2
checkSubject :: String -> JwtValidation any1 any2
checkSubject String
subject = String
-> (Sub -> Bool)
-> (Payload any1 any2 -> Sub)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
String
-> (a -> Bool) -> (Payload pc any -> a) -> JwtValidation pc any
check String
"sub" (Sub -> Sub -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String -> Sub
Sub (String -> Maybe String
forall a. a -> Maybe a
Just String
subject)) Payload any1 any2 -> Sub
forall (pc :: [Claim *]) (ns :: Namespace). Payload pc ns -> Sub
sub

_checkAud :: JwtValidation any1 any2
_checkAud :: JwtValidation any1 any2
_checkAud = (ValidationEnv -> Maybe String)
-> (Maybe String -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
(ValidationEnv -> a)
-> (a -> JwtValidation pc any) -> JwtValidation pc any
using (ValidationSettings -> Maybe String
appName (ValidationSettings -> Maybe String)
-> (ValidationEnv -> ValidationSettings)
-> ValidationEnv
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationEnv -> ValidationSettings
settings)
  ((Maybe String -> JwtValidation any1 any2)
 -> JwtValidation any1 any2)
-> (Maybe String -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ \Maybe String
ident -> Check any1 any2 -> JwtValidation any1 any2
forall (pc :: [Claim *]) (any :: Namespace).
Check pc any -> JwtValidation pc any
validation (Check any1 any2 -> JwtValidation any1 any2)
-> Check any1 any2 -> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ Maybe String -> Aud -> ValidationNEL ValidationFailure Valid
rfc7519_413 Maybe String
ident (Aud -> ValidationNEL ValidationFailure Valid)
-> (Payload any1 any2 -> Aud) -> Check any1 any2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload any1 any2 -> Aud
forall (pc :: [Claim *]) (ns :: Namespace). Payload pc ns -> Aud
aud
 where
  rfc7519_413 :: Maybe String -> Aud -> ValidationNEL ValidationFailure Valid
rfc7519_413 Maybe String
_       (Aud []) = ValidationNEL ValidationFailure Valid
valid
  rfc7519_413 Maybe String
Nothing Aud
_        = ValidationFailure -> ValidationNEL ValidationFailure Valid
invalid ValidationFailure
WrongRecipient
  rfc7519_413 (Just String
ident) (Aud [String]
rs) | String
ident String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
rs = ValidationNEL ValidationFailure Valid
valid
                                    | Bool
otherwise       = ValidationFailure -> ValidationNEL ValidationFailure Valid
invalid ValidationFailure
WrongRecipient

_checkExp :: JwtValidation any1 any2
_checkExp :: JwtValidation any1 any2
_checkExp = (ValidationEnv -> NominalDiffTime)
-> (NominalDiffTime -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
(ValidationEnv -> a)
-> (a -> JwtValidation pc any) -> JwtValidation pc any
using (ValidationSettings -> NominalDiffTime
leeway (ValidationSettings -> NominalDiffTime)
-> (ValidationEnv -> ValidationSettings)
-> ValidationEnv
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationEnv -> ValidationSettings
settings)
  ((NominalDiffTime -> JwtValidation any1 any2)
 -> JwtValidation any1 any2)
-> (NominalDiffTime -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ \NominalDiffTime
skew -> (ValidationEnv -> NumericDate)
-> (NumericDate -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
(ValidationEnv -> a)
-> (a -> JwtValidation pc any) -> JwtValidation pc any
using ValidationEnv -> NumericDate
timestamp ((NumericDate -> JwtValidation any1 any2)
 -> JwtValidation any1 any2)
-> (NumericDate -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ \NumericDate
t0 -> Check any1 any2 -> JwtValidation any1 any2
forall (pc :: [Claim *]) (any :: Namespace).
Check pc any -> JwtValidation pc any
validation (Check any1 any2 -> JwtValidation any1 any2)
-> Check any1 any2 -> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ NumericDate
-> NominalDiffTime -> Exp -> ValidationNEL ValidationFailure Valid
rfc7519_414 NumericDate
t0 NominalDiffTime
skew (Exp -> ValidationNEL ValidationFailure Valid)
-> (Payload any1 any2 -> Exp) -> Check any1 any2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload any1 any2 -> Exp
forall (pc :: [Claim *]) (ns :: Namespace). Payload pc ns -> Exp
exp
 where
  rfc7519_414 :: NumericDate
-> NominalDiffTime -> Exp -> ValidationNEL ValidationFailure Valid
rfc7519_414 NumericDate
_ NominalDiffTime
_ (Exp Maybe NumericDate
Nothing) = ValidationNEL ValidationFailure Valid
valid
  rfc7519_414 NumericDate
t0 NominalDiffTime
skew (Exp (Just NumericDate
t1))
    | NumericDate
t0 NumericDate -> NominalDiffTime -> NumericDate
`minusSeconds` NominalDiffTime
skew NumericDate -> NumericDate -> Bool
forall a. Ord a => a -> a -> Bool
< NumericDate
t1 = ValidationNEL ValidationFailure Valid
valid
    | Bool
otherwise                   = ValidationFailure -> ValidationNEL ValidationFailure Valid
invalid (ValidationFailure -> ValidationNEL ValidationFailure Valid)
-> ValidationFailure -> ValidationNEL ValidationFailure Valid
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> ValidationFailure
TokenExpired (NominalDiffTime -> ValidationFailure)
-> NominalDiffTime -> ValidationFailure
forall a b. (a -> b) -> a -> b
$ NumericDate -> NumericDate -> NominalDiffTime
diffSeconds NumericDate
t0 NumericDate
t1

_checkNbf :: JwtValidation any1 any2
_checkNbf :: JwtValidation any1 any2
_checkNbf = (ValidationEnv -> NominalDiffTime)
-> (NominalDiffTime -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
(ValidationEnv -> a)
-> (a -> JwtValidation pc any) -> JwtValidation pc any
using (ValidationSettings -> NominalDiffTime
leeway (ValidationSettings -> NominalDiffTime)
-> (ValidationEnv -> ValidationSettings)
-> ValidationEnv
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationEnv -> ValidationSettings
settings)
  ((NominalDiffTime -> JwtValidation any1 any2)
 -> JwtValidation any1 any2)
-> (NominalDiffTime -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ \NominalDiffTime
skew -> (ValidationEnv -> NumericDate)
-> (NumericDate -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
(ValidationEnv -> a)
-> (a -> JwtValidation pc any) -> JwtValidation pc any
using ValidationEnv -> NumericDate
timestamp ((NumericDate -> JwtValidation any1 any2)
 -> JwtValidation any1 any2)
-> (NumericDate -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ \NumericDate
t0 -> Check any1 any2 -> JwtValidation any1 any2
forall (pc :: [Claim *]) (any :: Namespace).
Check pc any -> JwtValidation pc any
validation (Check any1 any2 -> JwtValidation any1 any2)
-> Check any1 any2 -> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ NumericDate
-> NominalDiffTime -> Nbf -> ValidationNEL ValidationFailure Valid
rfc7519_415 NumericDate
t0 NominalDiffTime
skew (Nbf -> ValidationNEL ValidationFailure Valid)
-> (Payload any1 any2 -> Nbf) -> Check any1 any2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload any1 any2 -> Nbf
forall (pc :: [Claim *]) (ns :: Namespace). Payload pc ns -> Nbf
nbf
 where
  rfc7519_415 :: NumericDate
-> NominalDiffTime -> Nbf -> ValidationNEL ValidationFailure Valid
rfc7519_415 NumericDate
_ NominalDiffTime
_ (Nbf Maybe NumericDate
Nothing) = ValidationNEL ValidationFailure Valid
valid
  rfc7519_415 NumericDate
t0 NominalDiffTime
skew (Nbf (Just NumericDate
t1))
    | NumericDate
t0 NumericDate -> NominalDiffTime -> NumericDate
`plusSeconds` NominalDiffTime
skew NumericDate -> NumericDate -> Bool
forall a. Ord a => a -> a -> Bool
>= NumericDate
t1 = ValidationNEL ValidationFailure Valid
valid
    | Bool
otherwise                   = ValidationFailure -> ValidationNEL ValidationFailure Valid
invalid (ValidationFailure -> ValidationNEL ValidationFailure Valid)
-> ValidationFailure -> ValidationNEL ValidationFailure Valid
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> ValidationFailure
TokenNotReady (NominalDiffTime -> ValidationFailure)
-> NominalDiffTime -> ValidationFailure
forall a b. (a -> b) -> a -> b
$ NumericDate -> NumericDate -> NominalDiffTime
diffSeconds NumericDate
t1 NumericDate
t0

-- | Check that /iat/ (if present) is not further than @maxAge@ from 'currentTime' (minus possible 'leeway'). Otherwise signal 'TokenTooOld'.
checkAge
  :: NominalDiffTime -- ^ maxAge 
  -> JwtValidation any1 any2
checkAge :: NominalDiffTime -> JwtValidation any1 any2
checkAge NominalDiffTime
maxAge = (ValidationEnv -> NominalDiffTime)
-> (NominalDiffTime -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
(ValidationEnv -> a)
-> (a -> JwtValidation pc any) -> JwtValidation pc any
using (ValidationSettings -> NominalDiffTime
leeway (ValidationSettings -> NominalDiffTime)
-> (ValidationEnv -> ValidationSettings)
-> ValidationEnv
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationEnv -> ValidationSettings
settings)
  ((NominalDiffTime -> JwtValidation any1 any2)
 -> JwtValidation any1 any2)
-> (NominalDiffTime -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ \NominalDiffTime
skew -> (ValidationEnv -> NumericDate)
-> (NumericDate -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
(ValidationEnv -> a)
-> (a -> JwtValidation pc any) -> JwtValidation pc any
using ValidationEnv -> NumericDate
timestamp ((NumericDate -> JwtValidation any1 any2)
 -> JwtValidation any1 any2)
-> (NumericDate -> JwtValidation any1 any2)
-> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ \NumericDate
t0 -> Check any1 any2 -> JwtValidation any1 any2
forall (pc :: [Claim *]) (any :: Namespace).
Check pc any -> JwtValidation pc any
validation (Check any1 any2 -> JwtValidation any1 any2)
-> Check any1 any2 -> JwtValidation any1 any2
forall a b. (a -> b) -> a -> b
$ NumericDate
-> NominalDiffTime -> Iat -> ValidationNEL ValidationFailure Valid
ageCheck NumericDate
t0 NominalDiffTime
skew (Iat -> ValidationNEL ValidationFailure Valid)
-> (Payload any1 any2 -> Iat) -> Check any1 any2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload any1 any2 -> Iat
forall (pc :: [Claim *]) (ns :: Namespace). Payload pc ns -> Iat
iat
 where
  ageCheck :: NumericDate
-> NominalDiffTime -> Iat -> ValidationNEL ValidationFailure Valid
ageCheck NumericDate
_ NominalDiffTime
_ (Iat Maybe NumericDate
Nothing) = ValidationNEL ValidationFailure Valid
valid
  ageCheck NumericDate
t0 NominalDiffTime
skew (Iat (Just NumericDate
t1))
    | NominalDiffTime
age NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
maxAge = ValidationNEL ValidationFailure Valid
valid
    | Bool
otherwise     = ValidationFailure -> ValidationNEL ValidationFailure Valid
invalid (ValidationFailure -> ValidationNEL ValidationFailure Valid)
-> ValidationFailure -> ValidationNEL ValidationFailure Valid
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> ValidationFailure
TokenTooOld (NominalDiffTime -> ValidationFailure)
-> NominalDiffTime -> ValidationFailure
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
age NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
maxAge
    where age :: NominalDiffTime
age = NumericDate -> NumericDate -> NominalDiffTime
diffSeconds NumericDate
t0 (NumericDate -> NominalDiffTime) -> NumericDate -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NumericDate
t1 NumericDate -> NominalDiffTime -> NumericDate
`plusSeconds` NominalDiffTime
skew

-- | Check that /iat/ (if present) is after @time@. If false, signal @'InvalidClaim' "iat"@.
checkIssuedAfter
  :: UTCTime -- ^ time
  -> JwtValidation any1 any2
checkIssuedAfter :: UTCTime -> JwtValidation any1 any2
checkIssuedAfter UTCTime
time = String
-> (Iat -> Bool)
-> (Payload any1 any2 -> Iat)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
String
-> (a -> Bool) -> (Payload pc any -> a) -> JwtValidation pc any
check
  String
"iat"
  (\case
    Iat Maybe NumericDate
Nothing   -> Bool
True
    Iat (Just NumericDate
t1) -> NumericDate
t1 NumericDate -> NumericDate -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime -> NumericDate
fromUTC UTCTime
time
  )
  Payload any1 any2 -> Iat
forall (pc :: [Claim *]) (ns :: Namespace). Payload pc ns -> Iat
iat

-- | Check that /jti/ is present and equal to @jwtId@. If not, then signal @'InvalidClaim' "jti"@
checkJwtId
  :: UUID -- ^ jwtId
  -> JwtValidation any1 any2
checkJwtId :: UUID -> JwtValidation any1 any2
checkJwtId UUID
jwtId = String
-> (Jti -> Bool)
-> (Payload any1 any2 -> Jti)
-> JwtValidation any1 any2
forall a (pc :: [Claim *]) (any :: Namespace).
String
-> (a -> Bool) -> (Payload pc any -> a) -> JwtValidation pc any
check String
"jti" (Jti -> Jti -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe UUID -> Jti
Jti (UUID -> Maybe UUID
forall a. a -> Maybe a
Just UUID
jwtId)) Payload any1 any2 -> Jti
forall (pc :: [Claim *]) (ns :: Namespace). Payload pc ns -> Jti
jti

-- | Check that @p a == True@, where @a@ is a value of private claim @n@. If not, signal @'InvalidClaim' n@
--   
--   Example:
--   
-- @
-- 'checkClaim' not #is_root
-- @
checkClaim
  :: (CanGet n pc, a ~ LookupClaimType n pc)
  => (a -> Bool) -- ^ p
  -> ClaimName n -- ^ n
  -> JwtValidation pc any
checkClaim :: (a -> Bool) -> ClaimName n -> JwtValidation pc any
checkClaim a -> Bool
p ClaimName n
n = String
-> (a -> Bool) -> (Payload pc any -> a) -> JwtValidation pc any
forall a (pc :: [Claim *]) (any :: Namespace).
String
-> (a -> Bool) -> (Payload pc any -> a) -> JwtValidation pc any
check (ClaimName n -> String
forall (name :: Symbol).
KnownSymbol name =>
ClaimName name -> String
claimNameVal ClaimName n
n) a -> Bool
p (ClaimName n -> PrivateClaims pc any -> LookupClaimType n pc
forall (name :: Symbol) (ts :: [Claim *]) (ns :: Namespace).
CanGet name ts =>
ClaimName name -> PrivateClaims ts ns -> LookupClaimType name ts
getClaim ClaimName n
n (PrivateClaims pc any -> a)
-> (Payload pc any -> PrivateClaims pc any) -> Payload pc any -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload pc any -> PrivateClaims pc any
forall (pc :: [Claim *]) (ns :: Namespace).
Payload pc ns -> PrivateClaims pc ns
privateClaims)