{-# LANGUAGE UndecidableInstances, InstanceSigs #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints -fprof-auto #-}

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

import Import.NoFoundation hiding (Last(..))

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

import Foundation.DB

import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam
import Handler.Utils.Memcached
import Handler.Utils.I18n
import Handler.Utils.Routes
import Utils.Course (courseIsVisible)
import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..))
  
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 Data.Semigroup (Last(..))

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

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

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

-- import qualified Data.Conduit.Combinators as C

import qualified Data.Binary as Binary

import GHC.TypeLits (TypeError)
import qualified GHC.TypeLits as TypeError (ErrorMessage(..))

-- import Utils.VolatileClusterSettings


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


type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
  
data AccessPredicate
  = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
  | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
  | APDB       (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
  | APBind     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either AccessPredicate AuthResult))
  | APBindDB   (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either (ReaderT SqlReadBackend (HandlerFor UniWorX) (Either AccessPredicate AuthResult)) (Either AccessPredicate AuthResult)))

class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where
  evalAccessPred :: AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult

  apRunDB :: forall a. ReaderT SqlReadBackend (HandlerFor UniWorX) a -> m a

type family DisabledMonadAPInstance t err :: Constraint where
  DisabledMonadAPInstance t err
    = TypeError (                 'TypeError.Text "Used dangerous MonadAP instance for: " 'TypeError.:<>: 'TypeError.ShowType t
                  'TypeError.:$$: 'TypeError.Text "This instance is currently disabled via TypeError because: " 'TypeError.:<>: err
                  'TypeError.:$$: 'TypeError.Text "Please consider removing the usage triggering this error message before re-enabling or removing the instance."
                )

instance ( BearerAuthSite UniWorX
         -- , DisabledMonadAPInstance (HandlerFor UniWorX) ('TypeError.Text "It causes too many database connections")
         ) => MonadAP (HandlerFor UniWorX) where
  evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult
  evalAccessPred aPred contCtx cont aid r w = case aPred of
    (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
    (APHandler p) -> p aid r w
    (APDB      p) -> apRunDB $ p contCtx cont aid r w
    (APBind    p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w
    (APBindDB  p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w
                      in p aid r w >>= either apRunDB return >>= either contAP return

  apRunDB :: forall a. HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> HandlerFor UniWorX a
  apRunDB = runDBRead' callStack

instance BearerAuthSite UniWorX => MonadAP (WidgetFor UniWorX) where
  evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WidgetFor UniWorX AuthResult
  evalAccessPred aPred contCtx cont aid r w = liftHandler $ evalAccessPred aPred contCtx cont aid r w

  apRunDB :: forall a. HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> WidgetFor UniWorX a
  apRunDB = liftHandler . apRunDB

instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP (ReaderT backend m) where
  evalAccessPred aPred contCtx cont 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 contCtx cont aid r w
    (APBind    p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w
    (APBindDB  p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w
                      in lift (p aid r w) >>= either id return >>= either contAP return

  apRunDB = hoist liftHandler . withReaderT projectBackend

-- cacheAP :: ( Binary k
--            , Typeable v, Binary v
--            )
--         => Maybe Expiry
--         -> k
--         -> HandlerFor UniWorX v
--         -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
--         -> AccessPredicate
-- cacheAP mExp k mkV cont = APBind $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV

cacheAPDB :: ( Binary k
             , Typeable v, Binary v, NFData v
             )
          => Maybe Expiry
          -> k
          -> ReaderT SqlReadBackend (HandlerFor UniWorX) v
          -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
          -> AccessPredicate
cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do
  cachedV <- memcachedByGet k
  case cachedV of
    Just v -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite v
    Nothing -> return . Left $ do
      v <- mkV
      memcachedBySet mExp k v
      either (return . Left) (fmap Right . lift) $ cont mAuthId route isWrite v
 
-- cacheAP' :: ( Binary k
--             , Typeable v, Binary v
--             )
--          => Maybe Expiry
--          -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v))
--          -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
--          -> AccessPredicate
-- cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
--   Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV
--   Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
  
cacheAPDB' :: ( Binary k
              , Typeable v, Binary v, NFData v
              )
           => Maybe Expiry
           -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, ReaderT SqlReadBackend (HandlerFor UniWorX) v))
           -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
           -> AccessPredicate
