{-# LANGUAGE OverloadedStrings #-}

module SAML2.WebSSO.SP where

import Control.Lens hiding (Level)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Except
import Control.Monad.Extra (ifM)
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Foldable (toList)
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe
import qualified Data.Semigroup
import Data.String.Conversions
import Data.Time
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import GHC.Stack
import SAML2.Util
import SAML2.WebSSO.Config
import SAML2.WebSSO.Servant.CPP
import SAML2.WebSSO.Types
import Servant hiding (MkLink, URI (..))
import URI.ByteString

----------------------------------------------------------------------
-- class

-- | Application logic of the service provider.
type SP m = (HasConfig m, HasLogger m, HasCreateUUID m, HasNow m)

class HasLogger m where
  logger :: Level -> String -> m ()
  default logger :: (HasConfig m, MonadIO m) => Level -> String -> m ()
  logger = Level -> String -> m ()
forall (m :: * -> *).
(HasConfig m, MonadIO m) =>
Level -> String -> m ()
loggerConfIO

class HasCreateUUID m where
  createUUID :: m UUID
  default createUUID :: MonadIO m => m UUID
  createUUID = m UUID
forall (m :: * -> *). MonadIO m => m UUID
createUUIDIO

class HasNow m where
  getNow :: m Time
  default getNow :: MonadIO m => m Time
  getNow = m Time
forall (m :: * -> *). MonadIO m => m Time
getNowIO

type SPStore m = (SP m, SPStoreID AuthnRequest m, SPStoreID Assertion m)

class SPStoreID i m where
  storeID :: ID i -> Time -> m ()
  unStoreID :: ID i -> m ()
  isAliveID ::
    ID i ->
    -- | stored and not timed out.
    m Bool

class (MonadError err m) => SPStoreIdP err m where
  type IdPConfigExtra m :: Type
  type IdPConfigSPId m :: Type
  storeIdPConfig :: IdPConfig (IdPConfigExtra m) -> m ()
  getIdPConfig :: IdPId -> m (IdPConfig (IdPConfigExtra m))
  getIdPConfigByIssuer :: Issuer -> IdPConfigSPId m -> m (IdPConfig (IdPConfigExtra m))
  getIdPConfigByIssuer Issuer
issuer IdPConfigSPId m
spid = Issuer
-> Maybe (IdPConfigSPId m) -> m (IdPConfig (IdPConfigExtra m))
forall err (m :: * -> *).
SPStoreIdP err m =>
Issuer
-> Maybe (IdPConfigSPId m) -> m (IdPConfig (IdPConfigExtra m))
getIdPConfigByIssuerOptionalSPId Issuer
issuer (IdPConfigSPId m -> Maybe (IdPConfigSPId m)
forall a. a -> Maybe a
Just IdPConfigSPId m
spid)
  getIdPConfigByIssuerOptionalSPId :: Issuer -> Maybe (IdPConfigSPId m) -> m (IdPConfig (IdPConfigExtra m))

-- | HTTP handling of the service provider.
class (SP m, SPStore m, SPStoreIdP err m, MonadError err m) => SPHandler err m where
  type NTCTX m :: Type
  nt :: forall x. NTCTX m -> m x -> Handler x

----------------------------------------------------------------------
-- combinators

-- | Store 'Assertion's to prevent replay attack.  'Time' argument is end of life (IDs may be
-- garbage collected after that time).  Iff assertion has already been stored and is still alive,
-- return 'False'.
storeAssertion :: (Monad m, SPStore m) => ID Assertion -> Time -> m Bool
storeAssertion :: forall (m :: * -> *).
(Monad m, SPStore m) =>
ID Assertion -> Time -> m Bool
storeAssertion ID Assertion
item Time
endOfLife =
  m Bool -> m Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
    (ID Assertion -> m Bool
forall {k} (i :: k) (m :: * -> *). SPStoreID i m => ID i -> m Bool
isAliveID ID Assertion
item)
    (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
    (Bool
True Bool -> m () -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ID Assertion -> Time -> m ()
forall {k} (i :: k) (m :: * -> *).
SPStoreID i m =>
ID i -> Time -> m ()
storeID ID Assertion
item Time
endOfLife)

loggerConfIO :: (HasConfig m, MonadIO m) => Level -> String -> m ()
loggerConfIO :: forall (m :: * -> *).
(HasConfig m, MonadIO m) =>
Level -> String -> m ()
loggerConfIO Level
level String
msg = do
  Level
cfgsays <- (Config -> Getting Level Config Level -> Level
forall s a. s -> Getting a s a -> a
^. Getting Level Config Level
Lens' Config Level
cfgLogLevel) (Config -> Level) -> m Config -> m Level
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Config
forall (m :: * -> *). HasConfig m => m Config
getConfig
  Level -> Level -> String -> m ()
forall (m :: * -> *). MonadIO m => Level -> Level -> String -> m ()
loggerIO Level
cfgsays Level
level String
msg

loggerIO :: MonadIO m => Level -> Level -> String -> m ()
loggerIO :: forall (m :: * -> *). MonadIO m => Level -> Level -> String -> m ()
loggerIO Level
cfgsays Level
level String
msg =
  if Level
level Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Level
cfgsays
    then IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
msg
    else () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

createUUIDIO :: MonadIO m => m UUID
createUUIDIO :: forall (m :: * -> *). MonadIO m => m UUID
createUUIDIO = IO UUID -> m UUID
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.nextRandom

getNowIO :: MonadIO m => m Time
getNowIO :: forall (m :: * -> *). MonadIO m => m Time
getNowIO = UTCTime -> Time
Time (UTCTime -> Time) -> m UTCTime -> m Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

-- | (Microsoft Active Directory likes IDs to be of the form @id<32 hex digits>@: @ID . cs . ("id"
-- <>) . filter (/= '-') . cs . UUID.toText <$> createUUID@.  Hopefully the more common form
-- produced by this function is also ok.)
createID :: (Functor m, SP m) => m (ID a)
createID :: forall {k} (m :: * -> *) (a :: k). (Functor m, SP m) => m (ID a)
createID = ST -> ID a
forall {k} (m :: k). ST -> ID m
mkID (ST -> ID a) -> (UUID -> ST) -> UUID -> ID a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ST
"_" ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<>) (ST -> ST) -> (UUID -> ST) -> UUID -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ST
UUID.toText (UUID -> ID a) -> m UUID -> m (ID a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m UUID
forall (m :: * -> *). HasCreateUUID m => m UUID
createUUID

-- | Generate an 'AuthnRequest' value for the initiate-login response.  The 'NameIdPolicy' is
-- 'NameIDFUnspecified'.
--
-- We do not use XML encryption (which appears to have been dead for years).  We do not sign
-- 'AuthnRequest' values.  Both encryption and signatures are optional, and rarely found in the
-- wild.  Security: (1) the 'AuthnReq' 'ID' is stored, and 'Assertion's need to refer to a valid one
-- in order to get a positive 'AccessVerdict' by 'judge'.  'AuthnResponse's answering requests not
-- originating from us will be ignored.  (2) the request 'Issuer' is there to help the IdP construct
-- an 'AuthnResponse' that we will accept.  If it is changed by an attacker (either in the browser
-- or on the wire, which is weakly procted by TLS) and passed on to the legitimate IdP, there will
-- either be no access-granting 'AuthnResponse', or it will contain the wrong audience and be
-- rejected by us.  (3) The nameID policy is expected to be configured on the IdP side to not
-- support any set of name spaces that overlap (e.g. because user A has an email that is the account
-- name of user B).
createAuthnRequest :: (Monad m, SP m, SPStore m) => NominalDiffTime -> m Issuer -> m AuthnRequest
createAuthnRequest :: forall (m :: * -> *).
(Monad m, SP m, SPStore m) =>
NominalDiffTime -> m Issuer -> m AuthnRequest
createAuthnRequest NominalDiffTime
lifeExpectancySecs m Issuer
getIssuer = do
  ID AuthnRequest
_rqID <- m (ID AuthnRequest)
forall {k} (m :: * -> *) (a :: k). (Functor m, SP m) => m (ID a)
createID
  Time
_rqIssueInstant <- m Time
forall (m :: * -> *). HasNow m => m Time
getNow
  Issuer
_rqIssuer <- m Issuer
getIssuer
  let _rqNameIDPolicy :: Maybe NameIdPolicy
_rqNameIDPolicy = NameIdPolicy -> Maybe NameIdPolicy
forall a. a -> Maybe a
Just (NameIdPolicy -> Maybe NameIdPolicy)
-> NameIdPolicy -> Maybe NameIdPolicy
forall a b. (a -> b) -> a -> b
$ NameIDFormat -> Maybe XmlText -> Bool -> NameIdPolicy
NameIdPolicy NameIDFormat
NameIDFUnspecified Maybe XmlText
forall a. Maybe a
Nothing Bool
True
  ID AuthnRequest -> Time -> m ()
forall {k} (i :: k) (m :: * -> *).
SPStoreID i m =>
ID i -> Time -> m ()
storeID ID AuthnRequest
_rqID (NominalDiffTime -> Time -> Time
addTime NominalDiffTime
lifeExpectancySecs Time
_rqIssueInstant)
  AuthnRequest -> m AuthnRequest
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthnRequest {Maybe NameIdPolicy
ID AuthnRequest
Time
Issuer
_rqID :: ID AuthnRequest
_rqIssueInstant :: Time
_rqIssuer :: Issuer
_rqNameIDPolicy :: Maybe NameIdPolicy
_rqID :: ID AuthnRequest
_rqIssueInstant :: Time
_rqIssuer :: Issuer
_rqNameIDPolicy :: Maybe NameIdPolicy
..}

-- | The clock drift between IdP and us that we allow for.
--
-- FUTUREWORK: make this configurable
tolerance :: NominalDiffTime
tolerance :: NominalDiffTime
tolerance = NominalDiffTime
60 -- seconds; must be positive

-- | First arg must be comfortably earlier than the latter: if 'tolerance' is one minute, then
-- @("4:32:14" `earlier` "4:31:15") == True@.
--
-- If this returns 'False' you should be *more* inclined to throw an error, so a good calling
-- pattern is @unless (a `earlier` b) throwSomething@, which is very different from @when (b
-- `earlier` a) throwSomething@.
earlier :: Time -> Time -> Bool
earlier :: Time -> Time -> Bool
earlier Time
early Time
late = Time
early Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime -> Time -> Time
addTime NominalDiffTime
tolerance Time
late

-- | Even though this makes little sense, the standard requires to distinguish between "less"
-- and "less or equal".  For all practical purposes, you may consider @noLater == earlier@.
noLater :: Time -> Time -> Bool
noLater :: Time -> Time -> Bool
noLater Time
early Time
late = Time
early Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime -> Time -> Time
addTime NominalDiffTime
tolerance Time
late

----------------------------------------------------------------------
-- paths

getSsoURI ::
  forall m endpoint api.
  ( HasCallStack,
    Functor m,
    HasConfig m,
    IsElem endpoint api,
    HasLink endpoint,
    ToHttpApiData (MkLink endpoint)
  ) =>
  Proxy api ->
  Proxy endpoint ->
  m URI
getSsoURI :: forall (m :: * -> *) endpoint api.
(HasCallStack, Functor m, HasConfig m, IsElem endpoint api,
 HasLink endpoint, ToHttpApiData (MkLink endpoint)) =>
Proxy api -> Proxy endpoint -> m URI
getSsoURI Proxy api
proxyAPI Proxy endpoint
proxyAPIAuthResp = URI -> URI
extpath (URI -> URI) -> (Config -> URI) -> Config -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Getting URI Config URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI Config URI
Lens' Config URI
cfgSPSsoURI) (Config -> URI) -> m Config -> m URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Config
forall (m :: * -> *). HasConfig m => m Config
getConfig
  where
    extpath :: URI -> URI
    extpath :: URI -> URI
extpath = (HasCallStack => URI -> ST -> URI
URI -> ST -> URI
=/ (ST -> ST
forall a b. ConvertibleStrings a b => a -> b
cs (ST -> ST) -> (MkLink endpoint -> ST) -> MkLink endpoint -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MkLink endpoint -> ST
forall a. ToHttpApiData a => a -> ST
toUrlPiece (MkLink endpoint -> ST) -> MkLink endpoint -> ST
forall a b. (a -> b) -> a -> b
$ Proxy api -> Proxy endpoint -> MkLink endpoint
forall endpoint api.
(IsElem endpoint api, HasLink endpoint) =>
Proxy api -> Proxy endpoint -> MkLink endpoint Link
safeLink Proxy api
proxyAPI Proxy endpoint
proxyAPIAuthResp))

-- | 'getSsoURI' for links that have one variable path segment.
--
-- FUTUREWORK: this is only sometimes what we need.  it would be nice to have a type class with a
-- method 'getSsoURI' for arbitrary path arities.
getSsoURI' ::
  forall endpoint api a (f :: Type -> Type) t.
  ( Functor f,
    HasConfig f,
    MkLink endpoint ~ (t -> a),
    HasLink endpoint,
    ToHttpApiData a,
    IsElem endpoint api
  ) =>
  Proxy api ->
  Proxy endpoint ->
  t ->
  f URI
getSsoURI' :: forall endpoint api a (f :: * -> *) t.
(Functor f, HasConfig f, MkLink endpoint ~ (t -> a),
 HasLink endpoint, ToHttpApiData a, IsElem endpoint api) =>
Proxy api -> Proxy endpoint -> t -> f URI
getSsoURI' Proxy api
proxyAPI Proxy endpoint
proxyAPIAuthResp t
idpid = URI -> URI
extpath (URI -> URI) -> (Config -> URI) -> Config -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Getting URI Config URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI Config URI
Lens' Config URI
cfgSPSsoURI) (Config -> URI) -> f Config -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Config
forall (m :: * -> *). HasConfig m => m Config
getConfig
  where
    extpath :: URI -> URI
    extpath :: URI -> URI
