fradrive/src/Foundation/Authorization.hs

{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Foundation.Authorization
  ( evalAccess, evalAccessFor, evalAccessWith
  , evalAccessDB, evalAccessForDB, evalAccessWithDB
  , hasReadAccessTo, hasWriteAccessTo
  , wouldHaveReadAccessTo, wouldHaveWriteAccessTo
  , wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
  , AuthContext(..), getAuthContext
  , isDryRun
  , maybeBearerToken, requireBearerToken
  , requireCurrentBearerRestrictions, maybeCurrentBearerRestrictions
  , BearerAuthSite
  , routeAuthTags
  , orAR, andAR, notAR, trueAR, falseAR
  ) where

import Import.NoFoundation

import Foundation.Type
import Foundation.Routes
import Foundation.I18n

import Foundation.DB

import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam
import Utils.Course (courseIsVisible)
  
import qualified Data.Set as Set
import qualified Data.Aeson as JSON
import qualified Data.HashSet as HashSet
import qualified Data.Map as Map
import Data.Map ((!?))
import qualified Data.Text as Text
import Data.List (findIndex)

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Memo.Class (MonadMemo(..), for4)

import Data.Aeson.Lens hiding (_Value, key)


type BearerAuthSite site
  = ( MonadCrypto (HandlerFor site)
    , CryptoIDKey ~ MonadCryptoKey (HandlerFor site)
    , MonadCrypto (ReaderT SqlBackend (HandlerFor site))
    , CryptoIDKey ~ MonadCryptoKey (ReaderT SqlBackend (HandlerFor site))
    , MonadCrypto (ExceptT AuthResult (HandlerFor site))
    , CryptoIDKey ~ MonadCryptoKey (ExceptT AuthResult (HandlerFor site))
    , MonadCrypto (MaybeT (HandlerFor site))
    , CryptoIDKey ~ MonadCryptoKey (MaybeT (HandlerFor site))
    , MonadCrypto (ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor site)))
    , CryptoIDKey ~ MonadCryptoKey (ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor site)))
    , MonadCrypto (ReaderT SqlReadBackend (HandlerFor site))
    , CryptoIDKey ~ MonadCryptoKey (ReaderT SqlReadBackend (HandlerFor site))
    , MonadCrypto (MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor site))))
    , CryptoIDKey ~ MonadCryptoKey (MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor site))))
    , MonadCrypto (MaybeT (ReaderT SqlReadBackend (HandlerFor site)))
    , CryptoIDKey ~ MonadCryptoKey (MaybeT (ReaderT SqlReadBackend (HandlerFor site)))
    , UserId ~ AuthId site, User ~ AuthEntity site
    , YesodAuthPersist site
    )


-- Access Control
newtype InvalidAuthTag = InvalidAuthTag Text
  deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Exception InvalidAuthTag


data AccessPredicate
  = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
  | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
  | APDB       (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)

class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
  evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult

instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
  evalAccessPred aPred aid r w = liftHandler $ case aPred of
    (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
    (APHandler p) -> p aid r w
    (APDB      p) -> runDBRead $ p aid r w

instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where
  evalAccessPred aPred aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
    (APPure    p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
    (APHandler p) -> lift $ p aid r w
    (APDB      p) -> p aid r w


orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
orAR  _  Authorized _ = Authorized
orAR  _  _ Authorized = Authorized
orAR  _  AuthenticationRequired _  = AuthenticationRequired
orAR  _  _ AuthenticationRequired  = AuthenticationRequired
orAR  mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
-- and
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
andAR _  reason@(Unauthorized _) _ = reason
andAR _  _ reason@(Unauthorized _) = reason
andAR _  Authorized          other = other
andAR _  AuthenticationRequired  _ = AuthenticationRequired

notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult
notAR _  _   (Unauthorized _)        = Authorized
notAR _  _    AuthenticationRequired = AuthenticationRequired
notAR mr msg  Authorized             = Unauthorized . render mr . MsgUnauthorizedNot $ render mr msg

trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
trueAR = const Authorized
falseAR = Unauthorized . ($ MsgUnauthorized) . render

trueAP, _falseAP :: AccessPredicate
trueAP  = APPure . const . const . const $ trueAR <$> ask
_falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness


data AuthContext = AuthContext
  { authCtxAuth    :: Maybe (AuthId UniWorX)
  , authCtxBearer  :: Maybe (BearerToken UniWorX)
  , authActiveTags :: AuthTagActive
  } deriving (Generic, Typeable)

deriving instance Eq (AuthId UniWorX) => Eq AuthContext
deriving instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext
deriving instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show AuthContext
deriving anyclass instance Hashable (AuthId UniWorX) => Hashable AuthContext
deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary AuthContext

getAuthContext :: forall m.
                  ( MonadHandler m, HandlerSite m ~ UniWorX
                  , BearerAuthSite UniWorX
                  )
               => m AuthContext
getAuthContext = liftHandler $ do
  authCtx <- AuthContext
    <$> maybeAuthId
    <*> runMaybeT (exceptTMaybe askBearerUnsafe)
    <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags)

  $logDebugS "getAuthContext" $ tshow authCtx

  return authCtx

isDryRun :: forall m.
            ( MonadHandler m, HandlerSite m ~ UniWorX
            , BearerAuthSite UniWorX
            )
         => m Bool
isDryRun = $cachedHere . liftHandler $ orM
  [ hasGlobalPostParam PostDryRun
  , hasGlobalGetParam GetDryRun
  , and2M bearerDryRun bearerRequired
  ]
  where
    bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value
    bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do
      mAuthId <- maybeAuthId
      currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
      isWrite <- isWriteRequest currentRoute

      let noTokenAuth :: AuthDNF -> AuthDNF
          noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar

      dnf <- either throwM return $ routeAuthTags currentRoute
      guardAuthResult <=< fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) mAuthId currentRoute isWrite

      return False

    cPred err = any ($ err)
      [ is $ _HCError . _PermissionDenied
      , is $ _HCError . _NotAuthenticated
      ]