cacheAPDB' mExp mkKV cont = APBindDB $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
  Just (k, mkV) -> do
    cachedV <- memcachedByGet k
    case cachedV of
      Just v -> fmap Right . either (return . Left) (fmap Right) . cont mAuthId route isWrite $ Just v
      Nothing -> return . Left $ do
        v <- mkV
        memcachedBySet mExp k v
        either (return . Left) (fmap Right . lift) . cont mAuthId route isWrite $ Just v
  Nothing -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing


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

_orARI18n, _andARI18n :: MsgRenderer -> I18nAuthResult -> I18nAuthResult -> I18nAuthResult
_orARI18n _  AuthorizedI18n _ = AuthorizedI18n
_orARI18n _  _ AuthorizedI18n = AuthorizedI18n
_orARI18n _  AuthenticationRequiredI18n _  = AuthenticationRequiredI18n
_orARI18n _  _ AuthenticationRequiredI18n  = AuthenticationRequiredI18n
_orARI18n mr (UnauthorizedI18n x) (UnauthorizedI18n y) = fmap (Unauthorized . render mr) . MsgUnauthorizedOr <$> x <*> y
_orARI18n mr _ _ = UnauthorizedI18n . opoint $ render mr MsgUnauthorizedI18nMismatch
-- and
_andARI18n mr (UnauthorizedI18n x) (UnauthorizedI18n y) = fmap (Unauthorized . render mr) . MsgUnauthorizedAnd <$> x <*> y
_andARI18n _ reason@(UnauthorizedI18n _) _ = reason
_andARI18n _ _ reason@(UnauthorizedI18n _) = reason
_andARI18n _ AuthorizedI18n other = other
_andARI18n _  AuthenticationRequiredI18n  _ = AuthenticationRequiredI18n
_andARI18n mr _ _ = UnauthorizedI18n . opoint $ render mr MsgUnauthorizedI18nMismatch

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 stock instance Eq (AuthId UniWorX) => Eq AuthContext
deriving stock instance Ord (AuthId UniWorX) => Ord AuthContext
deriving stock instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext
deriving stock 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
    <$> defaultMaybeAuthId
    <*> runMaybeT (exceptTMaybe askBearerUnsafe)
    <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags)

  $logDebugS "getAuthContext" $ tshow authCtx

  return authCtx

newtype IsDryRun = MkIsDryRun { unIsDryRun :: Bool }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

isDryRun :: ( HasCallStack
            , BearerAuthSite UniWorX
            )
         => HandlerFor UniWorX Bool
isDryRun = fmap unIsDryRun . cached . fmap MkIsDryRun $ runDBRead isDryRunDB

isDryRunDB :: forall m backend.
              ( HasCallStack
              , MonadAP m, MonadCatch m
              , BearerAuthSite UniWorX
              , WithRunDB backend (HandlerFor UniWorX) m
              , BackendCompatible SqlReadBackend backend
              )
           => m Bool
isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM
  [ hasGlobalPostParam PostDryRun
  , hasGlobalGetParam GetDryRun
  , and2M bearerDryRun bearerRequired
  ]
  where
    bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value
    bearerRequired = maybeT (return True) . catchIfMaybeT cPred $ do
      mAuthId <- liftHandler defaultMaybeAuthId
      currentRoute <- liftHandler $ maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
      isWrite <- liftHandler $ isWriteRequest currentRoute

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

      dnf <- throwLeft $ routeAuthTags currentRoute
      let eval :: forall m'. MonadAP m' => AuthTagsEval m'
          eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
       in guardAuthResult <=< evalWriterT $ eval 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 :: forall m.
                  ( HasCallStack
                  , MonadHandler m, HandlerSite m ~ UniWorX
                  , MonadCatch m, MonadAP m
                  , BearerAuthSite UniWorX
                  )
               => Maybe (AuthId UniWorX)
               -> Route UniWorX
               -> Bool -- ^ @isWrite@
               -> BearerToken UniWorX
               -> m 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 m AuthResult
    validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
      iforM_ bearerRoutes $ \case
        BearerTokenRouteEval -> \routes -> guardMExceptT (HashSet.member route routes) $ unauthorizedI MsgUnauthorizedTokenInvalidRoute
        BearerTokenRouteAccess -> \routes -> maybeTMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidRoute) $ do
          cRoute <- MaybeT getCurrentRoute
          guard $ HashSet.member cRoute routes

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

        eval :: forall m'. MonadAP m' => AuthTagsEval m'
        eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''

      bearerAuthority' <- hoist apRunDB $ do
        bearerAuthority' <- flip foldMapM bearerAuthority $ \case
          Left tVal
            | JSON.Success groupName <- JSON.fromJSON tVal -> do
                Entity _ primary <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . getBy $ UniquePrimaryUserGroupMember groupName Active
                case bearerImpersonate of
                  Nothing -> return . Set.singleton $ userGroupMemberUser primary
                  Just iuid | iuid == userGroupMemberUser primary -> return . Set.singleton $ userGroupMemberUser primary
                            | otherwise -> do
                                unlessM (lift $ exists [UserGroupMemberUser ==. iuid, UserGroupMemberGroup ==. groupName]) $
                                  throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
                                return $ Set.singleton iuid
            | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
          Right uid -> case bearerImpersonate of
            Just iuid | uid == iuid -> return $ Set.singleton uid
                      | otherwise -> do
                          cID <- encrypt iuid
                          unlessM (lift $ is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $
                            throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
                          return $ Set.singleton iuid
            Nothing -> return $ Set.singleton uid

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

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

        return bearerAuthority'

      forM_ bearerAuthority' $ \uid -> do
        authorityVal <- do
          dnf <- throwLeft $ routeAuthTags route
          lift . evalWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite
        guardExceptT (is _Authorized authorityVal) authorityVal

      whenIsJust bearerAddAuth $ \addDNF -> do
        $logDebugS "validateToken" $ tshow addDNF
        additionalVal <- lift . evalWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite
        guardExceptT (is _Authorized additionalVal) additionalVal

      return Authorized

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

requireBearerToken :: forall m.
                      ( HasCallStack
                      , MonadHandler m, HandlerSite m ~ UniWorX
                      , BearerAuthSite UniWorX
                      , MonadAP m
                      , MonadCatch m
                      )
                   => m (BearerToken UniWorX)
requireBearerToken = do
  bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
  mAuthId <- defaultMaybeAuthId -- `maybeAuthId` would be an infinite loop; this is equivalent to `maybeAuthId` but ignoring `bearerImpersonate` from any valid token
  currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
  isWrite <- liftHandler $ isWriteRequest currentRoute
  guardAuthResult =<< validateBearer mAuthId currentRoute isWrite bearer
  return bearer

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

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

data AuthorizationCacheKey
  = AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
  | AuthCacheLecturerList | AuthCacheExternalExamStaffList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList
  | AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand
  | AuthCacheVisibleSystemMessages
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (Hashable, Binary)

cacheAPSchoolFunction :: BearerAuthSite UniWorX
                      => SchoolFunction
                      -> Maybe Expiry
                      -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
                      -> AccessPredicate
cacheAPSchoolFunction f mExp = cacheAPDB mExp (AuthCacheSchoolFunctionList f) mkFunctionList
  where
    mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do
      E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val f
      return $ userFunction E.^. UserFunctionUser

cacheAPSystemFunction :: BearerAuthSite UniWorX
                      => SystemFunction
                      -> Maybe Expiry
                      -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
                      -> AccessPredicate
cacheAPSystemFunction f mExp = cacheAPDB mExp (AuthCacheSystemFunctionList f) mkFunctionList
  where
    mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userSystemFunction -> do
      E.where_ $ userSystemFunction E.^. UserSystemFunctionFunction E.==. E.val f
           E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut)
      return $ userSystemFunction E.^. UserSystemFunctionUser

tagAccessPredicate :: ( HasCallStack
                      , BearerAuthSite UniWorX
                      )
                   => AuthTag -> AccessPredicate
