{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
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
}
data ValidationSettings = Settings { ValidationSettings -> NominalDiffTime
leeway :: NominalDiffTime
, ValidationSettings -> Maybe String
appName :: Maybe String
}
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
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 }
data ValidationFailure
= InvalidClaim String
| TokenExpired NominalDiffTime
| TokenNotReady NominalDiffTime
| WrongRecipient
| 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
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
valid :: ValidationNEL ValidationFailure Valid
valid :: ValidationNEL ValidationFailure Valid
valid = Valid -> ValidationNEL ValidationFailure Valid
forall e a. a -> Validation e a
Success Valid
Valid
invalid
:: ValidationFailure
-> 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
runValidation
:: (MonadTime m)
=> ValidationSettings
-> JwtValidation pc any
-> Payload pc any
-> 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
:: String
-> (a -> Bool)
-> (Payload pc any -> a)
-> 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
checkIssuer
:: String
-> 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
checkSubject
:: String
-> 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
checkAge
:: NominalDiffTime
-> 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
checkIssuedAfter
:: UTCTime
-> 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
checkJwtId
:: UUID
-> 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
checkClaim
:: (CanGet n pc, a ~ LookupClaimType n pc)
=> (a -> Bool)
-> ClaimName 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)