extpath = (HasCallStack => URI -> ST -> URI
URI -> ST -> URI
=/ (ST -> ST
forall a b. ConvertibleStrings a b => a -> b
cs (ST -> ST) -> (a -> ST) -> a -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ST
forall a. ToHttpApiData a => a -> ST
toUrlPiece (a -> ST) -> a -> ST
forall a b. (a -> b) -> a -> b
$ Proxy api -> Proxy endpoint -> MkLink endpoint
forall endpoint api.
(IsElem endpoint api, HasLink endpoint) =>
Proxy api -> Proxy endpoint -> MkLink endpoint Link
safeLink Proxy api
proxyAPI Proxy endpoint
proxyAPIAuthResp t
idpid))

----------------------------------------------------------------------
-- compute access verdict(s)

-- | This monad collects errors in a writer, so that the reasons for access denial are as helpful as
-- possible.  It is a little like an exception monad, except you can throw several exceptions
-- without interrupting the flow, and will get a list of them at the end.
--
-- NOTE: @-XGeneralizedNewtypeDeriving@ does not help with the boilerplate instances below, since
-- this is a transformer stack and not a concrete 'Monad'.
newtype JudgeT m a = JudgeT
  {forall (m :: * -> *) a.
JudgeT m a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
fromJudgeT :: ExceptT DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a}

-- | Note on security: we assume that the SP has only one audience, which is defined here.  If you
-- have different sub-services running on your SP, associate a dedicated IdP with each sub-service.
-- (To be more specific, construct 'AuthnReq's to different IdPs for each sub-service.)  Secure
-- association with the service can then be guaranteed via the 'Issuer' in the signed 'Assertion'.
data JudgeCtx = JudgeCtx
  { JudgeCtx -> Issuer
_judgeCtxAudience :: Issuer,
    JudgeCtx -> URI
_judgeCtxResponseURI :: URI
  }
  deriving (JudgeCtx -> JudgeCtx -> Bool
(JudgeCtx -> JudgeCtx -> Bool)
-> (JudgeCtx -> JudgeCtx -> Bool) -> Eq JudgeCtx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JudgeCtx -> JudgeCtx -> Bool
== :: JudgeCtx -> JudgeCtx -> Bool
$c/= :: JudgeCtx -> JudgeCtx -> Bool
/= :: JudgeCtx -> JudgeCtx -> Bool
Eq, Int -> JudgeCtx -> ShowS
[JudgeCtx] -> ShowS
JudgeCtx -> String
(Int -> JudgeCtx -> ShowS)
-> (JudgeCtx -> String) -> ([JudgeCtx] -> ShowS) -> Show JudgeCtx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JudgeCtx -> ShowS
showsPrec :: Int -> JudgeCtx -> ShowS
$cshow :: JudgeCtx -> String
show :: JudgeCtx -> String
$cshowList :: [JudgeCtx] -> ShowS
showList :: [JudgeCtx] -> ShowS
Show)

makeLenses ''JudgeCtx