tagAccessPredicate AuthFree = trueAP
tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right diffHour) $ \mAuthId' route' _ adminList -> if
  | maybe True (`Set.notMember` adminList) mAuthId' -> Right $ case route' of
      _ | is _Nothing mAuthId' -> return AuthenticationRequired
      CourseR{} -> unauthorizedI MsgUnauthorizedSchoolAdmin
      AllocationR{} -> unauthorizedI MsgUnauthorizedSchoolAdmin
      SchoolR _ _ -> unauthorizedI MsgUnauthorizedSchoolAdmin
      _other -> unauthorizedI MsgUnauthorizedSiteAdmin
  | otherwise -> Left $ 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 . existsBy $ UniqueUserFunction authId ssh 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 = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if
  | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if
      | is _Nothing mAuthId' -> return AuthenticationRequired
      | otherwise -> unauthorizedI MsgUnauthorizedSystemExamOffice
  | otherwise -> Left $ 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 AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if
  | maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if
      | is _Nothing mAuthId' -> return AuthenticationRequired
      | otherwise -> unauthorizedI MsgUnauthorizedStudent
  | otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      isStudent <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemStudent, UserSystemFunctionIsOptOut ==. False]
      guardMExceptT isStudent $ unauthorizedI MsgUnauthorizedStudent
      return Authorized
tagAccessPredicate AuthExamOffice = cacheAPSchoolFunction SchoolExamOffice (Just $ Right diffHour) $ \mAuthId' route' _ examOfficeList -> if
  | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ case route' of
      _ | is _Nothing mAuthId' -> return AuthenticationRequired
      CExamR{} -> unauthorizedI MsgUnauthorizedExamExamOffice
      EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamExamOffice
      CourseR{} -> unauthorizedI MsgUnauthorizedExamExamOffice
      SchoolR _ _ -> unauthorizedI MsgUnauthorizedSchoolExamOffice
      _other -> unauthorizedI MsgUnauthorizedExamOffice
  | otherwise -> Left $ 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
      SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
        authId <- maybeExceptT AuthenticationRequired $ return mAuthId
        isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice
        guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedSchoolExamOffice)
        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 = cacheAPSchoolFunction SchoolEvaluation (Just $ Right diffHour) $ \mAuthId' _ _ evaluationList -> if
  | maybe True (`Set.notMember` evaluationList) mAuthId' -> Right $ if
      | is _Nothing mAuthId' -> return AuthenticationRequired
      | otherwise -> unauthorizedI MsgUnauthorizedEvaluation
  | otherwise -> Left $ 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 = cacheAPSchoolFunction SchoolAllocation (Just $ Right diffHour) $ \mAuthId' _ _ allocationList -> if
  | maybe True (`Set.notMember` allocationList) mAuthId' -> Right $ if
      | is _Nothing mAuthId' -> return AuthenticationRequired
      | otherwise -> unauthorizedI MsgUnauthorizedAllocationAdmin
  | otherwise -> Left $ 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 = cacheAPDB' (Just $ Right diffMinute) mkLecturerList $ \mAuthId' route' _ mLecturerList -> if
  | Just lecturerList <- mLecturerList
  , maybe True (`Set.notMember` lecturerList) mAuthId' -> Right $ case route' of
      _ | is _Nothing mAuthId' -> return AuthenticationRequired
      CourseR{} -> unauthorizedI MsgUnauthorizedLecturer
      AllocationR{} -> unauthorizedI MsgUnauthorizedAllocationLecturer
      EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamLecturer
      _other -> unauthorizedI MsgUnauthorizedSchoolLecturer 
  | otherwise -> Left $ 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
  where
    mkLecturerList _ route _ = case route of
      CourseR{} -> cacheLecturerList 
      AllocationR{} -> cacheLecturerList 
      EExamR{} -> Just
        ( AuthCacheExternalExamStaffList
        , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser)
        )
      _other -> Just
        ( AuthCacheSchoolFunctionList SchoolLecturer
        , fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do
            E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolLecturer
            return $ userFunction E.^. UserFunctionUser
        )
      where
        cacheLecturerList = Just
          ( AuthCacheLecturerList
          , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser)
          )
