{-# LANGUAGE OverloadedStrings #-}

module SAML2.WebSSO.SP where

import Control.Lens hiding (Level)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Extra (ifM)
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Foldable (toList)
import Data.Kind (Type)
import Data.List (nub, partition)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe, isJust)
import Data.String.Conversions
import Data.Time
import Data.UUID (UUID)
import Data.UUID qualified as UUID
import Data.UUID.V4 qualified as UUID
import GHC.Stack
import SAML2.Util
import SAML2.WebSSO.API.UnvalidatedSAMLStatus
import SAML2.WebSSO.Config
import SAML2.WebSSO.Types
import Servant hiding (URI (..))
import System.Logger (Level (..))
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, SPStoreRequest AuthnRequest m, SPStoreAssertion Assertion m)

class SPStoreAssertion i m where
  storeAssertionInternal :: ID i -> Time -> m ()
  unStoreAssertion :: ID i -> m ()
  isAliveAssertion ::
    ID i ->
    -- | stored and not timed out.
    m Bool

class SPStoreRequest i m where
  storeRequest :: ID i -> Issuer {- NB: idp! -} -> Time -> m ()
  unStoreRequest :: ID i -> m ()
  getIdpIssuer :: ID i -> m (Maybe Issuer)

class (MonadError err m, Show (IdPConfigExtra 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 :: * -> *).
SPStoreAssertion i m =>
ID i -> m Bool
isAliveAssertion 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 :: * -> *).
SPStoreAssertion i m =>
ID i -> Time -> m ()
storeAssertionInternal 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 =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Level
level Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Level
cfgsays) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ 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

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 = Text -> ID a
forall {k} (m :: k). Text -> ID m
ID (Text -> ID a) -> (UUID -> Text) -> UUID -> ID a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"_" <>) (Text -> Text) -> (UUID -> Text) -> UUID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Text
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 -> Issuer {- sp -} -> Issuer {- idp -} -> m AuthnRequest
createAuthnRequest :: forall (m :: * -> *).
(Monad m, SP m, SPStore m) =>
NominalDiffTime -> Issuer -> Issuer -> m AuthnRequest
createAuthnRequest NominalDiffTime
lifeExpectancySecs Issuer
_rqIssuer Issuer
idpIssuer = 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
  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 Text -> Bool -> NameIdPolicy
NameIdPolicy NameIDFormat
NameIDFUnspecified Maybe Text
forall a. Maybe a
Nothing Bool
True
  ID AuthnRequest -> Issuer -> Time -> m ()
forall {k} (i :: k) (m :: * -> *).
SPStoreRequest i m =>
ID i -> Issuer -> Time -> m ()
storeRequest ID AuthnRequest
_rqID Issuer
idpIssuer (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
_rqIssuer :: Issuer
_rqID :: ID AuthnRequest
_rqIssueInstant :: Time
_rqNameIDPolicy :: Maybe NameIdPolicy
_rqNameIDPolicy :: Maybe NameIdPolicy
_rqIssuer :: Issuer
_rqIssueInstant :: Time
_rqID :: ID AuthnRequest
..}

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

-- | This function exists to deal with legacy test cases.
getSsoURINoMultiIngress ::
  forall m endpoint api.
  ( HasCallStack,
    Functor m,
    HasConfig m,
    IsElem endpoint api,
    HasLink endpoint,
    ToHttpApiData (MkLink endpoint Link)
  ) =>
  Proxy api ->
  Proxy endpoint ->
  m URI
getSsoURINoMultiIngress :: forall (m :: * -> *) endpoint api.
(HasCallStack, Functor m, HasConfig m, IsElem endpoint api,
 HasLink endpoint, ToHttpApiData (MkLink endpoint Link)) =>
Proxy api -> Proxy endpoint -> m URI
getSsoURINoMultiIngress Proxy api
proxyAPI Proxy endpoint
proxyAPIAuthResp =
  (URI -> URI
extpath (URI -> URI)
-> (MultiIngressDomainConfig -> URI)
-> MultiIngressDomainConfig
-> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiIngressDomainConfig -> URI
_cfgSPSsoURI) (MultiIngressDomainConfig -> URI)
-> m MultiIngressDomainConfig -> m URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m MultiIngressDomainConfig
forall (m :: * -> *).
(HasConfig m, Functor m) =>
m MultiIngressDomainConfig
getMultiIngressDomainConfigNoMultiIngress
  where
    extpath :: URI -> URI
    extpath :: URI -> URI