runJudgeT :: forall m. (Monad m, SP m) => JudgeCtx -> JudgeT m AccessVerdict -> m AccessVerdict
runJudgeT :: forall (m :: * -> *).
(Monad m, SP m) =>
JudgeCtx -> JudgeT m AccessVerdict -> m AccessVerdict
runJudgeT JudgeCtx
ctx (JudgeT ExceptT
  DeniedReason
  (WriterT [DeniedReason] (ReaderT JudgeCtx m))
  AccessVerdict
em) = ((Either DeniedReason AccessVerdict, [DeniedReason])
 -> AccessVerdict)
-> m (Either DeniedReason AccessVerdict, [DeniedReason])
-> m AccessVerdict
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either DeniedReason AccessVerdict, [DeniedReason])
-> AccessVerdict
collectErrors (m (Either DeniedReason AccessVerdict, [DeniedReason])
 -> m AccessVerdict)
-> (WriterT
      [DeniedReason]
      (ReaderT JudgeCtx m)
      (Either DeniedReason AccessVerdict)
    -> m (Either DeniedReason AccessVerdict, [DeniedReason]))
-> WriterT
     [DeniedReason]
     (ReaderT JudgeCtx m)
     (Either DeniedReason AccessVerdict)
-> m AccessVerdict
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT
  JudgeCtx m (Either DeniedReason AccessVerdict, [DeniedReason])