tagAccessPredicate AuthCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if
  | maybe True (`Set.notMember` correctorList) mAuthId' -> Right $ case route' of
      _ | is _Nothing mAuthId' -> return AuthenticationRequired
      CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionCorrector
      CSheetR{} -> unauthorizedI MsgUnauthorizedSheetCorrector
      CourseR{} -> unauthorizedI MsgUnauthorizedCorrector
      _other -> unauthorizedI MsgUnauthorizedCorrectorAny
  | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      case route of
        CSubmissionR _ _ _ _ cID _ -> lift . $cachedHereBinary (authId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
          sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
          guardM . lift . E.selectExists . E.from $ \submission ->
            E.where_ $ submission E.^. SubmissionId E.==. E.val sid
                 E.&&. submission E.^. SubmissionRatingBy E.==. E.justVal authId
          return Authorized
        CSheetR tid ssh csh shn _ -> lift . $cachedHereBinary (authId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
          guardM . lift . E.selectExists . 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
            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 Authorized
        CourseR tid ssh csh _ -> lift . $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
          guardM . lift . E.selectExists . 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
            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
          return Authorized
        _ -> lift . $cachedHereBinary mAuthId . maybeT (unauthorizedI MsgUnauthorizedCorrectorAny) $ do
          guardM . lift . E.selectExists . E.from $ \sheetCorrector ->
            E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
          return Authorized
  where
    mkCorrectorList = do
      submissionCorrectors <- E.select . E.from $ \submission -> E.distinctOnOrderBy [E.asc $ submission E.^. SubmissionRatingBy] $ do
        E.where_ . E.isJust $ submission E.^. SubmissionRatingBy
        return $ submission E.^. SubmissionRatingBy
      let submissionCorrectors' = Set.fromDistinctAscList $ mapMaybe (preview $ _Value . _Just) submissionCorrectors

      sheetCorrectors <- E.select . E.from $ \sheetCorrector -> E.distinctOnOrderBy [E.asc $ sheetCorrector E.^. SheetCorrectorUser] $
        return $ sheetCorrector E.^. SheetCorrectorUser
      let sheetCorrectors' = Set.fromDistinctAscList $ map (^. _Value) sheetCorrectors

      return $ submissionCorrectors' `Set.union` sheetCorrectors'
tagAccessPredicate AuthExamCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if
  | maybe True (`Set.notMember` examCorrectorList) mAuthId' -> Right $ case route' of
      _ | is _Nothing mAuthId' -> return AuthenticationRequired
      CExamR{} -> unauthorizedI MsgUnauthorizedExamCorrector
      CourseR{} -> unauthorizedI MsgUnauthorizedExamCorrector
      r -> $unsupportedAuthPredicate AuthExamCorrector r
  | otherwise -> Left $ 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
  where
    mkExamCorrectorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser)
tagAccessPredicate AuthTutor = cacheAPDB (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if
  | maybe True (`Set.notMember` tutorList) mAuthId' -> Right $ case route' of
      _ | is _Nothing mAuthId' -> return AuthenticationRequired
      CTutorialR{} -> unauthorizedI MsgUnauthorizedTutorialTutor
      CourseR{} -> unauthorizedI MsgUnauthorizedCourseTutor
      _other -> unauthorizedI MsgUnauthorizedTutor
  | otherwise -> Left $ 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
  where
    mkTutorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. TutorUser)
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 <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (course, shn) . getBy $ CourseSheet course shn
    when (is _RegisteredGroups sheetGrouping) $ do
      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) $ 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 $ \_ (runTACont -> cont) mAuthId route isWrite -> 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 <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
    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
    cTime <- liftIO getCurrentTime
    let cacheTime = diffDay
        massageVisible = Map.fromList . map (over _1 E.unValue . over (_2 . _1) E.unValue . over (_2 . _2) E.unValue)
    visibleSystemMessages <- lift . memcacheAuth' @(Map SystemMessageId (Maybe UTCTime, Maybe UTCTime)) (Right cacheTime) AuthCacheVisibleSystemMessages . fmap massageVisible . E.select . E.from $ \systemMessage -> do
      E.where_ $ E.maybe E.true (E.>=. E.val cTime) (systemMessage E.^. SystemMessageTo)
           E.&&. E.maybe E.false (E.<=. E.val (realToFrac diffDay `addUTCTime` cTime)) (systemMessage E.^. SystemMessageFrom) -- good enough.
      return
        ( systemMessage E.^. SystemMessageId
        , ( systemMessage E.^. SystemMessageFrom
          , systemMessage E.^. SystemMessageTo
          )
        )
    (msgFrom, msgTo) <- hoistMaybe $ Map.lookup smId visibleSystemMessages
    let cTime' = NTop $ Just cTime
    guard $ NTop msgFrom <= cTime'
         && NTop msgTo   >= 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 $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
  CourseR tid ssh csh CRegisterR -> do
    now <- liftIO getCurrentTime
    mba <- mbAllocation tid ssh csh
    case mba of
      Nothing -> return Authorized
      Just (_, Allocation{..}) -> do
        registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
        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 E.nothing
    guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime)
    return Authorized
  r -> $unsupportedAuthPredicate AuthCourseTime r