extpath = (HasCallStack => URI -> Text -> URI
URI -> Text -> URI
=/ (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text)
-> (MkLink endpoint Link -> Text) -> MkLink endpoint Link -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MkLink endpoint Link -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece (MkLink endpoint Link -> Text) -> MkLink endpoint Link -> Text
forall a b. (a -> b) -> a -> b
$ Proxy api -> Proxy endpoint -> MkLink endpoint Link
forall endpoint api.
(IsElem endpoint api, HasLink endpoint) =>
Proxy api -> Proxy endpoint -> MkLink endpoint Link
safeLink Proxy api
proxyAPI Proxy endpoint
proxyAPIAuthResp))

-- | DANGER: This function is not valid for all spar configurations! It
-- spuriously fails for multi-ingress configs!
getMultiIngressDomainConfigNoMultiIngress :: forall m. (HasConfig m, Functor m) => m MultiIngressDomainConfig
-- FUTUREWORK: Get rid of this dangerous function. It solely exists to
-- implement legacy service example functions.
getMultiIngressDomainConfigNoMultiIngress :: forall (m :: * -> *).
(HasConfig m, Functor m) =>
m MultiIngressDomainConfig
getMultiIngressDomainConfigNoMultiIngress =
  (MultiIngressDomainConfig
-> Maybe MultiIngressDomainConfig -> MultiIngressDomainConfig
forall a. a -> Maybe a -> a
fromMaybe (String -> MultiIngressDomainConfig
forall a. HasCallStack => String -> a
error String
"Configuration not found. (Multi-ingress config not supported.)") (Maybe MultiIngressDomainConfig -> MultiIngressDomainConfig)
-> (Config -> Maybe MultiIngressDomainConfig)
-> Config
-> MultiIngressDomainConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Maybe Domain -> Maybe MultiIngressDomainConfig
`getMultiIngressDomainConfig` Maybe Domain
forall a. Maybe a
Nothing))
    (Config -> MultiIngressDomainConfig)
-> m Config -> m MultiIngressDomainConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Config
forall (m :: * -> *). HasConfig m => m Config
getConfig

----------------------------------------------------------------------
-- 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, SPStoreAssertion i m) => SPStoreAssertion i (JudgeT m) where
  storeAssertionInternal :: ID i -> Time -> JudgeT m ()
storeAssertionInternal 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 :: * -> *).
SPStoreAssertion i m =>
ID i -> Time -> m ()
storeAssertionInternal ID i
item
  unStoreAssertion :: ID i -> JudgeT m ()
unStoreAssertion = 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 :: * -> *).
SPStoreAssertion i m =>
ID i -> m ()
unStoreAssertion
  isAliveAssertion :: ID i -> JudgeT m Bool
isAliveAssertion = 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 :: * -> *).
SPStoreAssertion i m =>
ID i -> m Bool
isAliveAssertion

instance (Monad m, SPStoreRequest i m) => SPStoreRequest i (JudgeT m) where
  storeRequest :: ID i -> Issuer -> Time -> JudgeT m ()
storeRequest ID i
item Issuer
issuer = 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 -> Issuer -> Time -> m ()
forall {k} (i :: k) (m :: * -> *).
SPStoreRequest i m =>
ID i -> Issuer -> Time -> m ()
storeRequest ID i
item Issuer
issuer
  unStoreRequest :: ID i -> JudgeT m ()
unStoreRequest = 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 :: * -> *).
SPStoreRequest i m =>
ID i -> m ()
unStoreRequest
  getIdpIssuer :: ID i -> JudgeT m (Maybe Issuer)
getIdpIssuer = ExceptT
  DeniedReason
  (WriterT [DeniedReason] (ReaderT JudgeCtx m))
  (Maybe Issuer)
-> JudgeT m (Maybe Issuer)
forall (m :: * -> *) a.
ExceptT
  DeniedReason (WriterT [DeniedReason] (ReaderT JudgeCtx m)) a
-> JudgeT m a
JudgeT (ExceptT
   DeniedReason
   (WriterT [DeniedReason] (ReaderT JudgeCtx m))
   (Maybe Issuer)
 -> JudgeT m (Maybe Issuer))