-> JudgeCtx
-> m (Either DeniedReason AccessVerdict, [DeniedReason])
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` JudgeCtx
ctx) (ReaderT
   JudgeCtx m (Either DeniedReason AccessVerdict, [DeniedReason])
 -> m (Either DeniedReason AccessVerdict, [DeniedReason]))
-> (WriterT
      [DeniedReason]
      (ReaderT JudgeCtx m)
      (Either DeniedReason AccessVerdict)
    -> ReaderT
         JudgeCtx m (Either DeniedReason AccessVerdict, [DeniedReason]))
-> WriterT
     [DeniedReason]
     (ReaderT JudgeCtx m)
     (Either DeniedReason AccessVerdict)
-> m (Either DeniedReason AccessVerdict, [DeniedReason])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT
  [DeniedReason]
  (ReaderT JudgeCtx m)
  (Either DeniedReason AccessVerdict)
-> ReaderT
     JudgeCtx m (Either DeniedReason AccessVerdict, [DeniedReason])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT
   [DeniedReason]
   (ReaderT JudgeCtx m)
   (Either DeniedReason AccessVerdict)
 -> m AccessVerdict)
-> WriterT
     [DeniedReason]
     (ReaderT JudgeCtx m)
     (Either DeniedReason AccessVerdict)
-> m AccessVerdict
forall a b. (a -> b) -> a -> b
$ ExceptT
  DeniedReason
  (WriterT [DeniedReason] (ReaderT JudgeCtx m))
  AccessVerdict
-> WriterT
     [DeniedReason]
     (ReaderT JudgeCtx m)
     (Either DeniedReason AccessVerdict)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
  DeniedReason
  (WriterT [DeniedReason] (ReaderT JudgeCtx m))
  AccessVerdict
em
  where
    collectErrors :: (Either DeniedReason AccessVerdict, [DeniedReason]) -> AccessVerdict
    collectErrors :: (Either DeniedReason AccessVerdict, [DeniedReason])
-> AccessVerdict
collectErrors (Left DeniedReason
err, [DeniedReason]
errs') = [DeniedReason] -> AccessVerdict
AccessDenied ([DeniedReason] -> AccessVerdict)
-> [DeniedReason] -> AccessVerdict
forall a b. (a -> b) -> a -> b
$ DeniedReason
err DeniedReason -> [DeniedReason] -> [DeniedReason]
forall a. a -> [a] -> [a]
: [DeniedReason]
errs'
    collectErrors (Right AccessVerdict
_, errs :: [DeniedReason]
errs@(DeniedReason
_ : [DeniedReason]
_)) = [DeniedReason] -> AccessVerdict
AccessDenied [DeniedReason]
errs
    collectErrors (Right AccessVerdict
v, []) = AccessVerdict
v

-- the parts of the MonadError, MonadWriter interfaces we want here.
class (Functor m, Applicative m, Monad m) => MonadJudge m where
  getJudgeCtx :: m JudgeCtx
  deny :: DeniedReason -> m ()
  giveup :: DeniedReason -> m a

instance (Functor m, Applicative m, Monad m) => MonadJudge (JudgeT m) where
  getJudgeCtx :: JudgeT m JudgeCtx
getJudgeCtx = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) JudgeCtx
-> JudgeT m JudgeCtx
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) JudgeCtx
 -> JudgeT m JudgeCtx)
-> (ReaderT JudgeCtx m JudgeCtx
    -> ExceptT
         DeniedReason
         (WriterT [DeniedReason] (ReaderT JudgeCtx m))
         JudgeCtx)
-> ReaderT JudgeCtx m JudgeCtx
-> JudgeT m JudgeCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [DeniedReason] (ReaderT JudgeCtx m) JudgeCtx
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) JudgeCtx
forall (m :: * -> *) a. Monad m => m a -> ExceptT DeniedReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [DeniedReason] (ReaderT JudgeCtx m) JudgeCtx
 -> ExceptT
      DeniedReason
      (WriterT [DeniedReason] (ReaderT JudgeCtx m))
      JudgeCtx)
-> (ReaderT JudgeCtx m JudgeCtx
    -> WriterT [DeniedReason] (ReaderT JudgeCtx m) JudgeCtx)
-> ReaderT JudgeCtx m JudgeCtx
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) JudgeCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT JudgeCtx m JudgeCtx
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) JudgeCtx
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [DeniedReason] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT JudgeCtx m JudgeCtx -> JudgeT m JudgeCtx)
-> ReaderT JudgeCtx m JudgeCtx -> JudgeT m JudgeCtx
forall a b. (a -> b) -> a -> b
$ ReaderT JudgeCtx m JudgeCtx
forall r (m :: * -> *). MonadReader r m => m r
ask
  deny :: DeniedReason -> JudgeT m ()
deny = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
-> JudgeT m ()
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
 -> JudgeT m ())
-> (DeniedReason
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ())
-> DeniedReason
-> JudgeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DeniedReason]
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([DeniedReason]
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ())
-> (DeniedReason -> [DeniedReason])
-> DeniedReason
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeniedReason -> [DeniedReason] -> [DeniedReason]
forall a. a -> [a] -> [a]
: [])
  giveup :: forall a. DeniedReason -> JudgeT m a
giveup = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
 -> JudgeT m a)
-> (DeniedReason
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a)
-> DeniedReason
-> JudgeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
forall a.
DeniedReason
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

instance (Functor m, Applicative m, Monad m) => Functor (JudgeT m) where
  fmap :: forall a b. (a -> b) -> JudgeT m a -> JudgeT m b
fmap a -> b
f = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
-> JudgeT m b
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
 -> JudgeT m b)
-> (JudgeT m a
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b)
-> JudgeT m a
-> JudgeT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b)
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
forall a b.
(a -> b)
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b)
-> (JudgeT m a
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a)
-> JudgeT m a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JudgeT m a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
forall (m :: * -> *) a.
JudgeT m a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
fromJudgeT

instance (Functor m, Applicative m, Monad m) => Applicative (JudgeT m) where
  pure :: forall a. a -> JudgeT m a
pure = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
 -> JudgeT m a)
-> (a
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a)
-> a
-> JudgeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
forall a.
a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (JudgeT ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) (a -> b)
f) <*> :: forall a b. JudgeT m (a -> b) -> JudgeT m a -> JudgeT m b
<*> (JudgeT ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
x) = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
-> JudgeT m b
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) (a -> b)
f ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) (a -> b)
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
forall a b.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) (a -> b)
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
x)

instance (Functor m, Applicative m, Monad m) => Monad (JudgeT m) where
  (JudgeT ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
x) >>= :: forall a b. JudgeT m a -> (a -> JudgeT m b) -> JudgeT m b
>>= a -> JudgeT m b
f = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
-> JudgeT m b
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
x ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> (a
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b)
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
forall a b.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> (a
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b)
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JudgeT m b
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
forall (m :: * -> *) a.
JudgeT m a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
fromJudgeT (JudgeT m b
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b)
-> (a -> JudgeT m b)
-> a
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> JudgeT m b
f)

instance (Monad m, HasConfig m) => HasConfig (JudgeT m) where
  getConfig :: JudgeT m Config
getConfig = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Config
-> JudgeT m Config
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Config
 -> JudgeT m Config)
-> (m Config
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Config)
-> m Config
-> JudgeT m Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [DeniedReason] (ReaderT JudgeCtx m) Config
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Config
forall (m :: * -> *) a. Monad m => m a -> ExceptT DeniedReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [DeniedReason] (ReaderT JudgeCtx m) Config
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Config)
-> (m Config -> WriterT [DeniedReason] (ReaderT JudgeCtx m) Config)
-> m Config
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT JudgeCtx m Config
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) Config
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [DeniedReason] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT JudgeCtx m Config
 -> WriterT [DeniedReason] (ReaderT JudgeCtx m) Config)
-> (m Config -> ReaderT JudgeCtx m Config)
-> m Config
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Config -> ReaderT JudgeCtx m Config
forall (m :: * -> *) a. Monad m => m a -> ReaderT JudgeCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Config -> JudgeT m Config) -> m Config -> JudgeT m Config
forall a b. (a -> b) -> a -> b
$ m Config
forall (m :: * -> *). HasConfig m => m Config
getConfig

instance (Monad m, HasLogger m) => HasLogger (JudgeT m) where
  logger :: Level -> String -> JudgeT m ()
logger Level
level = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
-> JudgeT m ()
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
 -> JudgeT m ())
-> (String
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ())
-> String
-> JudgeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT DeniedReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ())
-> (String -> WriterT [DeniedReason] (ReaderT JudgeCtx m) ())
-> String
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT JudgeCtx m ()
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [DeniedReason] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT JudgeCtx m ()
 -> WriterT [DeniedReason] (ReaderT JudgeCtx m) ())
-> (String -> ReaderT JudgeCtx m ())
-> String
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> ReaderT JudgeCtx m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT JudgeCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT JudgeCtx m ())
-> (String -> m ()) -> String -> ReaderT JudgeCtx m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Level -> String -> m ()
forall (m :: * -> *). HasLogger m => Level -> String -> m ()
logger Level
level

instance (Monad m, HasCreateUUID m) => HasCreateUUID (JudgeT m) where
  createUUID :: JudgeT m UUID
createUUID = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) UUID
-> JudgeT m UUID
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) UUID
 -> JudgeT m UUID)
-> (m UUID
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) UUID)
-> m UUID
-> JudgeT m UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [DeniedReason] (ReaderT JudgeCtx m) UUID
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) UUID
forall (m :: * -> *) a. Monad m => m a -> ExceptT DeniedReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [DeniedReason] (ReaderT JudgeCtx m) UUID
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) UUID)
-> (m UUID -> WriterT [DeniedReason] (ReaderT JudgeCtx m) UUID)
-> m UUID
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT JudgeCtx m UUID
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) UUID
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [DeniedReason] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT JudgeCtx m UUID
 -> WriterT [DeniedReason] (ReaderT JudgeCtx m) UUID)
-> (m UUID -> ReaderT JudgeCtx m UUID)
-> m UUID
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m UUID -> ReaderT JudgeCtx m UUID
forall (m :: * -> *) a. Monad m => m a -> ReaderT JudgeCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m UUID -> JudgeT m UUID) -> m UUID -> JudgeT m UUID
forall a b. (a -> b) -> a -> b
$ m UUID
forall (m :: * -> *). HasCreateUUID m => m UUID
createUUID

instance (Monad m, HasNow m) => HasNow (JudgeT m) where
  getNow :: JudgeT m Time
getNow = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Time
-> JudgeT m Time
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Time
 -> JudgeT m Time)
-> (m Time
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Time)
-> m Time
-> JudgeT m Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [DeniedReason] (ReaderT JudgeCtx m) Time
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Time
forall (m :: * -> *) a. Monad m => m a -> ExceptT DeniedReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [DeniedReason] (ReaderT JudgeCtx m) Time
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Time)
-> (m Time -> WriterT [DeniedReason] (ReaderT JudgeCtx m) Time)
-> m Time
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT JudgeCtx m Time
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) Time
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [DeniedReason] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT JudgeCtx m Time
 -> WriterT [DeniedReason] (ReaderT JudgeCtx m) Time)
-> (m Time -> ReaderT JudgeCtx m Time)
-> m Time
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Time -> ReaderT JudgeCtx m Time
forall (m :: * -> *) a. Monad m => m a -> ReaderT JudgeCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Time -> JudgeT m Time) -> m Time -> JudgeT m Time
forall a b. (a -> b) -> a -> b
$ m Time
forall (m :: * -> *). HasNow m => m Time
getNow

instance (Monad m, SPStoreID i m) => SPStoreID i (JudgeT m) where
  storeID :: ID i -> Time -> JudgeT m ()
storeID ID i
item = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
-> JudgeT m ()
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
 -> JudgeT m ())
-> (Time
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ())
-> Time
-> JudgeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT DeniedReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ())
-> (Time -> WriterT [DeniedReason] (ReaderT JudgeCtx m) ())
-> Time
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT JudgeCtx m ()
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [DeniedReason] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT JudgeCtx m ()
 -> WriterT [DeniedReason] (ReaderT JudgeCtx m) ())
-> (Time -> ReaderT JudgeCtx m ())
-> Time
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> ReaderT JudgeCtx m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT JudgeCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT JudgeCtx m ())
-> (Time -> m ()) -> Time -> ReaderT JudgeCtx m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID i -> Time -> m ()
forall {k} (i :: k) (m :: * -> *).
SPStoreID i m =>
ID i -> Time -> m ()
storeID ID i
item
  unStoreID :: ID i -> JudgeT m ()
unStoreID = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
-> JudgeT m ()
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
 -> JudgeT m ())
-> (ID i
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ())
-> ID i
-> JudgeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT DeniedReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ())
-> (ID i -> WriterT [DeniedReason] (ReaderT JudgeCtx m) ())
-> ID i
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT JudgeCtx m ()
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [DeniedReason] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT JudgeCtx m ()
 -> WriterT [DeniedReason] (ReaderT JudgeCtx m) ())
-> (ID i -> ReaderT JudgeCtx m ())
-> ID i
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> ReaderT JudgeCtx m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT JudgeCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT JudgeCtx m ())
-> (ID i -> m ()) -> ID i -> ReaderT JudgeCtx m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID i -> m ()
forall {k} (i :: k) (m :: * -> *). SPStoreID i m => ID i -> m ()
unStoreID
  isAliveID :: ID i -> JudgeT m Bool
isAliveID = ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Bool
-> JudgeT m Bool
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Bool
 -> JudgeT m Bool)
-> (ID i
    -> ExceptT
         DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Bool)
-> ID i
-> JudgeT m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [DeniedReason] (ReaderT JudgeCtx m) Bool
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT DeniedReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [DeniedReason] (ReaderT JudgeCtx m) Bool
 -> ExceptT
      DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Bool)
-> (ID i -> WriterT [DeniedReason] (ReaderT JudgeCtx m) Bool)
-> ID i
-> ExceptT
     DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT JudgeCtx m Bool
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) Bool
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [DeniedReason] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT JudgeCtx m Bool
 -> WriterT [DeniedReason] (ReaderT JudgeCtx m) Bool)
-> (ID i -> ReaderT JudgeCtx m Bool)
-> ID i
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Bool -> ReaderT JudgeCtx m Bool
forall (m :: * -> *) a. Monad m => m a -> ReaderT JudgeCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ReaderT JudgeCtx m Bool)
-> (ID i -> m Bool) -> ID i -> ReaderT JudgeCtx m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID i -> m Bool
forall {k} (i :: k) (m :: * -> *). SPStoreID i m => ID i -> m Bool
isAliveID

-- | [3/4.1.4.2], [3/4.1.4.3]; specific to active-directory:
-- <https://docs.microsoft.com/en-us/azure/active-directory/develop/active-directory-single-sign-on-protocol-reference>
--
-- 'judge' does not consider the following parts of the 'AuthnResponse'.
--  * 'subjectID'
--  * 'scdAddress' ("If any bearer <SubjectConfirmationData> includes an Address attribute, the
--    service provider MAY check the user agent's client address against it."  [3/4.1.4.3])
--  * 'astSessionIndex'
--  * 'astSubjectLocality' ("This element is entirely advisory, since both of these fields are
--    quite easily “spoofed,” but may be useful information in some applications." [1/2.7.2.1])
--
-- 'judge' does check the 'rspStatus' field, even though that makes no sense: most IdPs encrypt the
-- 'Assertion's, but not the entire response, and we make taht an assumption when validating
-- signatures.  So the status info is not signed, and could easily be changed by an attacker
-- attempting to authenticate.
judge :: (Monad m, SP m, SPStore m) => AuthnResponse -> JudgeCtx -> m AccessVerdict
judge :: forall (m :: * -> *).
(Monad m, SP m, SPStore m) =>
AuthnResponse -> JudgeCtx -> m AccessVerdict
judge AuthnResponse
resp JudgeCtx
ctx = JudgeCtx -> JudgeT m AccessVerdict -> m AccessVerdict
forall (m :: * -> *).
(Monad m, SP m) =>
JudgeCtx -> JudgeT m AccessVerdict -> m AccessVerdict
runJudgeT JudgeCtx
ctx (AuthnResponse -> JudgeT m AccessVerdict
forall (m :: * -> *).
(HasCallStack, MonadJudge m, SP m, SPStore m) =>
AuthnResponse -> m AccessVerdict
judge' AuthnResponse
resp)

judge' :: (HasCallStack, MonadJudge m, SP m, SPStore m) => AuthnResponse -> m AccessVerdict
judge' :: forall (m :: * -> *).
(HasCallStack, MonadJudge m, SP m, SPStore m) =>
AuthnResponse -> m AccessVerdict
judge' AuthnResponse
resp = do
  case AuthnResponse
resp AuthnResponse -> Getting Status AuthnResponse Status -> Status
forall s a. s -> Getting a s a -> a
^. Getting Status AuthnResponse Status
forall payload (f :: * -> *).
Functor f =>
(Status -> f Status) -> Response payload -> f (Response payload)
rspStatus of
    Status
StatusSuccess -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Status
StatusFailure -> DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny DeniedReason
DeniedStatusFailure
  UserRef
uref <- (String -> m UserRef)
-> (UserRef -> m UserRef) -> Either String UserRef -> m UserRef
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (DeniedReason -> m UserRef
forall a. DeniedReason -> m a
forall (m :: * -> *) a. MonadJudge m => DeniedReason -> m a
giveup (DeniedReason -> m UserRef)
-> (String -> DeniedReason) -> String -> m UserRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DeniedReason
DeniedBadUserRefs) UserRef -> m UserRef
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String UserRef -> m UserRef)
-> Either String UserRef -> m UserRef
forall a b. (a -> b) -> a -> b
$ AuthnResponse -> Either String UserRef
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AuthnResponse -> m UserRef
getUserRef AuthnResponse
resp
  ID AuthnRequest
inRespTo <- (String -> m (ID AuthnRequest))
-> (ID AuthnRequest -> m (ID AuthnRequest))
-> Either String (ID AuthnRequest)
-> m (ID AuthnRequest)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (DeniedReason -> m (ID AuthnRequest)
forall a. DeniedReason -> m a
forall (m :: * -> *) a. MonadJudge m => DeniedReason -> m a
giveup (DeniedReason -> m (ID AuthnRequest))
-> (String -> DeniedReason) -> String -> m (ID AuthnRequest)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DeniedReason
DeniedBadInResponseTos) ID AuthnRequest -> m (ID AuthnRequest)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (ID AuthnRequest) -> m (ID AuthnRequest))
-> Either String (ID AuthnRequest) -> m (ID AuthnRequest)
forall a b. (a -> b) -> a -> b
$ AuthnResponse -> Either String (ID AuthnRequest)
forall (m :: * -> *).
MonadError String m =>
AuthnResponse -> m (ID AuthnRequest)
rspInResponseTo AuthnResponse
resp
  String -> ID AuthnRequest -> m ()
forall (m :: * -> *).
(SPStore m, MonadJudge m) =>
String -> ID AuthnRequest -> m ()
checkInResponseTo String
"response" ID AuthnRequest
inRespTo
  (Time -> Time -> DeniedReason) -> Time -> m ()
forall (m :: * -> *).
(SP m, MonadJudge m) =>
(Time -> Time -> DeniedReason) -> Time -> m ()
checkIsInPast Time -> Time -> DeniedReason
DeniedIssueInstantNotInPast (Time -> m ()) -> Time -> m ()
forall a b. (a -> b) -> a -> b
$ AuthnResponse
resp AuthnResponse -> Getting Time AuthnResponse Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time AuthnResponse Time
forall payload (f :: * -> *).
Functor f =>
(Time -> f Time) -> Response payload -> f (Response payload)
rspIssueInstant
  m () -> (URI -> m ()) -> Maybe URI -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((String -> String -> DeniedReason) -> URI -> m ()
forall (m :: * -> *).
(HasConfig m, MonadJudge m) =>
(String -> String -> DeniedReason) -> URI -> m ()
checkDestination String -> String -> DeniedReason
DeniedBadDestination) (AuthnResponse
resp AuthnResponse
-> Getting (Maybe URI) AuthnResponse (Maybe URI) -> Maybe URI
forall s a. s -> Getting a s a -> a
^. Getting (Maybe URI) AuthnResponse (Maybe URI)
forall payload (f :: * -> *).
Functor f =>
(Maybe URI -> f (Maybe URI))
-> Response payload -> f (Response payload)
rspDestination)
  AccessVerdict
verdict <- Maybe Issuer -> NonEmpty Assertion -> UserRef -> m AccessVerdict
forall (m :: * -> *).
(SP m, SPStore m, MonadJudge m) =>
Maybe Issuer -> NonEmpty Assertion -> UserRef -> m AccessVerdict
checkAssertions (AuthnResponse
resp AuthnResponse
-> Getting (Maybe Issuer) AuthnResponse (Maybe Issuer)
-> Maybe Issuer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Issuer) AuthnResponse (Maybe Issuer)
forall payload (f :: * -> *).
Functor f =>
(Maybe Issuer -> f (Maybe Issuer))
-> Response payload -> f (Response payload)
rspIssuer) (AuthnResponse
resp AuthnResponse
-> Getting (NonEmpty Assertion) AuthnResponse (NonEmpty Assertion)
-> NonEmpty Assertion
forall s a. s -> Getting a s a -> a
^. Getting (NonEmpty Assertion) AuthnResponse (NonEmpty Assertion)
forall payload (f :: * -> *).
Functor f =>
(payload -> f payload) -> Response payload -> f (Response payload)
rspPayload) UserRef
uref
  ID AuthnRequest -> m ()
forall {k} (i :: k) (m :: * -> *). SPStoreID i m => ID i -> m ()
unStoreID ID AuthnRequest
inRespTo
  AccessVerdict -> m AccessVerdict
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AccessVerdict
verdict

-- | If this fails, we could continue ('deny'), but we stop processing ('giveup') to make DOS
-- attacks harder.
checkInResponseTo :: (SPStore m, MonadJudge m) => String -> ID AuthnRequest -> m ()
checkInResponseTo :: forall (m :: * -> *).
(SPStore m, MonadJudge m) =>
String -> ID AuthnRequest -> m ()
checkInResponseTo String
loc ID AuthnRequest
req = do
  Bool
ok <- ID AuthnRequest -> m Bool
forall {k} (i :: k) (m :: * -> *). SPStoreID i m => ID i -> m Bool
isAliveID ID AuthnRequest
req
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (m () -> m ()) -> (String -> m ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall a. DeniedReason -> m a
forall (m :: * -> *) a. MonadJudge m => DeniedReason -> m a
giveup (DeniedReason -> m ())
-> (String -> DeniedReason) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DeniedReason
DeniedBadInResponseTos (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
loc String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ID AuthnRequest -> String
forall a. Show a => a -> String
show ID AuthnRequest
req

checkIsInPast :: (SP m, MonadJudge m) => (Time -> Time -> DeniedReason) -> Time -> m ()
checkIsInPast :: forall (m :: * -> *).
(SP m, MonadJudge m) =>
(Time -> Time -> DeniedReason) -> Time -> m ()
checkIsInPast Time -> Time -> DeniedReason
err Time
tim = do
  Time
now <- m Time
forall (m :: * -> *). HasNow m => m Time
getNow
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Time
tim Time -> Time -> Bool
`earlier` Time
now) (m () -> m ()) -> (DeniedReason -> m ()) -> DeniedReason -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny (DeniedReason -> m ()) -> DeniedReason -> m ()
forall a b. (a -> b) -> a -> b
$ Time -> Time -> DeniedReason
err Time
tim Time
now

-- | Check that the response is intended for us (based on config's finalize-login uri stored in
-- 'JudgeCtx').
checkDestination :: (HasConfig m, MonadJudge m) => (String -> String -> DeniedReason) -> URI -> m ()
checkDestination :: forall (m :: * -> *).
(HasConfig m, MonadJudge m) =>
(String -> String -> DeniedReason) -> URI -> m ()
checkDestination String -> String -> DeniedReason
err (URI -> ST
renderURI -> ST
expectedByIdp) = do
  (URI -> ST
renderURI -> ST
expectedByUs) <- (JudgeCtx -> Getting URI JudgeCtx URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI JudgeCtx URI
Lens' JudgeCtx URI
judgeCtxResponseURI) (JudgeCtx -> URI) -> m JudgeCtx -> m URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m JudgeCtx
forall (m :: * -> *). MonadJudge m => m JudgeCtx
getJudgeCtx
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ST
expectedByUs ST -> ST -> Bool
forall a. Eq a => a -> a -> Bool
== ST
expectedByIdp) (m () -> m ()) -> (DeniedReason -> m ()) -> DeniedReason -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny (DeniedReason -> m ()) -> DeniedReason -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> DeniedReason
err (ST -> String
forall a b. ConvertibleStrings a b => a -> b
cs ST
expectedByUs) (ST -> String
forall a b. ConvertibleStrings a b => a -> b
cs ST
expectedByIdp)

checkAssertions :: (SP m, SPStore m, MonadJudge m) => Maybe Issuer -> NonEmpty Assertion -> UserRef -> m AccessVerdict
checkAssertions :: forall (m :: * -> *).
(SP m, SPStore m, MonadJudge m) =>
Maybe Issuer -> NonEmpty Assertion -> UserRef -> m AccessVerdict
checkAssertions Maybe Issuer
missuer (NonEmpty Assertion -> [Assertion]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [Assertion]
assertions) uref :: UserRef
uref@(UserRef Issuer
issuer NameID
_) = do
  [Assertion] -> (Assertion -> m Bool) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Assertion]
assertions ((Assertion -> m Bool) -> m ()) -> (Assertion -> m Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \Assertion
ass -> do
    (Time -> Time -> DeniedReason) -> Time -> m ()
forall (m :: * -> *).
(SP m, MonadJudge m) =>
(Time -> Time -> DeniedReason) -> Time -> m ()
checkIsInPast Time -> Time -> DeniedReason
DeniedAssertionIssueInstantNotInPast (Assertion
ass Assertion -> Getting Time Assertion Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time Assertion Time
Lens' Assertion Time
assIssueInstant)
    ID Assertion -> Time -> m Bool
forall (m :: * -> *).
(Monad m, SPStore m) =>
ID Assertion -> Time -> m Bool
storeAssertion (Assertion
ass Assertion
-> Getting (ID Assertion) Assertion (ID Assertion) -> ID Assertion
forall s a. s -> Getting a s a -> a
^. Getting (ID Assertion) Assertion (ID Assertion)
Lens' Assertion (ID Assertion)
assID) (Assertion
ass Assertion -> Getting Time Assertion Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time Assertion Time
Lens' Assertion Time
assEndOfLife)
  Conditions -> m ()
forall (m :: * -> *).
(HasCallStack, MonadJudge m, SP m) =>
Conditions -> m ()
checkConditions (Conditions -> m ()) -> [Conditions] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [Maybe Conditions] -> [Conditions]
forall a. [Maybe a] -> [a]
catMaybes ((Assertion
-> Getting (Maybe Conditions) Assertion (Maybe Conditions)
-> Maybe Conditions
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Conditions) Assertion (Maybe Conditions)
Lens' Assertion (Maybe Conditions)
assConditions) (Assertion -> Maybe Conditions)
-> [Assertion] -> [Maybe Conditions]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Assertion]
assertions)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> (Issuer -> Bool) -> Maybe Issuer -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Issuer
issuer Issuer -> Issuer -> Bool
forall a. Eq a => a -> a -> Bool
==) Maybe Issuer
missuer) (m () -> m ()) -> (DeniedReason -> m ()) -> DeniedReason -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny (DeniedReason -> m ()) -> DeniedReason -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Issuer -> Issuer -> DeniedReason
DeniedIssuerMismatch Maybe Issuer
missuer Issuer
issuer
  [Assertion] -> m ()
forall (m :: * -> *).
(SP m, SPStore m, MonadJudge m) =>
[Assertion] -> m ()
checkSubjectConfirmations [Assertion]
assertions
  let statements :: [Statement]
      statements :: [Statement]
statements = [[Statement]] -> [Statement]
forall a. Monoid a => [a] -> a
mconcat ([[Statement]] -> [Statement]) -> [[Statement]] -> [Statement]
forall a b. (a -> b) -> a -> b
$ (Assertion
-> Getting [Statement] Assertion [Statement] -> [Statement]
forall s a. s -> Getting a s a -> a
^. (SubjectAndStatements -> Const [Statement] SubjectAndStatements)
-> Assertion -> Const [Statement] Assertion
Lens' Assertion SubjectAndStatements
assContents ((SubjectAndStatements -> Const [Statement] SubjectAndStatements)
 -> Assertion -> Const [Statement] Assertion)
-> (([Statement] -> Const [Statement] [Statement])
    -> SubjectAndStatements -> Const [Statement] SubjectAndStatements)
-> Getting [Statement] Assertion [Statement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Statement -> Const [Statement] (NonEmpty Statement))
-> SubjectAndStatements -> Const [Statement] SubjectAndStatements
Lens' SubjectAndStatements (NonEmpty Statement)
sasStatements ((NonEmpty Statement -> Const [Statement] (NonEmpty Statement))
 -> SubjectAndStatements -> Const [Statement] SubjectAndStatements)
-> (([Statement] -> Const [Statement] [Statement])
    -> NonEmpty Statement -> Const [Statement] (NonEmpty Statement))
-> ([Statement] -> Const [Statement] [Statement])
-> SubjectAndStatements
-> Const [Statement] SubjectAndStatements
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Statement -> [Statement])
-> ([Statement] -> Const [Statement] [Statement])
-> NonEmpty Statement
-> Const [Statement] (NonEmpty Statement)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to NonEmpty Statement -> [Statement]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) (Assertion -> [Statement]) -> [Assertion] -> [[Statement]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Assertion]
assertions
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Statement] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Statement]
statements) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny DeniedReason
DeniedNoStatements -- (not sure this is even possible?)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Statement -> Bool) -> [Statement] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Statement -> Bool
isAuthnStatement [Statement]
statements) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny DeniedReason
DeniedNoAuthnStatement
  Statement -> m ()
forall (m :: * -> *). (SP m, MonadJudge m) => Statement -> m ()
checkStatement (Statement -> m ()) -> [Statement] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [Statement]
statements
  AccessVerdict -> m AccessVerdict
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AccessVerdict -> m AccessVerdict)
-> AccessVerdict -> m AccessVerdict
forall a b. (a -> b) -> a -> b
$ UserRef -> AccessVerdict
AccessGranted UserRef
uref

checkStatement :: (SP m, MonadJudge m) => Statement -> m ()
checkStatement :: forall (m :: * -> *). (SP m, MonadJudge m) => Statement -> m ()
checkStatement Statement
stm =
  do
    let issued :: Time
issued = Statement
stm Statement -> Getting Time Statement Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time Statement Time
Lens' Statement Time
astAuthnInstant
        mtimeout :: Maybe Time
mtimeout = Statement
stm Statement
-> Getting (Maybe Time) Statement (Maybe Time) -> Maybe Time
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Time) Statement (Maybe Time)
Lens' Statement (Maybe Time)
astSessionNotOnOrAfter
    (Time -> Time -> DeniedReason) -> Time -> m ()
forall (m :: * -> *).
(SP m, MonadJudge m) =>
(Time -> Time -> DeniedReason) -> Time -> m ()
checkIsInPast Time -> Time -> DeniedReason
DeniedAuthnStatementIssueInstantNotInPast Time
issued
    Maybe Time -> (Time -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Time
mtimeout ((Time -> m ()) -> m ()) -> (Time -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Time
endoflife -> do
      Time
now <- m Time
forall (m :: * -> *). HasNow m => m Time
getNow
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Time
now Time -> Time -> Bool
`earlier` Time
endoflife) (m () -> m ()) -> (DeniedReason -> m ()) -> DeniedReason -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny (DeniedReason -> m ()) -> DeniedReason -> m ()
forall a b. (a -> b) -> a -> b
$ Time -> DeniedReason
DeniedAuthnStatmentExpiredAt Time
endoflife

-- | Check all 'SubjectConfirmation's and 'Subject's in all 'Assertion'.  Deny if not at least one
-- confirmation has method "bearer".
checkSubjectConfirmations :: (SP m, SPStore m, MonadJudge m) => [Assertion] -> m ()
checkSubjectConfirmations :: forall (m :: * -> *).
(SP m, SPStore m, MonadJudge m) =>
[Assertion] -> m ()
checkSubjectConfirmations [Assertion]
assertions = do
  [[HasBearerConfirmation]]
bearerFlags :: [[HasBearerConfirmation]] <- [Assertion]
-> (Assertion -> m [HasBearerConfirmation])
-> m [[HasBearerConfirmation]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Assertion]
assertions ((Assertion -> m [HasBearerConfirmation])
 -> m [[HasBearerConfirmation]])
-> (Assertion -> m [HasBearerConfirmation])
-> m [[HasBearerConfirmation]]
forall a b. (a -> b) -> a -> b
$
    \Assertion
assertion -> case Assertion
assertion Assertion -> Getting Subject Assertion Subject -> Subject
forall s a. s -> Getting a s a -> a
^. (SubjectAndStatements -> Const Subject SubjectAndStatements)
-> Assertion -> Const Subject Assertion
Lens' Assertion SubjectAndStatements
assContents ((SubjectAndStatements -> Const Subject SubjectAndStatements)
 -> Assertion -> Const Subject Assertion)
-> ((Subject -> Const Subject Subject)
    -> SubjectAndStatements -> Const Subject SubjectAndStatements)
-> Getting Subject Assertion Subject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Subject -> Const Subject Subject)
-> SubjectAndStatements -> Const Subject SubjectAndStatements
Lens' SubjectAndStatements Subject
sasSubject of
      Subject NameID
_ [SubjectConfirmation]
confs -> Assertion -> SubjectConfirmation -> m HasBearerConfirmation
forall (m :: * -> *).
(SPStore m, MonadJudge m) =>
Assertion -> SubjectConfirmation -> m HasBearerConfirmation
checkSubjectConfirmation Assertion
assertion (SubjectConfirmation -> m HasBearerConfirmation)
-> [SubjectConfirmation] -> m [HasBearerConfirmation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [SubjectConfirmation]
confs
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([HasBearerConfirmation] -> HasBearerConfirmation
forall a. Monoid a => [a] -> a
mconcat ([[HasBearerConfirmation]] -> [HasBearerConfirmation]
forall a. Monoid a => [a] -> a
mconcat [[HasBearerConfirmation]]
bearerFlags) HasBearerConfirmation -> HasBearerConfirmation -> Bool
forall a. Eq a => a -> a -> Bool
== HasBearerConfirmation
HasBearerConfirmation) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny DeniedReason
DeniedNoBearerConfSubj

data HasBearerConfirmation = HasBearerConfirmation | NoBearerConfirmation
  deriving (HasBearerConfirmation -> HasBearerConfirmation -> Bool
(HasBearerConfirmation -> HasBearerConfirmation -> Bool)
-> (HasBearerConfirmation -> HasBearerConfirmation -> Bool)
-> Eq HasBearerConfirmation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
== :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
$c/= :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
/= :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
Eq, Eq HasBearerConfirmation
Eq HasBearerConfirmation =>
(HasBearerConfirmation -> HasBearerConfirmation -> Ordering)
-> (HasBearerConfirmation -> HasBearerConfirmation -> Bool)
-> (HasBearerConfirmation -> HasBearerConfirmation -> Bool)
-> (HasBearerConfirmation -> HasBearerConfirmation -> Bool)
-> (HasBearerConfirmation -> HasBearerConfirmation -> Bool)
-> (HasBearerConfirmation
    -> HasBearerConfirmation -> HasBearerConfirmation)
-> (HasBearerConfirmation
    -> HasBearerConfirmation -> HasBearerConfirmation)
-> Ord HasBearerConfirmation
HasBearerConfirmation -> HasBearerConfirmation -> Bool
HasBearerConfirmation -> HasBearerConfirmation -> Ordering
HasBearerConfirmation
-> HasBearerConfirmation -> HasBearerConfirmation
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HasBearerConfirmation -> HasBearerConfirmation -> Ordering
compare :: HasBearerConfirmation -> HasBearerConfirmation -> Ordering
$c< :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
< :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
$c<= :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
<= :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
$c> :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
> :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
$c>= :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
>= :: HasBearerConfirmation -> HasBearerConfirmation -> Bool
$cmax :: HasBearerConfirmation
-> HasBearerConfirmation -> HasBearerConfirmation
max :: HasBearerConfirmation
-> HasBearerConfirmation -> HasBearerConfirmation
$cmin :: HasBearerConfirmation
-> HasBearerConfirmation -> HasBearerConfirmation
min :: HasBearerConfirmation
-> HasBearerConfirmation -> HasBearerConfirmation
Ord, HasBearerConfirmation
HasBearerConfirmation
-> HasBearerConfirmation -> Bounded HasBearerConfirmation
forall a. a -> a -> Bounded a
$cminBound :: HasBearerConfirmation
minBound :: HasBearerConfirmation
$cmaxBound :: HasBearerConfirmation
maxBound :: HasBearerConfirmation
Bounded, Int -> HasBearerConfirmation
HasBearerConfirmation -> Int
HasBearerConfirmation -> [HasBearerConfirmation]
HasBearerConfirmation -> HasBearerConfirmation
HasBearerConfirmation
-> HasBearerConfirmation -> [HasBearerConfirmation]
HasBearerConfirmation
-> HasBearerConfirmation
-> HasBearerConfirmation
-> [HasBearerConfirmation]
(HasBearerConfirmation -> HasBearerConfirmation)
-> (HasBearerConfirmation -> HasBearerConfirmation)
-> (Int -> HasBearerConfirmation)
-> (HasBearerConfirmation -> Int)
-> (HasBearerConfirmation -> [HasBearerConfirmation])
-> (HasBearerConfirmation
    -> HasBearerConfirmation -> [HasBearerConfirmation])
-> (HasBearerConfirmation
    -> HasBearerConfirmation -> [HasBearerConfirmation])
-> (HasBearerConfirmation
    -> HasBearerConfirmation
    -> HasBearerConfirmation
    -> [HasBearerConfirmation])
-> Enum HasBearerConfirmation
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: HasBearerConfirmation -> HasBearerConfirmation
succ :: HasBearerConfirmation -> HasBearerConfirmation
$cpred :: HasBearerConfirmation -> HasBearerConfirmation
pred :: HasBearerConfirmation -> HasBearerConfirmation
$ctoEnum :: Int -> HasBearerConfirmation
toEnum :: Int -> HasBearerConfirmation
$cfromEnum :: HasBearerConfirmation -> Int
fromEnum :: HasBearerConfirmation -> Int
$cenumFrom :: HasBearerConfirmation -> [HasBearerConfirmation]
enumFrom :: HasBearerConfirmation -> [HasBearerConfirmation]
$cenumFromThen :: HasBearerConfirmation
-> HasBearerConfirmation -> [HasBearerConfirmation]
enumFromThen :: HasBearerConfirmation
-> HasBearerConfirmation -> [HasBearerConfirmation]
$cenumFromTo :: HasBearerConfirmation
-> HasBearerConfirmation -> [HasBearerConfirmation]
enumFromTo :: HasBearerConfirmation
-> HasBearerConfirmation -> [HasBearerConfirmation]
$cenumFromThenTo :: HasBearerConfirmation
-> HasBearerConfirmation
-> HasBearerConfirmation
-> [HasBearerConfirmation]
enumFromThenTo :: HasBearerConfirmation
-> HasBearerConfirmation
-> HasBearerConfirmation
-> [HasBearerConfirmation]
Enum)

instance Monoid HasBearerConfirmation where
  mappend :: HasBearerConfirmation
-> HasBearerConfirmation -> HasBearerConfirmation
mappend = HasBearerConfirmation
-> HasBearerConfirmation -> HasBearerConfirmation
forall a. Semigroup a => a -> a -> a
(Data.Semigroup.<>)
  mempty :: HasBearerConfirmation
mempty = HasBearerConfirmation
forall a. Bounded a => a
maxBound

instance Data.Semigroup.Semigroup HasBearerConfirmation where
  <> :: HasBearerConfirmation
-> HasBearerConfirmation -> HasBearerConfirmation
(<>) = HasBearerConfirmation
-> HasBearerConfirmation -> HasBearerConfirmation
forall a. Ord a => a -> a -> a
min

-- | Locally check one 'SubjectConfirmation' and deny if there is a problem.  If this is a
-- confirmation of method "bearer", return 'HasBearerConfirmation'.
checkSubjectConfirmation :: (SPStore m, MonadJudge m) => Assertion -> SubjectConfirmation -> m HasBearerConfirmation
checkSubjectConfirmation :: forall (m :: * -> *).
(SPStore m, MonadJudge m) =>
Assertion -> SubjectConfirmation -> m HasBearerConfirmation
checkSubjectConfirmation Assertion
ass SubjectConfirmation
conf = do
  let bearer :: HasBearerConfirmation
bearer =
        if (SubjectConfirmation
conf SubjectConfirmation
-> Getting
     SubjectConfirmationMethod
     SubjectConfirmation
     SubjectConfirmationMethod
-> SubjectConfirmationMethod
forall s a. s -> Getting a s a -> a
^. Getting
  SubjectConfirmationMethod
  SubjectConfirmation
  SubjectConfirmationMethod
Lens' SubjectConfirmation SubjectConfirmationMethod
scMethod) SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== SubjectConfirmationMethod
SubjectConfirmationMethodBearer
          then HasBearerConfirmation
HasBearerConfirmation
          else HasBearerConfirmation
NoBearerConfirmation
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HasBearerConfirmation
bearer HasBearerConfirmation -> HasBearerConfirmation -> Bool
forall a. Eq a => a -> a -> Bool
== HasBearerConfirmation
HasBearerConfirmation) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Conditions -> Bool) -> Maybe Conditions -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Conditions -> Bool) -> Conditions -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NonEmpty URI] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([NonEmpty URI] -> Bool)
-> (Conditions -> [NonEmpty URI]) -> Conditions -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Conditions
-> Getting [NonEmpty URI] Conditions [NonEmpty URI]
-> [NonEmpty URI]
forall s a. s -> Getting a s a -> a
^. Getting [NonEmpty URI] Conditions [NonEmpty URI]
Lens' Conditions [NonEmpty URI]
condAudienceRestriction)) (Assertion
ass Assertion
-> Getting (Maybe Conditions) Assertion (Maybe Conditions)
-> Maybe Conditions
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Conditions) Assertion (Maybe Conditions)
Lens' Assertion (Maybe Conditions)
assConditions)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny DeniedReason
DeniedBearerConfAssertionsWithoutAudienceRestriction
  -- (the actual validation of the audience restrictions happens in 'checkConditions'.)

  SubjectConfirmationData -> m ()
forall (m :: * -> *).
(HasConfig m, SP m, SPStore m, MonadJudge m) =>
SubjectConfirmationData -> m ()
checkSubjectConfirmationData (SubjectConfirmationData -> m ())
-> Maybe SubjectConfirmationData -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` (SubjectConfirmation
conf SubjectConfirmation
-> Getting
     (Maybe SubjectConfirmationData)
     SubjectConfirmation
     (Maybe SubjectConfirmationData)
-> Maybe SubjectConfirmationData
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe SubjectConfirmationData)
  SubjectConfirmation
  (Maybe SubjectConfirmationData)