tagAccessPredicate AuthExamTime = APDB $ \_ _ _ route _ -> case route of
  CSubmissionR tid ssh csh shn _cID CorrectionR -> maybeT (unauthorizedI MsgUnauthorizedCorrectionExamTime) $ do
    cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity _sid Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn
    whenIsJust (sheetType ^? _examPart . from _SqlKey) $ \epId -> do
      ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
      Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
      now <- liftIO getCurrentTime
      guard $ NTop (Just now) >= NTop examFinished
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamTime r
tagAccessPredicate AuthCourseRegistered = cacheAPDB' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if
  | Just courseRegisteredList <- mCourseRegisteredList
  , maybe True (`Set.notMember` courseRegisteredList) mAuthId' -> Right $ case route' of
      _ | is _Nothing mAuthId' -> return AuthenticationRequired
      CourseR{} -> unauthorizedI MsgUnauthorizedRegistered
      r -> $unsupportedAuthPredicate AuthCourseRegistered r
  | otherwise -> Left $ 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
  where
    mkAuthCacheCourseRegisteredList _ route _ = case route of
      CourseR tid ssh csh _ -> Just
        ( AuthCacheCourseRegisteredList tid ssh csh
        , fmap (setOf $ folded . _Value) . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
            E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
            E.where_ $ 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
            return $ courseParticipant E.^. CourseParticipantUser
        )
      _other -> Nothing
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
    -- Nothing means unlimited size
    whenIsJust examOccurrenceCapacity $ \capacity -> do
      registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ]
      guard $ capacity > 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 AuthCorrectionAnonymous = APDB $ \_ _ _ route _ -> case route of
  CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectionAnonymous) $ do
    Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{ sheetAnonymousCorrection } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
    guard sheetAnonymousCorrection
    return Authorized
  r -> $unsupportedAuthPredicate AuthCorrectionAnonymous 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