-> (ID i
    -> ExceptT
         DeniedReason
         (WriterT [DeniedReason] (ReaderT JudgeCtx m))
         (Maybe Issuer))
-> ID i
-> JudgeT m (Maybe Issuer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [DeniedReason] (ReaderT JudgeCtx m) (Maybe Issuer)
-> ExceptT
     DeniedReason
     (WriterT [DeniedReason] (ReaderT JudgeCtx m))
     (Maybe Issuer)
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) (Maybe Issuer)
 -> ExceptT
      DeniedReason
      (WriterT [DeniedReason] (ReaderT JudgeCtx m))
      (Maybe Issuer))
-> (ID i
    -> WriterT [DeniedReason] (ReaderT JudgeCtx m) (Maybe Issuer))
-> ID i
-> ExceptT
     DeniedReason
     (WriterT [DeniedReason] (ReaderT JudgeCtx m))
     (Maybe Issuer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT JudgeCtx m (Maybe Issuer)
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) (Maybe Issuer)
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 (Maybe Issuer)
 -> WriterT [DeniedReason] (ReaderT JudgeCtx m) (Maybe Issuer))
-> (ID i -> ReaderT JudgeCtx m (Maybe Issuer))
-> ID i
-> WriterT [DeniedReason] (ReaderT JudgeCtx m) (Maybe Issuer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Maybe Issuer) -> ReaderT JudgeCtx m (Maybe Issuer)
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 (Maybe Issuer) -> ReaderT JudgeCtx m (Maybe Issuer))
-> (ID i -> m (Maybe Issuer))
-> ID i
-> ReaderT JudgeCtx m (Maybe Issuer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID i -> m (Maybe Issuer)
forall {k} (i :: k) (m :: * -> *).
SPStoreRequest i m =>
ID i -> m (Maybe Issuer)
getIdpIssuer

-- | [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 *not* check any of the *unsigned* parts of the AuthnResponse body because...
-- those are not signed!  the standard doesn't seem to worry about that, but wire does.  this
-- affects `rspStatus`, `inRespTo`, `rspIssueInstant`, `rspDestination`.  those are inferred
-- from the *signed* information available.
judge :: (Monad m, SP m, SPStore m) => NonEmpty Assertion -> UnvalidatedSAMLStatus -> JudgeCtx -> m AccessVerdict
judge :: forall (m :: * -> *).
(Monad m, SP m, SPStore m) =>
NonEmpty Assertion
-> UnvalidatedSAMLStatus -> JudgeCtx -> m AccessVerdict
judge NonEmpty Assertion
assertions UnvalidatedSAMLStatus
status JudgeCtx
ctx = JudgeCtx -> JudgeT m AccessVerdict -> m AccessVerdict
forall (m :: * -> *).
(Monad m, SP m) =>
JudgeCtx -> JudgeT m AccessVerdict -> m AccessVerdict
runJudgeT JudgeCtx
ctx (JudgeT m AccessVerdict -> m AccessVerdict)
-> JudgeT m AccessVerdict -> m AccessVerdict
forall a b. (a -> b) -> a -> b
$ do
  Bool -> JudgeT m () -> JudgeT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    (UnvalidatedSAMLStatus -> Status -> Bool
eqUnvalidatedSAMLStatus UnvalidatedSAMLStatus
status Status
StatusSuccess)
    (DeniedReason -> JudgeT m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny DeniedReason
DeniedStatusFailure)
  NonEmpty Assertion -> JudgeT m AccessVerdict
forall (m :: * -> *).
(HasCallStack, MonadJudge m, SP m, SPStore m) =>
NonEmpty Assertion -> m AccessVerdict
foldJudge NonEmpty Assertion
assertions

foldJudge :: (HasCallStack, MonadJudge m, SP m, SPStore m) => NonEmpty Assertion -> m AccessVerdict
foldJudge :: forall (m :: * -> *).
(HasCallStack, MonadJudge m, SP m, SPStore m) =>
NonEmpty Assertion -> m AccessVerdict
foldJudge (NonEmpty Assertion -> [Assertion]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [Assertion]
assertions) = do
  [AccessVerdict]
verdicts <- Assertion -> m AccessVerdict
forall (m :: * -> *).
(HasCallStack, MonadJudge m, SP m, SPStore m) =>
Assertion -> m AccessVerdict
judge1 (Assertion -> m AccessVerdict) -> [Assertion] -> m [AccessVerdict]
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` [Assertion]
assertions
  let ([AccessVerdict]
granteds, [AccessVerdict]
denieds) =
        [AccessVerdict]
verdicts
          [AccessVerdict]
-> ([AccessVerdict] -> ([AccessVerdict], [AccessVerdict]))
-> ([AccessVerdict], [AccessVerdict])
forall a b. a -> (a -> b) -> b
& (AccessVerdict -> Bool)
-> [AccessVerdict] -> ([AccessVerdict], [AccessVerdict])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition
            ( \case
                AccessDenied [DeniedReason]
_ -> Bool
False
                AccessGranted UserRef
_ -> Bool
True
            )

  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
$ case ([AccessVerdict]
granteds, [AccessVerdict]
denieds) of
    -- granted
    ([AccessVerdict] -> [AccessVerdict]
forall a. Eq a => [a] -> [a]
nub -> [result :: AccessVerdict
result@(AccessGranted UserRef
_)], []) -> AccessVerdict
result
    -- denied
    ([], AccessVerdict
_ : [AccessVerdict]
_) -> [DeniedReason] -> AccessVerdict
AccessDenied (Getting [DeniedReason] AccessVerdict [DeniedReason]
-> AccessVerdict -> [DeniedReason]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [DeniedReason] AccessVerdict [DeniedReason]
Traversal' AccessVerdict [DeniedReason]
avReasons (AccessVerdict -> [DeniedReason])
-> [AccessVerdict] -> [DeniedReason]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [AccessVerdict]
denieds)
    -- weird corner cases
    (bad :: [AccessVerdict]
bad@(AccessVerdict
_ : [AccessVerdict]
_), [AccessVerdict]
_) -> [DeniedReason] -> AccessVerdict
AccessDenied (String -> DeniedReason
DeniedBadUserRefs ([AccessVerdict] -> String
forall a. Show a => a -> String
show [AccessVerdict]
bad) DeniedReason -> [DeniedReason] -> [DeniedReason]
forall a. a -> [a] -> [a]
: (Getting [DeniedReason] AccessVerdict [DeniedReason]
-> AccessVerdict -> [DeniedReason]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [DeniedReason] AccessVerdict [DeniedReason]
Traversal' AccessVerdict [DeniedReason]
avReasons (AccessVerdict -> [DeniedReason])
-> [AccessVerdict] -> [DeniedReason]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [AccessVerdict]
denieds))
    ([], []) -> [DeniedReason] -> AccessVerdict
AccessDenied [String -> DeniedReason
DeniedBadUserRefs String
"there are no assertions"]

judge1 :: (HasCallStack, MonadJudge m, SP m, SPStore m) => Assertion -> m AccessVerdict
judge1 :: forall (m :: * -> *).
(HasCallStack, MonadJudge m, SP m, SPStore m) =>
Assertion -> m AccessVerdict
judge1 Assertion
assertion = do
  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 (m (ID AuthnRequest) -> String -> m (ID AuthnRequest)
forall a b. a -> b -> a
const (m (ID AuthnRequest) -> String -> m (ID AuthnRequest))
-> m (ID AuthnRequest) -> String -> m (ID AuthnRequest)
forall a b. (a -> b) -> a -> b
$ DeniedReason -> m (ID AuthnRequest)
forall a. DeniedReason -> m a
forall (m :: * -> *) a. MonadJudge m => DeniedReason -> m a
giveup DeniedReason
DeniedNoInResponseTo) 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
$ Assertion -> Either String (ID AuthnRequest)
forall (m :: * -> *).
MonadError String m =>
Assertion -> m (ID AuthnRequest)
assertionToInResponseTo Assertion
assertion
  String -> Issuer -> ID AuthnRequest -> m ()
forall (m :: * -> *).
(SPStore m, MonadJudge m) =>
String -> Issuer -> ID AuthnRequest -> m ()
checkInResponseTo String
"response" (Assertion
assertion Assertion -> Getting Issuer Assertion Issuer -> Issuer
forall s a. s -> Getting a s a -> a
^. Getting Issuer Assertion Issuer
Lens' Assertion Issuer
assIssuer) ID AuthnRequest
inRespTo
  AccessVerdict
verdict <- Assertion -> m AccessVerdict
forall (m :: * -> *).
(SP m, SPStore m, MonadJudge m) =>
Assertion -> m AccessVerdict
checkAssertion Assertion
assertion
  ID AuthnRequest -> m ()
forall {k} (i :: k) (m :: * -> *).
SPStoreRequest i m =>
ID i -> m ()
unStoreRequest 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 -> Issuer -> ID AuthnRequest -> m ()
checkInResponseTo :: forall (m :: * -> *).
(SPStore m, MonadJudge m) =>
String -> Issuer -> ID AuthnRequest -> m ()
checkInResponseTo String
loc Issuer
issuerFromRes ID AuthnRequest
req = do
  Maybe Issuer
mbIssuerFromReq <- ID AuthnRequest -> m (Maybe Issuer)
forall {k} (i :: k) (m :: * -> *).
SPStoreRequest i m =>
ID i -> m (Maybe Issuer)
getIdpIssuer ID AuthnRequest
req
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    (Maybe Issuer -> Bool
forall a. Maybe a -> Bool
isJust Maybe Issuer
mbIssuerFromReq)
    (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)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    (Issuer -> Maybe Issuer
forall a. a -> Maybe a
Just Issuer
issuerFromRes Maybe Issuer -> Maybe Issuer -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Issuer
mbIssuerFromReq)
    (DeniedReason -> m ()
forall a. DeniedReason -> m a
forall (m :: * -> *) a. MonadJudge m => DeniedReason -> m a
giveup (Maybe Issuer -> Issuer -> DeniedReason
DeniedIssuerMismatch Maybe Issuer
mbIssuerFromReq Issuer
issuerFromRes))

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 -> Text
renderURI -> Text
expectedByIdp) = do
  (URI -> Text
renderURI -> Text
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 (Text
expectedByUs Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
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 (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
expectedByUs) (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
expectedByIdp)

checkAssertion :: (SP m, SPStore m, MonadJudge m) => Assertion -> m AccessVerdict
checkAssertion :: forall (m :: * -> *).
(SP m, SPStore m, MonadJudge m) =>
Assertion -> m AccessVerdict
checkAssertion 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) m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Bool
False -> DeniedReason -> m ()
forall (m :: * -> *). MonadJudge m => DeniedReason -> m ()
deny DeniedReason
DeniedStatusFailure
  Conditions -> m ()
forall (m :: * -> *).
(HasCallStack, MonadJudge m, SP m) =>
Conditions -> m ()
checkConditions (Conditions -> m ()) -> Maybe Conditions -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` (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)
  Assertion -> m ()
forall (m :: * -> *).
(SP m, SPStore m, MonadJudge m) =>
Assertion -> m ()
checkSubjectConfirmations Assertion
ass
  let statements :: NonEmpty Statement
statements = Assertion
ass Assertion
-> Getting (NonEmpty Statement) Assertion (NonEmpty Statement)
-> NonEmpty Statement
forall s a. s -> Getting a s a -> a
^. (SubjectAndStatements
 -> Const (NonEmpty Statement) SubjectAndStatements)
-> Assertion -> Const (NonEmpty Statement) Assertion
Lens' Assertion SubjectAndStatements
assContents ((SubjectAndStatements
  -> Const (NonEmpty Statement) SubjectAndStatements)
 -> Assertion -> Const (NonEmpty Statement) Assertion)
-> ((NonEmpty Statement
     -> Const (NonEmpty Statement) (NonEmpty Statement))
    -> SubjectAndStatements
    -> Const (NonEmpty Statement) SubjectAndStatements)
-> Getting (NonEmpty Statement) Assertion (NonEmpty Statement)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Statement
 -> Const (NonEmpty Statement) (NonEmpty Statement))
-> SubjectAndStatements
-> Const (NonEmpty Statement) SubjectAndStatements
Lens' SubjectAndStatements (NonEmpty Statement)
sasStatements
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Statement -> Bool) -> NonEmpty Statement -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Statement -> Bool
isAuthnStatement NonEmpty Statement
statements) (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_` NonEmpty Statement -> [Statement]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty 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 (Assertion -> UserRef
assertionToUserRef Assertion
ass)

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
assertion = do
  [HasBearerConfirmation]
bearerFlags :: [HasBearerConfirmation] <- 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. Eq a => [a] -> [a]
nub [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)

-- | 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 ()
when ((Conditions -> Bool) -> Maybe Conditions -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([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 ()

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 ()
unless (URI
us URI -> NonEmpty URI -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` 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