Lens' SubjectConfirmation (Maybe SubjectConfirmationData)
scData)
  HasBearerConfirmation -> m HasBearerConfirmation
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HasBearerConfirmation
bearer

checkSubjectConfirmationData ::
  (HasConfig m, SP m, SPStore m, MonadJudge m) =>
  SubjectConfirmationData ->
  m ()
checkSubjectConfirmationData :: forall (m :: * -> *).
(HasConfig m, SP m, SPStore m, MonadJudge m) =>
SubjectConfirmationData -> m ()
checkSubjectConfirmationData SubjectConfirmationData
confdat = do
  (String -> String -> DeniedReason) -> URI -> m ()
forall (m :: * -> *).
(HasConfig m, MonadJudge m) =>
(String -> String -> DeniedReason) -> URI -> m ()
checkDestination String -> String -> DeniedReason
DeniedBadRecipient (URI -> m ()) -> URI -> m ()
forall a b. (a -> b) -> a -> b
$ SubjectConfirmationData
confdat SubjectConfirmationData
-> Getting URI SubjectConfirmationData URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI SubjectConfirmationData URI
Lens' SubjectConfirmationData URI
scdRecipient
  Time
now <- m Time
forall (m :: * -> *). HasNow m => m Time
getNow
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Time
now Time -> Time -> Bool
`earlier` (SubjectConfirmationData
confdat SubjectConfirmationData
-> Getting Time SubjectConfirmationData Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time SubjectConfirmationData Time
Lens' SubjectConfirmationData Time
scdNotOnOrAfter)) (m () -> m ()) -> (DeniedReason -> m ()) -> DeniedReason -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny (DeniedReason -> m ()) -> DeniedReason -> m ()
forall a b. (a -> b) -> a -> b
$
    Time -> DeniedReason