runTACont :: forall m. MonadAP m
          => (forall m'. MonadAP m' => AuthTagsEval m')
          -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m Bool
runTACont cont dnf mAuthId route isWrite = is _Authorized <$> evalWriterT (cont dnf mAuthId route 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 = predDNFVar AuthAdmin `predDNFOr` predDNFVar AuthToken

routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
-- ^ DNF up to entailment, see `predDNFEntail`
routeAuthTags = fmap predDNFEntail . ofoldM parse defaultAuthDNF . routeAttrs
  where
    parse :: AuthDNF -> Text -> Either InvalidAuthTag AuthDNF
    parse prev t = case fromNullable . Set.fromList =<< mapM fromPathPiece (Text.splitOn "AND" t) of
      Just t' -> Right . predDNFOr prev . PredDNF $ Set.singleton t'
      Nothing -> Left $ InvalidAuthTag t

broadenRoute :: AuthTag -> Route UniWorX -> Route UniWorX
broadenRoute aTag route = case (aTag, route) of
  (AuthAdmin, CourseR tid ssh csh _) -> CourseR tid ssh csh CShowR
  (AuthAdmin, AllocationR tid ssh ash _) -> AllocationR tid ssh ash AShowR
  (AuthAdmin, SchoolR ssh _) -> SchoolR ssh SchoolEditR
  (AuthAdmin, _) -> NewsR

  (AuthStudent, _) -> NewsR

  (AuthExamOffice, CExamR tid ssh csh examn _) -> CExamR tid ssh csh examn EShowR
  (AuthExamOffice, EExamR tid ssh coursen examn _) -> EExamR tid ssh coursen examn EEShowR
  (AuthExamOffice, CourseR _ ssh _ _) -> SchoolR ssh SchoolEditR
  (AuthExamOffice, SchoolR ssh _) -> SchoolR ssh SchoolEditR
  (AuthExamOffice, _) -> NewsR

  (AuthLecturer, CourseR tid ssh csh _) -> CourseR tid ssh csh CShowR
  (AuthLecturer, AllocationR tid ssh ash _) -> AllocationR tid ssh ash AShowR
  (AuthLecturer, EExamR tid ssh coursen examn _) -> EExamR tid ssh coursen examn EEShowR
  (AuthLecturer, _) -> NewsR

  _other -> route

evalAuthTags :: forall ctx m. (HasCallStack, Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m
-- ^ `tell`s disabled predicates, identified as pivots
evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
  = do
      mr <- getMsgRenderer
      let
        contCtx = toStrict $ Binary.encode (ctx, authActive)
        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 (ctx, AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for5 memo (const evalAccessPred') ctx authTag mAuthId route'' isWrite
          where
            route'' = broadenRoute authTag route
            evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
              $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
              observeAuthTagEvaluation authTag' (classifyHandler route') $ do
                res <- evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite'
                return . (res, ) $ case res of
                  Authorized             -> OutcomeAuthorized
                  Unauthorized _         -> OutcomeUnauthorized
                  AuthenticationRequired -> OutcomeAuthenticationRequired

        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

evalAccessWithFor :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessWithFor assumptions mAuthId route isWrite = do
  isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
  tagActive <- if
    | isSelf    -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
    | otherwise -> return . AuthTagActive $ const True
  dnf <- throwLeft $ routeAuthTags route
  let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just
      evalAdj :: forall m'. MonadAP m' => AuthTagsEval m'
      evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of
        Nothing    -> return Authorized
        Just dnf'' -> evalAuthTags ('evalAccessWithFor, assumptions) tagActive evalAdj dnf'' mAuthId' route' isWrite'
   in do
    (result, deactivated) <- runWriterT $ evalAdj dnf mAuthId route isWrite
    when isSelf $
      tellSessionJson SessionInactiveAuthTags deactivated
    return result

evalAccessFor :: (HasCallStack, MonadThrow m, MonadAP m) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessFor = evalAccessWithFor []

evalAccessForDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessForDB = evalAccessFor

evalAccessWith :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult
evalAccessWith assumptions route isWrite = do
  mAuthId <- liftHandler maybeAuthId
  evalAccessWithFor assumptions mAuthId route isWrite
  
evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessWithDB = evalAccessWith

evalAccess :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> Bool -> m AuthResult
evalAccess = evalAccessWith []

evalAccessDB :: (HasCallStack, MonadThrow m, MonadAP m, 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 :: (HasCallStack, MonadThrow m, MonadAP m) => 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 :: (HasCallStack, MonadThrow m, MonadAP m) => 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 :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> m Bool
hasWriteAccessTo = flip hasAccessTo True

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

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

wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
  :: (HasCallStack, MonadThrow m, MonadAP m)
  => [(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


authoritiveApproot :: Route UniWorX -> ApprootScope
authoritiveApproot = \case
  CourseR _ _ _ (MaterialR _ (MFileR _))                      -> ApprootUserGenerated
  CourseR _ _ _ (MaterialR _ MArchiveR)                       -> ApprootUserGenerated
  CourseR _ _ _ (SheetR _ (SFileR _ _))                       -> ApprootUserGenerated
  CourseR _ _ _ (SheetR _ (SZipR _))                          -> ApprootUserGenerated
  CourseR _ _ _ (SheetR _ (SubmissionR _ (SubDownloadR _ _))) -> ApprootUserGenerated
  CourseR _ _ _ (SheetR _ (SubmissionR _ (SubArchiveR _)))    -> ApprootUserGenerated
  CourseR _ _ _ (CourseNewsR _ (CNFileR _))                   -> ApprootUserGenerated
  CourseR _ _ _ (CourseNewsR _ CNArchiveR)                    -> ApprootUserGenerated
  CourseR _ _ _ CRegisterTemplateR                            -> ApprootUserGenerated
  CourseR _ _ _ CAppsFilesR                                   -> ApprootUserGenerated
  CourseR _ _ _ (CourseApplicationR _ CAFilesR)               -> ApprootUserGenerated
  _other -> ApprootDefault