askBearerUnsafe :: forall m.
                  ( MonadHandler m, HandlerSite m ~ UniWorX
                  , BearerAuthSite UniWorX
                  )
               => ExceptT AuthResult m (BearerToken UniWorX)
-- | This performs /no/ meaningful validation of the `BearerToken`
--
-- Use `requireBearerToken` or `maybeBearerToken` instead
askBearerUnsafe = ExceptT . $cachedHere . liftHandler . runExceptT $ do
  bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer
  catch (decodeBearer bearer) $ \case
    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
    other -> do
      $logWarnS "AuthToken" $ tshow other
      throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid

validateBearer :: BearerAuthSite UniWorX
               => Maybe (AuthId UniWorX)
               -> Route UniWorX
               -> Bool -- ^ @isWrite@
               -> BearerToken UniWorX
               -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult
validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token'
  where
    validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) AuthResult
    validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
      guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)

      bearerAuthority' <- flip foldMapM bearerAuthority $ \case
        Left tVal
          | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
              Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
              return $ Set.singleton userGroupMemberUser
          | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
        Right uid -> return $ Set.singleton uid

      let
        -- Prevent infinite loops
        noTokenAuth :: AuthDNF -> AuthDNF
        noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar

      guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority

      forM_ bearerAuthority' $ \uid -> do
        User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid
        guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)

        authorityVal <- do
          dnf <- either throwM return $ routeAuthTags route
          fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite
        guardExceptT (is _Authorized authorityVal) authorityVal

      whenIsJust bearerAddAuth $ \addDNF -> do
        $logDebugS "validateToken" $ tshow addDNF
        additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
        guardExceptT (is _Authorized additionalVal) additionalVal

      return Authorized

maybeBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX
                    , BearerAuthSite UniWorX
                    ) => m (Maybe (BearerToken UniWorX))
maybeBearerToken = liftHandler . runMaybeT $ catchIfMaybeT cPred requireBearerToken
  where
    cPred err = any ($ err)
      [ is $ _HCError . _PermissionDenied
      , is $ _HCError . _NotAuthenticated
      ]

requireBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX
                      , BearerAuthSite UniWorX
                      )
                   => m (BearerToken UniWorX)
requireBearerToken = liftHandler $ do
  bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
  mAuthId <- maybeAuthId
  currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
  isWrite <- isWriteRequest currentRoute
  guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer
  return bearer

requireCurrentBearerRestrictions :: forall a m.
                                    ( MonadHandler m, HandlerSite m ~ UniWorX
                                    , FromJSON a, ToJSON a
                                    , BearerAuthSite UniWorX
                                    )
                                 => m (Maybe a)
requireCurrentBearerRestrictions = liftHandler . runMaybeT $ do
  bearer <- requireBearerToken
  route <- MaybeT getCurrentRoute
  hoistMaybe $ bearer ^? _bearerRestrictionIx route

maybeCurrentBearerRestrictions :: forall a m.
                                  ( MonadHandler m, HandlerSite m ~ UniWorX
                                  , FromJSON a, ToJSON a
                                  , BearerAuthSite UniWorX
                                  )
                               => m (Maybe a)
maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
  bearer <- MaybeT maybeBearerToken
  route <- MaybeT getCurrentRoute
  hoistMaybe $ bearer ^? _bearerRestrictionIx route

tagAccessPredicate :: BearerAuthSite UniWorX
                   => AuthTag -> AccessPredicate
tagAccessPredicate AuthFree = trueAP
tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
  -- Courses: access only to school admins
  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
      E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool
      E.where_  $ userAdmin E.^. UserFunctionUser E.==. E.val authId
            E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
            E.&&. course E.^. CourseTerm      E.==. E.val tid
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
    guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
    return Authorized
  -- Allocations: access only to school admins
  AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
      E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool
      E.where_  $ userAdmin E.^. UserFunctionUser E.==. E.val authId
            E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
            E.&&. allocation E.^. AllocationTerm      E.==. E.val tid
            E.&&. allocation E.^. AllocationSchool    E.==. E.val ssh
            E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
    guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
    return Authorized
  -- Schools: access only to school admins
  SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin]
    guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
    return Authorized
  -- other routes: access to any admin is granted here
  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
    guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
    return Authorized