DeniedNotOnOrAfterSubjectConfirmation (SubjectConfirmationData
confdat SubjectConfirmationData
-> Getting Time SubjectConfirmationData Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time SubjectConfirmationData Time
Lens' SubjectConfirmationData Time
scdNotOnOrAfter)
  case SubjectConfirmationData
confdat SubjectConfirmationData
-> Getting (Maybe Time) SubjectConfirmationData (Maybe Time)
-> Maybe Time
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Time) SubjectConfirmationData (Maybe Time)
Lens' SubjectConfirmationData (Maybe Time)
scdNotBefore of
    Just Time
notbef -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Time
notbef Time -> Time -> Bool
`noLater` Time
now) (m () -> m ()) -> (DeniedReason -> m ()) -> DeniedReason -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny (DeniedReason -> m ()) -> DeniedReason -> m ()
forall a b. (a -> b) -> a -> b
$ Time -> DeniedReason
DeniedNotBeforeSubjectConfirmation Time
notbef
    Maybe Time
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  -- double-check the result of the call to 'rspInResponseTo' in 'judge'' above.
  String -> ID AuthnRequest -> m ()
forall (m :: * -> *).
(SPStore m, MonadJudge m) =>
String -> ID AuthnRequest -> m ()
checkInResponseTo String
"assertion" (ID AuthnRequest -> m ()) -> Maybe (ID AuthnRequest) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` (SubjectConfirmationData
confdat SubjectConfirmationData
-> Getting
     (Maybe (ID AuthnRequest))
     SubjectConfirmationData
     (Maybe (ID AuthnRequest))
-> Maybe (ID AuthnRequest)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (ID AuthnRequest))
  SubjectConfirmationData
  (Maybe (ID AuthnRequest))
Lens' SubjectConfirmationData (Maybe (ID AuthnRequest))
scdInResponseTo)

checkConditions :: forall m. (HasCallStack, MonadJudge m, SP m) => Conditions -> m ()
checkConditions :: forall (m :: * -> *).
(HasCallStack, MonadJudge m, SP m) =>
Conditions -> m ()
checkConditions (Conditions Maybe Time
lowlimit Maybe Time
uplimit Bool
_onetimeuse [NonEmpty URI]
audiences) = do
  Time
now <- m Time
forall (m :: * -> *). HasNow m => m Time
getNow
  case Maybe Time
lowlimit of
    Just Time
lim -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Time
lim Time -> Time -> Bool
`noLater` Time
now) (m () -> m ()) -> (DeniedReason -> m ()) -> DeniedReason -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny (DeniedReason -> m ()) -> DeniedReason -> m ()
forall a b. (a -> b) -> a -> b
$ Time -> DeniedReason
DeniedNotBeforeCondition Time
lim
    Maybe Time
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  case Maybe Time
uplimit of
    Just Time
lim -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Time
now Time -> Time -> Bool
`earlier` Time
lim) (m () -> m ()) -> (DeniedReason -> m ()) -> DeniedReason -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny (DeniedReason -> m ()) -> DeniedReason -> m ()
forall a b. (a -> b) -> a -> b
$ Time -> DeniedReason
DeniedNotOnOrAfterCondition Time
lim
    Maybe Time
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Issuer URI
us <- (JudgeCtx -> Getting Issuer JudgeCtx Issuer -> Issuer
forall s a. s -> Getting a s a -> a
^. Getting Issuer JudgeCtx Issuer
Lens' JudgeCtx Issuer
judgeCtxAudience) (JudgeCtx -> Issuer) -> m JudgeCtx -> m Issuer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m JudgeCtx
forall (m :: * -> *). MonadJudge m => m JudgeCtx
getJudgeCtx
  let checkAudience :: NonEmpty URI -> m ()
      checkAudience :: NonEmpty URI -> m ()
checkAudience NonEmpty URI
aus =
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (URI
us URI -> NonEmpty URI -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` NonEmpty URI
aus) (m () -> m ()) -> (DeniedReason -> m ()) -> DeniedReason -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny (DeniedReason -> m ()) -> DeniedReason -> m ()
forall a b. (a -> b) -> a -> b
$
          URI -> NonEmpty URI -> DeniedReason
DeniedAudienceMismatch URI
us NonEmpty URI
aus
  NonEmpty URI -> m ()
checkAudience (NonEmpty URI -> m ()) -> [NonEmpty URI] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [NonEmpty URI]
audiences