tagAccessPredicate AuthSystemExamOffice = APDB $ \mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
  isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
  guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
  return Authorized
tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of
  CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
      E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId

      E.where_ $ course E.^. CourseTerm E.==. E.val tid
           E.&&. course E.^. CourseSchool E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. exam E.^. ExamName E.==. E.val examn

      E.where_ $ examOfficeExamResultAuth (E.val authId) examResult
    guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice)
    return Authorized
  EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do
      E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam

      E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid
           E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
           E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
           E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn

      E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult
    guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice
    return Authorized
  CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice
    guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice
    return Authorized
  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
    guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
    return Authorized
tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of
  ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
    return Authorized
  CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
    return Authorized
  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
    return Authorized
tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of
  AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
    return Authorized
  CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
    return Authorized
  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]
    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
    return Authorized
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
  lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
  AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
    myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
    uid <- decrypt cID
    otherSchoolsFunctions <- lift . $cachedHereBinary uid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] []
    mySchools <- lift . $cachedHereBinary myUid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] []
    guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
    return Authorized
  r -> $unsupportedAuthPredicate AuthNoEscalation r
tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
  $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
  addMessageI Error MsgDeprecatedRoute
  allow <- getsYesod $ view _appAllowDeprecated
  return $ bool (Unauthorized "Deprecated Route") Authorized allow
tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
  $logWarnS "AccessControl" ("route in development: " <> tshow r)
#ifdef DEVELOPMENT
  return Authorized
#else
  return $ Unauthorized "Route under development"
#endif
tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do
       E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
       E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
            E.&&. course E.^. CourseTerm      E.==. E.val tid
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
     guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
     return Authorized
  AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
      E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
      E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
      E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
      E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
           E.&&. allocation E.^. AllocationTerm      E.==. E.val tid
           E.&&. allocation E.^. AllocationSchool    E.==. E.val ssh
           E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
    guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer
    return Authorized
  EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do
      E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam
      E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId
           E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid
           E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
           E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
           E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
    guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer
    return Authorized
  -- lecturer for any school will do
  _ -> $cachedHereBinary mAuthId . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
     return Authorized
tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
  resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
    E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
    E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
    E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
    return (course E.^. CourseId, sheet E.^. SheetId)
  let
    resMap :: Map CourseId (Set SheetId)
    resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
  case route of
    CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
      sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
      Submission{..} <- MaybeT . lift $ get sid
      guard $ Just authId == submissionRatingBy
      return Authorized
    CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
      Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
      guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
      return Authorized
    CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
      guard $ cid `Set.member` Map.keysSet resMap
      return Authorized
    _ -> do
      guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
      return Authorized
tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of
  CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
      E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
      E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
        E.&&. course E.^. CourseTerm      E.==. E.val tid
        E.&&. course E.^. CourseSchool    E.==. E.val ssh
        E.&&. course E.^. CourseShorthand E.==. E.val csh
        E.&&. exam   E.^. ExamName        E.==. E.val examn
    guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
    return Authorized
  CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
      E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
        E.&&. course E.^. CourseTerm      E.==. E.val tid
        E.&&. course E.^. CourseSchool    E.==. E.val ssh
        E.&&. course E.^. CourseShorthand E.==. E.val csh
    guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamCorrector r
tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do
  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
  resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
    E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
    E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
    E.where_ $ tutor E.^. TutorUser E.==. E.val authId
    return (course E.^. CourseId, tutorial E.^. TutorialId)
  let
    resMap :: Map CourseId (Set TutorialId)
    resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ]
  case route of
    CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do
      Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
      Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn
      guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid)
      return Authorized
    CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do
      Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
      guard $ cid `Set.member` Map.keysSet resMap
      return Authorized
    _ -> do
      guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
      return Authorized
tagAccessPredicate AuthTutorControl = APDB $ \_ route _ -> case route of
  CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
    Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
    guard tutorialTutorControlled
    return Authorized
  r -> $unsupportedAuthPredicate AuthTutorControl r
tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route of
  CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do
      E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser
      E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId
      return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
    unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do
      uid <- hoistMaybe mAuthId
      guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups]
    return Authorized
  CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do
    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn
    when (is _RegisteredGroups sheetGrouping) $ do
      uid <- hoistMaybe mAuthId
      guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
        E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
        E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course
             E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid

    return Authorized
  r -> $unsupportedAuthPredicate AuthSubmissionGroup r
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
  CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
    cTime <- liftIO getCurrentTime
    registration <- case mAuthId of
      Just uid -> $cachedHereBinary (eId, uid) . lift . getBy $ UniqueExamRegistration eId uid
      Nothing  -> return Nothing

    let visible = NTop examVisibleFrom <= NTop (Just cTime)

    case subRoute of
      EShowR     -> guard visible
      EUsersR    -> guard $ NTop examStart <= NTop (Just cTime)
                         && NTop (Just cTime) <= NTop examFinished
      ERegisterR
        | is _Nothing registration
          -> guard $ visible
                  && NTop examRegisterFrom <= NTop (Just cTime)
                  && NTop (Just cTime) <= NTop examRegisterTo
        | otherwise
          -> guard $ visible
                  && NTop (Just cTime) <= NTop examDeregisterUntil
      ERegisterOccR occn -> do
        occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
        if
          | (registration >>= examRegistrationOccurrence . entityVal) == Just occId
            -> guard $ visible
                    && NTop (Just cTime) <= NTop examDeregisterUntil
          | otherwise
            -> guard $ visible
                    && NTop examRegisterFrom <= NTop (Just cTime)
                    && NTop (Just cTime) <= NTop examRegisterTo
      ECorrectR -> guard $ NTop (Just cTime) >= NTop examStart
                        && NTop (Just cTime) <= NTop examFinished
      _          -> return ()

    return Authorized

  CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do
    now <- liftIO getCurrentTime
    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn
    registered <- case mAuthId of
      Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid
      Nothing  -> return False

    if
      | not registered
      , maybe False (now >=) tutorialRegisterFrom
      , maybe True  (now <=) tutorialRegisterTo
        -> return Authorized
      | registered
      , maybe True  (now <=) tutorialDeregisterUntil
        -> return Authorized
      | otherwise
        -> mzero

  CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
    cTime <- liftIO getCurrentTime
    let
      visible = NTop sheetVisibleFrom <= NTop (Just cTime)
      active  = NTop sheetActiveFrom <= NTop (Just cTime) && NTop (Just cTime) <= NTop sheetActiveTo
      marking = NTop (Just cTime) > NTop sheetActiveTo

    guard visible

    case subRoute of
      -- Single Files
      SFileR                SheetExercise _ -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
      SFileR                SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
      SFileR                SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
      SFileR                _             _ -> mzero
      -- Archives of SheetFileType
      SZipR                 SheetExercise   -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
      SZipR                 SheetHint       -> guard $ maybe False (<= cTime) sheetHintFrom
      SZipR                 SheetSolution   -> guard $ maybe False (<= cTime) sheetSolutionFrom
      SZipR                 _               -> mzero
      -- Submissions
      SubmissionNewR           -> guard   active
      SAssignR                 -> guard   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change; this is assumed in Corrections.assignHandler
      SubmissionR _ SubAssignR -> guard   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
      SubmissionR _ _          -> guard   active
      _                        -> return ()

    return Authorized

  CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do
    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm
    cTime <- liftIO getCurrentTime
    let visible = NTop materialVisibleFrom <= NTop (Just cTime)
    guard visible
    return Authorized

  CourseR tid ssh csh CRegisterR -> do
    now <- liftIO getCurrentTime
    mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
    registered <- case (mbc,mAuthId) of
      (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
      _ -> return False
    case mbc of
      (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
        | not registered
        , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed
        , maybe True  (now <=) courseRegisterTo      -> return Authorized
      (Just (Entity cid Course{courseDeregisterUntil}))
        | registered
          -> maybeT (unauthorizedI MsgUnauthorizedCourseRegistrationTime) $ do
            guard $ maybe True (now <=) courseDeregisterUntil
            forM_ mAuthId $ \uid -> do
              exams <- lift . E.select . E.from $ \exam -> do
                E.where_ . E.exists . E.from $ \examRegistration ->
                  E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
                       E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
                E.where_ $ exam E.^. ExamCourse E.==. E.val cid
                return $ exam E.^. ExamDeregisterUntil
              forM_ exams $ \(E.Value deregUntil) ->
                guard $ NTop (Just now) <= NTop deregUntil

              tutorials <- lift . E.select . E.from $ \tutorial -> do
                E.where_ . E.exists . E.from $ \tutorialParticipant ->
                  E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
                       E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
                E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
                return $ tutorial E.^. TutorialDeregisterUntil
              forM_ tutorials $ \(E.Value deregUntil) ->
                guard $ NTop (Just now) <= NTop deregUntil
            return Authorized
      _other -> unauthorizedI MsgUnauthorizedCourseRegistrationTime
  
  CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
    Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
    allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation

    case allocation of
      Nothing -> do
        cTime <- liftIO getCurrentTime
        guard $ maybe False (cTime >=) courseRegisterFrom
        guard $ maybe True  (cTime <=) courseRegisterTo
      Just Allocation{..} -> do
        cTime <- liftIO getCurrentTime
        guard $ NTop allocationRegisterFrom <= NTop (Just cTime)
        guard $ NTop (Just cTime) <= NTop allocationRegisterTo

    return Authorized

  AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
    -- Checks `registerFrom` and `registerTo`, override as further routes become available
    now <- liftIO getCurrentTime
    Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
    guard $ NTop allocationRegisterFrom <= NTop (Just now)
    guard $ NTop (Just now) <= NTop allocationRegisterTo
    return Authorized

  MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
    cTime <- NTop . Just <$> liftIO getCurrentTime
    guard $ NTop systemMessageFrom <= cTime
         && NTop systemMessageTo   >= cTime
    return Authorized

  MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
    cTime <- NTop . Just <$> liftIO getCurrentTime
    guard $ NTop systemMessageFrom <= cTime
         && NTop systemMessageTo   >= cTime
    return Authorized

  CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
    nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
    cTime <- NTop . Just <$> liftIO getCurrentTime
    guard $ NTop courseNewsVisibleFrom <= cTime
    return Authorized

  r -> $unsupportedAuthPredicate AuthTime r
tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of
  CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
    allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation

    case allocation of
      Nothing -> return ()
      Just Allocation{..} -> do
        cTime <- liftIO getCurrentTime
        guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
        when isWrite $
          guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo

    return Authorized

  AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
    -- Checks `registerFrom` and `registerTo`, override as further routes become available
    now <- liftIO getCurrentTime
    Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
    guard $ NTop allocationStaffAllocationFrom <= NTop (Just now)
    guard $ NTop (Just now) <= NTop allocationStaffAllocationTo
    return Authorized

  r -> $unsupportedAuthPredicate AuthStaffTime r
tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
  CourseR tid ssh csh CRegisterR -> do
    now <- liftIO getCurrentTime
    mba <- mbAllocation tid ssh csh
    case mba of
      Nothing -> return Authorized
      Just (cid, Allocation{..}) -> do
        registered <- case mAuthId of
          Just uid -> $cachedHereBinary (uid, cid) . existsBy $ UniqueParticipant uid cid
          _        -> return False
        if
          | not registered
          , NTop allocationRegisterByCourse >= NTop (Just now)
            -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
          | registered
          , NTop (Just now) >= NTop allocationOverrideDeregister
            -> unauthorizedI MsgUnauthorizedAllocatedCourseDeregister
          | otherwise
            -> return Authorized

  CourseR tid ssh csh CAddUserR -> do
    now <- liftIO getCurrentTime
    mba <- mbAllocation tid ssh csh
    case mba of
      Just (_, Allocation{..})
        |    NTop allocationRegisterByStaffTo <= NTop (Just now)
          || NTop allocationRegisterByStaffFrom >= NTop (Just now)
          -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
      _other -> return Authorized

  CourseR tid ssh csh CDeleteR -> do
    now <- liftIO getCurrentTime
    mba <- mbAllocation tid ssh csh
    case mba of
      Just (_, Allocation{..})
        |    NTop allocationRegisterByStaffTo <= NTop (Just now)
          || NTop allocationRegisterByStaffFrom >= NTop (Just now)
          -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete
      _other -> return Authorized

  r -> $unsupportedAuthPredicate AuthAllocationTime r
  where
    mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do
      cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
      Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
      (cid,) <$> MaybeT (get allocationCourseAllocation)
tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of
  CourseR tid ssh csh _ -> exceptT return return $ do
    now <- liftIO getCurrentTime
    courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do
      E.where_ $ course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. courseIsVisible now course Nothing
    guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime)
    return Authorized
  r -> $unsupportedAuthPredicate AuthCourseTime r
tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
      E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
      E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
           E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthCourseRegistered r
tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of
  CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
      E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
      E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
      E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. tutorial E.^. TutorialName  E.==. E.val tutn
    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
      E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
      E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
      E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthTutorialRegistered r
tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ course E.^. CourseTerm       E.==. E.val tid
           E.&&. course E.^. CourseSchool     E.==. E.val ssh
           E.&&. course E.^. CourseShorthand  E.==. E.val csh
           E.&&. exam E.^. ExamName           E.==. E.val examn
           E.&&. exam E.^. ExamOccurrenceRule E.==. E.val ExamRoomFifo
    guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration)
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r
tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of
  CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do
      E.on $ E.just (examOccurrence E.^. ExamOccurrenceId) E.==. examRegistration E.^. ExamRegistrationOccurrence
      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
           E.&&. examOccurrence E.^. ExamOccurrenceName E.==. E.val occn
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. exam E.^. ExamName          E.==. E.val examn
    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. exam E.^. ExamName          E.==. E.val examn
           E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence)
    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence)
    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r
tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. exam E.^. ExamName          E.==. E.val examn
    guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam
    return Authorized
  CSheetR tid ssh csh shn _ -> exceptT return return $ do
    requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do
      E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
      E.where_ $ course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. sheet  E.^. SheetName       E.==. E.val shn
      return $ sheet E.^. SheetRequireExamRegistration
    requiredExam <- maybeMExceptT (unauthorizedI MsgUnauthorizedRegisteredExam) . return $ E.unValue <$> requiredExam'
    whenIsJust requiredExam $ \eId -> do
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      isRegistered <- $cachedHereBinary (authId, eId) . lift . E.selectExists . E.from $ \examRegistration ->
        E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
             E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val authId
      guardMExceptT isRegistered $ unauthorizedI MsgUnauthorizedRegisteredExam
    return Authorized
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
    guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamRegistered r
tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
      E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. exam E.^. ExamName  E.==. E.val examn
    hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do
      E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
      E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. exam E.^. ExamName  E.==. E.val examn
    guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
    return Authorized
  EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasResult <- $cachedHereBinary (authId, tid, ssh, coursen, examn) . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do
      E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam
      E.where_ $ eexamResult E.^. ExternalExamResultUser E.==. E.val authId
           E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid
           E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
           E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
           E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
    guardMExceptT hasResult $ unauthorizedI MsgUnauthorizedExternalExamResult
    return Authorized
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
      E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
    hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do
      E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
      E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
    guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamRegistered r
tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of
  AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do
    uid <- hoistMaybe mAuthId
    aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash
    void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
    return Authorized
  r -> $unsupportedAuthPredicate AuthAllocationRegistered r
tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
  CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do
    nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
    if | courseNewsParticipantsOnly -> do
           uid <- hoistMaybe mAuthId
           exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid True
       | otherwise
           -> return Authorized

  CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
    participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
    isCourseParticipant tid ssh csh participant False
    unauthorizedI MsgUnauthorizedParticipant

  r -> $unsupportedAuthPredicate AuthParticipant r

  where
    isCourseParticipant tid ssh csh participant onlyActive = do
      let
        authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
        authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
      -- participant is currently registered
      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
        E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
        E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
             E.&&. course E.^. CourseTerm      E.==. E.val tid
             E.&&. course E.^. CourseSchool    E.==. E.val ssh
             E.&&. course E.^. CourseShorthand E.==. E.val csh
        when onlyActive $
          E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
      -- participant has at least one submission
      unless onlyActive $
        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
          E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
          E.on $ sheet  E.^. SheetId   E.==. submission E.^. SubmissionSheet
          E.on $ course E.^. CourseId  E.==. sheet E.^. SheetCourse
          E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant
               E.&&. course E.^. CourseTerm      E.==. E.val tid
               E.&&. course E.^. CourseSchool    E.==. E.val ssh
               E.&&. course E.^. CourseShorthand E.==. E.val csh
      -- participant is member of a submissionGroup
      unless onlyActive $
        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
          E.on $ submissionGroup E.^. SubmissionGroupId  E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
          E.on $ course E.^. CourseId  E.==. submissionGroup E.^. SubmissionGroupCourse
          E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
               E.&&. course E.^. CourseTerm      E.==. E.val tid
               E.&&. course E.^. CourseSchool    E.==. E.val ssh
               E.&&. course E.^. CourseShorthand E.==. E.val csh
      -- participant is a sheet corrector
      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
        E.on $ sheet  E.^. SheetId   E.==. sheetCorrector E.^. SheetCorrectorSheet
        E.on $ course E.^. CourseId  E.==. sheet E.^. SheetCourse
        E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
             E.&&. course E.^. CourseTerm      E.==. E.val tid
             E.&&. course E.^. CourseSchool    E.==. E.val ssh
             E.&&. course E.^. CourseShorthand E.==. E.val csh
      -- participant is a tutorial user
      unless onlyActive $
        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
          E.on $ tutorial  E.^. TutorialId   E.==. tutorialUser E.^. TutorialParticipantTutorial
          E.on $ course E.^. CourseId  E.==. tutorial E.^. TutorialCourse
          E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
               E.&&. course E.^. CourseTerm      E.==. E.val tid
               E.&&. course E.^. CourseSchool    E.==. E.val ssh
               E.&&. course E.^. CourseShorthand E.==. E.val csh
      -- participant is tutor for this course
      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
        E.on $ tutorial  E.^. TutorialId   E.==. tutor E.^. TutorTutorial
        E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
        E.where_ $ tutor E.^. TutorUser E.==. E.val participant
             E.&&. course E.^. CourseTerm      E.==. E.val tid
             E.&&. course E.^. CourseSchool    E.==. E.val ssh
             E.&&. course E.^. CourseShorthand E.==. E.val csh
      -- participant is exam corrector for this course
      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
        E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
        E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
        E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val participant
             E.&&. course E.^. CourseTerm      E.==. E.val tid
             E.&&. course E.^. CourseSchool    E.==. E.val ssh
             E.&&. course E.^. CourseShorthand E.==. E.val csh
      -- participant is lecturer for this course
      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
        E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
        E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
             E.&&. course E.^. CourseTerm      E.==. E.val tid
             E.&&. course E.^. CourseSchool    E.==. E.val ssh
             E.&&. course E.^. CourseShorthand E.==. E.val csh
      -- participant has an exam result for this course
      unless onlyActive $
        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
          E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
          E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
          E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant
               E.&&. course E.^. CourseTerm      E.==. E.val tid
               E.&&. course E.^. CourseSchool    E.==. E.val ssh
               E.&&. course E.^. CourseShorthand E.==. E.val csh
      -- participant is registered for an exam for this course
      unless onlyActive $
        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
          E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
          E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
          E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant
               E.&&. course E.^. CourseTerm      E.==. E.val tid
               E.&&. course E.^. CourseSchool    E.==. E.val ssh
               E.&&. course E.^. CourseShorthand E.==. E.val csh
tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
  CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
    uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    isApplicant <- isCourseApplicant tid ssh csh uid
    guard isApplicant
    return Authorized

  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedApplicantSelf) $ do
    uid <- hoistMaybe mAuthId
    isApplicant <- isCourseApplicant tid ssh csh uid
    guard isApplicant
    return Authorized

  r -> $unsupportedAuthPredicate AuthApplicant r
  where
    isCourseApplicant tid ssh csh uid = lift . $cachedHereBinary (uid, tid, ssh, csh) . E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
      E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
      E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
  CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do
    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn
    Entity occId ExamOccurrence{..} <- $cachedHereBinary (eid, occn) . MaybeT . getBy $ UniqueExamOccurrence eid occn
    registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ]
    guard $ examOccurrenceCapacity > registered
    return Authorized
  CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do
    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
    registered <- $cachedHereBinary tutId . lift $ count [ TutorialParticipantTutorial ==. tutId ]
    guard $ NTop tutorialCapacity > NTop (Just registered)
    return Authorized
  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
    Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    registered <- $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
    guard $ NTop courseCapacity > NTop (Just registered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthCapacity r
tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of
  CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
    case (tutorialRegGroup, mAuthId) of
      (Nothing, _) -> return Authorized
      (_, Nothing) -> return AuthenticationRequired
      (Just rGroup, Just uid) -> do
        hasOther <- $cachedHereBinary (uid, rGroup) . lift . E.selectExists . E.from $ \(tutorial `E.InnerJoin` participant) -> do
          E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
           E.&&. tutorial E.^. TutorialCourse E.==. E.val tutorialCourse
           E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup)
           E.&&. participant E.^. TutorialParticipantUser E.==. E.val uid
        guard $ not hasOther
        return Authorized
  r -> $unsupportedAuthPredicate AuthRegisterGroup r
tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of
  EExamListR -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
      E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
      E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
        E.||. E.exists (E.from $ \externalExamResult ->
            E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId
                 E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId
          )
    guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
    return Authorized
  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
    -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
    assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
      E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
    return Authorized
  r -> $unsupportedAuthPredicate AuthEmpty r
tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
    Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    guard courseMaterialFree
    return Authorized
  r -> $unsupportedAuthPredicate AuthMaterials r
tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
    sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
    return Authorized
  r -> $unsupportedAuthPredicate AuthOwner r
tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of
  CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do
    Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do
      cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
      MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn
    if | sheetAllowNonPersonalisedSubmission -> return Authorized
       | otherwise -> do
           authId <- maybeExceptT AuthenticationRequired $ return mAuthId
           flip guardMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) <=< $cachedHereBinary (shId, authId) . lift $
             E.selectExists . E.from $ \psFile ->
               E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. E.val shId
                    E.&&. psFile E.^. PersonalisedSheetFileUser  E.==. E.val authId
                    E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count
           return Authorized
  r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r
tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
    sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    sub <- MaybeT $ get sid
    guard $ submissionRatingDone sub
    return Authorized
  r -> $unsupportedAuthPredicate AuthRated r
tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
  CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
    Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
    guard $ is _Just submissionModeUser
    return Authorized
  r -> $unsupportedAuthPredicate AuthUserSubmissions r
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
  CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
    Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
    guard submissionModeCorrector
    return Authorized
  r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do
  referencedUser' <- case route of
    AdminUserR cID -> return $ Left cID
    AdminUserDeleteR cID -> return $ Left cID
    AdminHijackUserR cID -> return $ Left cID
    UserNotificationR cID -> return $ Left cID
    UserPasswordR cID -> return $ Left cID
    CourseR _ _ _ (CUserR cID) -> return $ Left cID
    CApplicationR _ _ _ cID _ -> do
      appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
      CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
      return $ Right courseApplicationUser
    _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
  referencedUser <- case referencedUser' of
    Right uid -> return uid
    Left cID  -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
  case mAuthId of
    Just uid
      | uid == referencedUser -> return Authorized
    Nothing -> return AuthenticationRequired
    _other  -> unauthorizedI MsgUnauthorizedSelf
tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
  referencedUser <- case route of
    AdminUserR cID -> return cID
    AdminUserDeleteR cID -> return cID
    AdminHijackUserR cID -> return cID
    UserNotificationR cID -> return cID
    UserPasswordR cID -> return cID
    CourseR _ _ _ (CUserR cID) -> return cID
    _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
  referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
  maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
    User{..} <- MaybeT $ get referencedUser'
    guard $ userAuthentication == AuthLDAP
  return Authorized
tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do
  referencedUser <- case route of
    AdminUserR cID -> return cID
    AdminUserDeleteR cID -> return cID
    AdminHijackUserR cID -> return cID
    UserNotificationR cID -> return cID
    UserPasswordR cID -> return cID
    CourseR _ _ _ (CUserR cID) -> return cID
    _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
  referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
  maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
    User{..} <- MaybeT $ get referencedUser'
    guard $ is _AuthPWHash userAuthentication
  return Authorized
tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
  MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
    let isAuthenticated = isJust mAuthId
    guard $ not systemMessageAuthenticatedOnly || isAuthenticated
    return Authorized
  MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
    let isAuthenticated = isJust mAuthId
    guard $ not systemMessageAuthenticatedOnly || isAuthenticated
    return Authorized
  r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do
  MsgRenderer mr <- ask
  return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite
tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do
  MsgRenderer mr <- ask
  return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite


authTagSpecificity :: AuthTag -> AuthTag -> Ordering
-- ^ Heuristic for which `AuthTag`s to evaluate first
authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem
  where
    eqClasses :: [[AuthTag]]
    -- ^ Constructors of `AuthTag` ordered (increasing) by execution order
    eqClasses =
      [ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide
      , [ AuthRead, AuthWrite, AuthToken ] -- Request wide
      , [ AuthAdmin ] -- Site wide
      , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthCourseTime, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide
      , [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide
      , [ AuthOwner, AuthRated ] -- Submission wide
      ]

defaultAuthDNF :: AuthDNF
defaultAuthDNF = PredDNF $ Set.fromList
  [ impureNonNull . Set.singleton $ PLVariable AuthAdmin
  , impureNonNull . Set.singleton $ PLVariable AuthToken
  ]

routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
-- ^ DNF up to entailment:
--
-- > (A_1 && A_2 && ...) OR' B OR' ...
--
-- > A OR' B := ((A |- B) ==> A) && (A || B)
routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs
  where
    partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral))
    partition' prev t
      | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
        = if
           | oany (authTags `Set.isSubsetOf`) prev
             -> Right prev
           | otherwise
             -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev
      | otherwise
        = Left $ InvalidAuthTag t

evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
-- ^ `tell`s disabled predicates, identified as pivots
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
  = do
      mr <- getMsgRenderer
      let
        authVarSpecificity = authTagSpecificity `on` plVar
        authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF'

        authTagIsInactive = not . authTagIsActive

        evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
        evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
          where
            evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
              $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
              evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'

        evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
        evalAuthLiteral PLVariable{..} = evalAuthTag plVar
        evalAuthLiteral PLNegated{..} = notAR mr plVar <$> evalAuthTag plVar

        orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
        orAR' = shortCircuitM (is _Authorized) (orAR mr)
        andAR' = shortCircuitM (is _Unauthorized) (andAR mr)

        evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
        evalDNF = maybe (return $ falseAR mr) (ofoldr1 orAR') . fromNullable . map evalConj
          where
            evalConj = maybe (return $ trueAR mr) (ofoldr1 andAR') . fromNullable . map evalAuthLiteral

      $logDebugS "evalAuthTags" . tshow . (route, isWrite, ) $ map (map $ id &&& authTagIsActive . plVar) authDNF

      result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF

      unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
        whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
          let pivots = filter (authTagIsInactive . plVar) conj
          whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
            let pivots' = plVar <$> pivots
            $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|]
            tell $ Set.fromList pivots'

      return result

evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessFor mAuthId route isWrite = do
  dnf <- either throwM return $ routeAuthTags route
  fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite

evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessForDB = evalAccessFor

evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult
evalAccessWith assumptions route isWrite = do
  mAuthId <- liftHandler maybeAuthId
  tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
  dnf <- either throwM return $ routeAuthTags route
  let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf
  case dnf' of
    Nothing -> return Authorized
    Just dnf'' -> do
      (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite
      result <$ tellSessionJson SessionInactiveAuthTags deactivated
  
evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessWithDB = evalAccessWith

evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess = evalAccessWith []

evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessDB = evalAccess

-- | Check whether the current user is authorized by `evalAccess` for the given route
--   Convenience function for a commonly used code fragment
hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m Bool
hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite

-- | Check whether the current user is authorized by `evalAccess` to read from the given route
--   Convenience function for a commonly used code fragment
hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool
hasReadAccessTo = flip hasAccessTo False

-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route
--   Convenience function for a commonly used code fragment
hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool
hasWriteAccessTo = flip hasAccessTo True

wouldHaveAccessTo :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX )
                  => [(AuthTag, Bool)] -- ^ Assumptions
                  -> Route UniWorX
                  -> Bool
                  -> m Bool
wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite

wouldHaveReadAccessTo, wouldHaveWriteAccessTo
  :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX )
  => [(AuthTag, Bool)] -- ^ Assumptions
  -> Route UniWorX
  -> m Bool
wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route False
wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True

wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
  :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX )
  => [(AuthTag, Bool)] -- ^ Assumptions
  -> Route UniWorX
  -> m Bool
wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route
wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route