fradrive-old/src/Foundation.hs

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLabels #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns -fno-warn-redundant-constraints #-} -- MonadCrypto

module Foundation
  ( module Foundation
  ) where

import Foundation.Type as Foundation
import Foundation.Types as Foundation
import Foundation.I18n as Foundation
import Foundation.Routes as Foundation


import Import.NoFoundation hiding (embedFile)
import Database.Persist.Sql (runSqlPool)
import Text.Hamlet          (hamletFile)

import Yesod.Auth.Message
import Auth.LDAP
import Auth.PWHash
import Auth.Dummy

import qualified Network.Wai as W
import qualified Network.HTTP.Types.Header as W
import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)

import Yesod.Core.Types (HandlerContents)
import qualified Yesod.Core.Unsafe as Unsafe
import qualified Data.CaseInsensitive as CI

import Data.ByteArray (convert)
import Crypto.Hash (SHAKE256, SHAKE128)
import Crypto.Hash.Conduit (sinkHash)
import qualified Data.UUID as UUID
import qualified Data.Binary as Binary

import qualified Data.ByteString.Base64.URL as Base64 (encode)

import qualified Data.ByteString.Lazy as Lazy.ByteString
import qualified Data.ByteString as ByteString

import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text

import qualified Data.Set as Set
import Data.Map ((!?))
import qualified Data.Map as Map
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List.NonEmpty as NonEmpty

import Data.List ((!!), findIndex, inits)
import qualified Data.List as List

import Data.Conduit.List (sourceList)

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

import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.State (execStateT)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Memo.Class (MonadMemo(..), for4)
import Control.Monad.Reader.Class (MonadReader(local))
import qualified Control.Monad.Catch as C

import Handler.Utils.StudyFeatures
import Handler.Utils.SchoolLdap
import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam
import Handler.Utils.ExamOffice.Course
import Handler.Utils.Profile
import Handler.Utils.Routes
import Handler.Utils.Memcached
import Utils.Form
import Utils.Sheet
import Utils.SystemMessage
import Utils.Metrics

import Text.Cassius (cassiusFile)

import qualified Yesod.Auth.Message as Auth

import qualified Data.Conduit.List as C

import qualified Database.Memcached.Binary.IO as Memcached
import Data.Bits (Bits(zeroBits))

import Network.Wai.Parse (lbsBackEnd)

import qualified Data.Aeson as JSON
import Data.Aeson.Lens hiding (_Value, key)

import Data.FileEmbed (embedFile)

import qualified Ldap.Client as Ldap

import UnliftIO.Pool

import qualified Web.ServerSession.Core as ServerSession
import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession

import Web.Cookie

import Yesod.Core.Types (GHState(..), HandlerData(handlerState, handlerEnv), RunHandlerEnv(rheSite, rheChild))
import Database.Persist.Sql (transactionUndo, SqlReadBackend(..))

-- | Convenient Type Synonyms:
type DB = YesodDB UniWorX
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget)
type MsgRenderer = MsgRendererS UniWorX -- see Utils
type MailM a = MailT (HandlerFor UniWorX) a

-- Requires `rendeRoute`, thus cannot currently be moved to Foundation.I18n
instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
  renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
    where
      mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage f ls
      (pieces, _) = renderRoute route

data NavQuickView
  = NavQuickViewFavourite
  | NavQuickViewPageActionSecondary
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
  deriving (Universe, Finite)

navQuick :: NavQuickView -> (NavQuickView -> Any)
navQuick x x' = Any $ x == x'

data NavType
  = NavTypeLink
    { navModal  :: Bool
    }
  | NavTypeButton
    { navMethod :: StdMethod
    , navData   :: [(Text, Text)]
    }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (Binary)

makeLenses_ ''NavType
makePrisms ''NavType

data NavLevel = NavLevelTop | NavLevelInner
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX route, RedirectUrl UniWorX route) => NavLink
  { navLabel       :: msg
  , navRoute       :: route
  , navAccess'     :: Handler Bool
  , navType        :: NavType
  , navQuick'      :: NavQuickView -> Any
  , navForceActive :: Bool
  }

makeLenses_ ''NavLink

instance HasRoute UniWorX NavLink where
  urlRoute NavLink{..} = urlRoute navRoute
instance RedirectUrl UniWorX NavLink where
  toTextUrl NavLink{..} = toTextUrl navRoute
instance RenderMessage UniWorX NavLink where
  renderMessage app ls NavLink{..} = renderMessage app ls navLabel

data Nav
  = NavHeader
    { navHeaderRole :: NavHeaderRole
    , navIcon       :: Icon
    , navLink       :: NavLink
    }
  | NavHeaderContainer
    { navHeaderRole :: NavHeaderRole
    , navLabel      :: SomeMessage UniWorX
    , navIcon       :: Icon
    , navChildren   :: [NavLink]
    }
  | NavPageActionPrimary
    { navLink     :: NavLink
    , navChildren :: [NavLink]
    }
  | NavPageActionSecondary
    { navLink :: NavLink
    }
  | NavFooter
    { navLink :: NavLink
    } deriving (Generic, Typeable)

makeLenses_ ''Nav
makePrisms ''Nav
  
data NavChildren
type instance Children NavChildren a = ChildrenNavChildren a
type family ChildrenNavChildren a where
  ChildrenNavChildren (SomeMessage UniWorX) = '[]

  ChildrenNavChildren a = Children ChGeneric a

navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => Nav -> MaybeT m Nav
navAccess = execStateT $ do
  guardM $ preuse _navLink >>= maybe (return True) navLinkAccess

  _navChildren <~ (filterM navLinkAccess =<< use _navChildren)
  whenM (hasn't _navLink <$> use id) $
    guardM $ not . null <$> use _navChildren

navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => NavLink -> m Bool
navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute
  where
    shortCircuit :: HandlerContents -> m Bool
    shortCircuit _ = return False
    
    accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool
    accessCheck nt (urlRoute -> route) = do
      authCtx <- getAuthContext
      $memcachedByHere (Just $ Right 120) (authCtx, nt, route) $
        bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
  

getTimeLocale' :: [Lang] -> TimeLocale
getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])

appTZ :: TZ
appTZ = $(includeSystemTZ "Europe/Berlin")

appLanguagesOpts :: ( MonadHandler m
                    , HandlerSite m ~ UniWorX
                    ) => m (OptionList Lang)
-- ^ Authoritive list of supported Languages
appLanguagesOpts = do
  MsgRenderer mr <- getMsgRenderer
  let mkOption l = Option
        { optionDisplay = mr $ MsgLanguage l
        , optionInternalValue = l
        , optionExternalValue = l
        }
      langOptions = map mkOption $ toList appLanguages
  return $ mkOptionList langOptions
  
instance RenderMessage UniWorX WeekDay where
  renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)

newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }

instance RenderMessage UniWorX ShortWeekDay where
  renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)


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


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

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

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

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


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

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

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

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


data AuthContext = AuthContext
  { authCtxAuth    :: Maybe UserId
  , authCtxBearer  :: Maybe (BearerToken UniWorX)
  , authActiveTags :: AuthTagActive
  } deriving (Eq, Read, Show, Generic, Typeable)
    deriving anyclass (Hashable, Binary)

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

  $logDebugS "getAuthContext" $ tshow authCtx

  return authCtx


askBearerUnsafe :: forall m.
                  ( MonadHandler m
                  , HandlerSite m ~ UniWorX
                  , MonadCatch m
                  )
               => ExceptT AuthResult m (BearerToken UniWorX)
-- | This performs /no/ meaningful validation of the `BearerToken`
--
-- Use `requireBearerToken` or `maybeBearerToken` instead
askBearerUnsafe = $cachedHere $ 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 :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> ReaderT SqlReadBackend Handler AuthResult
validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token'
  where
    validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend Handler) AuthResult
    validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
      guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)

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

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

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

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

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

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

      return Authorized

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

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

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

isDryRun :: forall m.
            ( MonadHandler m
            , HandlerSite m ~ UniWorX
            , MonadCatch m
            )
         => m Bool
isDryRun = $cachedHere $ orM
  [ hasGlobalPostParam PostDryRun
  , hasGlobalGetParam GetDryRun
  , and2M bearerDryRun bearerRequired
  ]
  where
    bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value
    bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do
      mAuthId <- maybeAuthId
      currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
      isWrite <- isWriteRequest currentRoute
      
      let noTokenAuth :: AuthDNF -> AuthDNF
          noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar

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

      return False

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


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

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

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

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

    return Authorized

  CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
    cTime <- liftIO getCurrentTime
    registration <- case mAuthId of
      Just uid -> $cachedHereBinary (eId, uid) . lift . getBy $ UniqueExamRegistration eId uid
      Nothing  -> return Nothing

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

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

    return Authorized

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

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

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

    guard visible

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

    return Authorized

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

  CourseR tid ssh csh CRegisterR -> do
    now <- liftIO getCurrentTime
    mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
    registered <- case (mbc,mAuthId) of
      (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
      _ -> return False
    case mbc of
      (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
        | not registered
        , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed
        , maybe True  (now <=) courseRegisterTo      -> return Authorized
      (Just (Entity cid Course{courseDeregisterUntil}))
        | registered
          -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ 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 MsgUnauthorizedCourseTime
  
  CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
    Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
    allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation

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

    return Authorized

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

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

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

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

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

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

    return Authorized

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

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

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

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

  r -> $unsupportedAuthPredicate AuthAllocationTime r
  where
    mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do
      cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
      Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
      (cid,) <$> MaybeT (get allocationCourseAllocation)
tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
      E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
      E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
           E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthCourseRegistered r
tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of
  CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
      E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
      E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
      E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. tutorial E.^. TutorialName  E.==. E.val tutn
    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
      E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
      E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
      E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthTutorialRegistered r
tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ course E.^. CourseTerm       E.==. E.val tid
           E.&&. course E.^. CourseSchool     E.==. E.val ssh
           E.&&. course E.^. CourseShorthand  E.==. E.val csh
           E.&&. exam E.^. ExamName           E.==. E.val examn
           E.&&. exam E.^. ExamOccurrenceRule E.==. E.val ExamRoomFifo
    guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration)
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r
tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of
  CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do
      E.on $ E.just (examOccurrence E.^. ExamOccurrenceId) E.==. examRegistration E.^. ExamRegistrationOccurrence
      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
           E.&&. examOccurrence E.^. ExamOccurrenceName E.==. E.val occn
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. exam E.^. ExamName          E.==. E.val examn
    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. exam E.^. ExamName          E.==. E.val examn
           E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence)
    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence)
    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r
tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
           E.&&. exam E.^. ExamName          E.==. E.val examn
    guardMExceptT hasRegistration (unauthorizedI 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
    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
    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 Handler) ()
        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
      when (not 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
      when (not 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
      when (not 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
      when (not 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
      when (not 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

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


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

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

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

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

        authTagIsInactive = not . authTagIsActive

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

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

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

        evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
        evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr)

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

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

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

      return result

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

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

evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess route isWrite = do
  mAuthId <- liftHandler maybeAuthId
  tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
  dnf <- either throwM return $ routeAuthTags route
  (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite
  result <$ tellSessionJson SessionInactiveAuthTags deactivated

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

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

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

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

-- | Conditional redirect that hides the URL if the user is not authorized for the route
redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
redirectAccess url = do
  -- must hide URL if not authorized
  access <- evalAccess url False
  case access of
    Authorized -> redirect url
    _          -> permissionDeniedI MsgUnauthorizedRedirect

redirectAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route UniWorX -> m a
redirectAccessWith status url = do
  -- must hide URL if not authorized
  access <- evalAccess url False
  case access of
    Authorized -> redirectWith status url
    _          -> permissionDeniedI MsgUnauthorizedRedirect


-- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course
evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX)
            => TermId -> SchoolId -> CourseShorthand -> m AuthResult
evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False


data instance ButtonClass UniWorX
  = BCIsButton
  | BCDefault
  | BCPrimary
  | BCSuccess
  | BCInfo
  | BCWarning
  | BCDanger
  | BCLink
  | BCMassInputAdd | BCMassInputDelete
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
  deriving anyclass (Universe, Finite)

instance PathPiece (ButtonClass UniWorX) where
  toPathPiece BCIsButton = "btn"
  toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
  fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF

instance Button UniWorX ButtonSubmit where
  btnClasses BtnSubmit = [BCIsButton, BCPrimary]



-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod UniWorX where
    -- Controls the base of generated URLs. For more information on modifying,
    -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
    approot = ApprootRequest $ \app req ->
        case app ^. _appRoot of
            Nothing -> getApprootText guessApproot app req
            Just root -> root

    makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
        SessionStorageMemcachedSql sqlStore
          -> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
        SessionStorageAcid acidStore
          | appServerSessionAcidFallback
            -> mkBackend =<< stateSettings <$> ServerSession.createState acidStore
        _other
          -> return Nothing
      where
        cfg = JwtSession.ServerSessionJwtConfig
          { sJwtJwkSet     = appJSONWebKeySet
          , sJwtStart      = Nothing
          , sJwtExpiration = appSessionTokenExpiration
          , sJwtEncoding   = appSessionTokenEncoding
          , sJwtIssueBy    = appInstanceID
          , sJwtIssueFor   = appClusterID
          }
        mkBackend :: forall sto.
                   ( ServerSession.SessionData sto ~ Map Text ByteString
                   , ServerSession.Storage sto
                   )
                  => ServerSession.State sto -> IO (Maybe SessionBackend)
        mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
        stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
        stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
        sameSite
          | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
          = strictSameSiteSessions
          | Just sameSiteLax    == cookieSameSite (getCookieSettings app CookieSession)
          = laxSameSiteSessions
          | otherwise
          = id
        notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
        notForBearer = fmap $ fmap notForBearer'
          where notForBearer' :: SessionBackend -> SessionBackend
                notForBearer' (SessionBackend load)
                  = let load' req
                          | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
                          , any (is _Just) $ map W.extractBearerAuth aHdrs
                          = return (mempty, const $ return [])
                          | otherwise
                          = load req
                     in SessionBackend load'

    maximumContentLength app _ = app ^. _appMaximumContentLength

    -- Yesod Middleware allows you to run code before and after each handler function.
    -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
    -- Some users may also want to add the defaultCsrfMiddleware, which:
    --   a) Sets a cookie with a CSRF token in it.
    --   b) Validates that incoming write requests include that token in either a header or POST parameter.
    -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
    -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
    yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware
      where
        dryRunMiddleware :: Handler a -> Handler a
        dryRunMiddleware handler = do
          dryRun <- isDryRun
          if | dryRun -> do
                 hData <- ask
                 prevState <- readIORef (handlerState hData) 
                 let
                   restoreSession =
                     modifyIORef (handlerState hData) $
                       \hst -> hst { ghsSession = ghsSession prevState
                                   , ghsCache = ghsCache prevState
                                   , ghsCacheBy = ghsCacheBy prevState
                                   }
                   site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing }
                   handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler

                 addCustomHeader HeaderDryRun ("1" :: Text)
                 
                 handler' `finally` restoreSession
             | otherwise -> handler
        updateFavouritesMiddleware :: Handler a -> Handler a
        updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
          route <- MaybeT getCurrentRoute
          case route of -- update Course Favourites here
            CourseR tid ssh csh _  -> do
              void . lift . runDB . runMaybeT $ do
                guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
                lift . updateFavourites $ Just (tid, ssh, csh)
            _other -> return ()
        normalizeRouteMiddleware :: Handler a -> Handler a
        normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do
          route <- MaybeT getCurrentRoute
          (route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers
          when changed $ do
            $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
            redirectWith movedPermanently301 route'
        headerMessagesMiddleware :: Handler a -> Handler a
        headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
          isModal <- hasCustomHeader HeaderIsModal
          dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
          massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit
          $logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit)
          guard $ or
            [ isModal
            , dbTableShortcircuit
            , massInputShortcircuit
            ]

          lift . bracketOnError getMessages (mapM_ addMessage') $
            addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
        observeYesodCacheSizeMiddleware :: Handler a -> Handler a
        observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
        csrfMiddleware :: Handler a -> Handler a
        csrfMiddleware handler = do
          hasBearer <- is _Just <$> lookupBearerAuth

          if | hasBearer -> handler
             | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
          where
            csrfSetCookieMiddleware' handler' = do
              mcsrf <- reqToken <$> getRequest
              whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken
              handler'
        storeBearerMiddleware :: Handler a -> Handler a
        storeBearerMiddleware handler = do
          askBearer >>= \case
            Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs
            Nothing       -> return ()

          handler

    -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
    defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"

    errorHandler err = do
      shouldEncrypt <- do
        canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
        shouldEncrypt <- getsYesod $ view _appEncryptErrors
        return $ shouldEncrypt && not canDecrypt

      sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
      setSessionJson SessionError sessErr

      selectRep $ do
        provideRep $ do
          mr <- getMessageRender
          let
            encrypted :: ToJSON a => a -> Widget -> Widget
            encrypted plaintextJson plaintext = do
              if
                | shouldEncrypt -> do
                    ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson

                    [whamlet|
                      <p>_{MsgErrorResponseEncrypted}
                      <pre .errMsg>
                        #{ciphertext}
                    |]
                | otherwise -> plaintext

            errPage = case err of
              NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
              InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
              InvalidArgs errs -> [whamlet|
                  <ul>
                    $forall err' <- errs
                      <li .errMsg>#{err'}
                 |]
              NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
              PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
              BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
          siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
            toWidget
              [cassius|
                .errMsg
                  white-space: pre-wrap
                  font-family: monospace
              |]
            errPage
        provideRep . fmap PrettyValue $ case err of
          PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
          InternalError err'
            | shouldEncrypt -> do
                ciphertext <- encodedSecretBox SecretBoxShort err'
                return $ object [ "message" JSON..= ciphertext
                                , "encrypted" JSON..= True
                                ]
            | otherwise -> return $ object [ "message" JSON..= err' ]
          InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
          _other -> return $ object []
        provideRep $ case err of
          PermissionDenied err' -> return err'
          InternalError err'
            | shouldEncrypt -> do
                addHeader "Encrypted-Error-Message" "True"
                encodedSecretBox SecretBoxPretty err'
            | otherwise -> return err'
          InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
          _other -> return Text.empty

    defaultLayout = siteLayout' Nothing

    -- The page to be redirected to when authentication is required.
    authRoute _ = Just $ AuthR LoginR

    isAuthorized = evalAccess

    addStaticContent ext _mime content = do
      UniWorX{appWidgetMemcached, appSettings'} <- getYesod
      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
        let expiry = maybe 0 ceiling memcachedExpiry
            touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
            add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
            absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
        C.catchIf Memcached.isKeyNotFound touch $ \_ ->
          C.handleIf Memcached.isKeyExists (\_ -> return ()) add
        return . Left $ pack absoluteLink
      where
        -- Generate a unique filename based on the content itself, this is used
        -- for deduplication so a collision resistant hash function is required
        --
        -- SHA-3 (SHAKE256) seemed to be a future-proof choice
        --
        -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
        -- padding after base64-conversion
        fileName = (<.> unpack ext)
                 . unpack
                 . decodeUtf8
                 . Base64.encode
                 . (convert :: Digest (SHAKE256 144) -> ByteString)
                 . runConduitPure
                 $ sourceList (Lazy.ByteString.toChunks content) .| sinkHash

    fileUpload _site _length = FileUploadMemory lbsBackEnd

    -- What messages should be logged. The following includes all messages when
    -- in development, and warnings and errors in production.
    shouldLogIO app _source level = do
      LogSettings{..} <- readTVarIO $ appLogSettings app
      return $ logAll || level >= logMinimumLevel

    makeLogger = readTVarIO . snd . appLogger


-- langForm :: Form (Lang, Route UniWorX)
-- langForm csrf = do
--   lang <- selectLanguage appLanguages
--   route <- getCurrentRoute
--   (urlRes, urlView) <- mreq hiddenField ("" & addName ("referer" :: Text)) route
--   (langBoxRes, langBoxView) <- mreq
--     (selectField appLanguagesOpts)
--     ("" & addAttr "multiple" "multiple" & addAttr "size" (tshow . min 10 $ length appLanguages) & addAutosubmit & addName ("lang" :: Text))
--     (Just lang)
--   return ((,) <$> langBoxRes <*> urlRes, toWidget csrf <> fvInput urlView <> fvInput langBoxView)

data MemcachedKeyFavourites
  = MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
  deriving (Eq, Read, Show, Generic, Typeable)
  deriving anyclass (Hashable, Binary)

data MemcachedLimitKeyFavourites
  = MemcachedLimitKeyFavourites
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (Hashable, Binary)


updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX)
                 => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
                 -> ReaderT SqlBackend m ()
updateFavourites cData = void . runMaybeT $ do
  $logDebugS "updateFavourites" "Updating favourites"

  now <- liftIO $ getCurrentTime
  uid <- MaybeT $ liftHandler maybeAuthId
  mcid  <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
  User{userMaxFavourites} <- MaybeT $ get uid

  -- update Favourites
  for_ mcid $ \cid ->
    void . lift $ upsertBy
      (UniqueCourseFavourite uid cid)
      (CourseFavourite uid cid FavouriteVisited now)
      [CourseFavouriteLastVisit =. now]
  -- prune Favourites to user-defined size
  oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
  let deleteFavs = oldFavs
        & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
        & drop userMaxFavourites
        & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
        & map entityKey
  unless (null deleteFavs) $
    lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]


siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html
siteLayoutMsg msg widget = do
  mr <- getMessageRender
  siteLayout (toWgt $ mr msg) widget

siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html
siteLayoutMsg' = siteLayout . i18nHeading

siteLayout :: Widget -- ^ `pageHeading`
           -> Widget -> Handler Html
siteLayout = siteLayout' . Just

siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading`
           -> Widget -> Handler Html
siteLayout' headingOverride widget = do
  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings

  isModal <- hasCustomHeader HeaderIsModal

  primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages

  mcurrentRoute <- getCurrentRoute
  let currentHandler = classifyHandler <$> mcurrentRoute

  currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest)

  -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
  let
    breadcrumbs' mcRoute = do
      mr <- getMessageRender
      case mcRoute of
        Nothing -> return (mr MsgErrorResponseTitleNotFound, [])
        Just cRoute -> do
          (title, next) <- breadcrumb cRoute
          crumbs <- go [] next
          return (title, crumbs)
      where
        go crumbs  Nothing      = return crumbs
        go crumbs (Just cRoute) = do
          hasAccess <- hasReadAccessTo cRoute
          (title, next) <- breadcrumb cRoute
          go ((cRoute, title, hasAccess) : crumbs) next
  (title, parents) <- breadcrumbs' mcurrentRoute

  --         let isParent :: Route UniWorX -> Bool
  --             isParent r = r == (fst parents)

  isAuth <- isJust <$> maybeAuthId

  -- Lookup Favourites & Theme if possible
  (favourites', maxFavouriteTerms, currentTheme) <- do
      muid <- maybeAuthPair

      favCourses <- runDB . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
        E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
         E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)

        let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId
            isCurrent
              | Just (CourseR tid ssh csh _) <- mcurrentRoute
              =       course E.^. CourseTerm E.==. E.val tid
                E.&&. course E.^. CourseSchool E.==. E.val ssh
                E.&&. course E.^. CourseShorthand E.==. E.val csh
              | otherwise
              = E.false
            notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite ->
              E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid)
                   E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId
            isParticipant = E.exists . E.from $ \participant ->
              E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
                   E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid)
                   E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
            isLecturer = E.exists . E.from $ \lecturer ->
              E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
                   E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid)
            isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do
              E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
               E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId
              E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid)
            isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
              E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
               E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
              E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
            isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor

            reason = E.case_
              [ E.when_ isCurrent    E.then_ . E.just $ E.val FavouriteCurrent
              , E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
              ] (E.else_ $ courseFavourite E.?. CourseFavouriteReason)
            
        E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent

        return (course, reason)

      return ( favCourses
             , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
             , maybe userDefaultTheme userTheme $ view _2 <$> muid
             )

  let favouriteTerms :: [TermIdentifier]
      favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _) -> Set.singleton $ unTermKey courseTerm) favourites'
  
  favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite)
      -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
             favouriteReason = fromMaybe FavouriteCurrent mFavourite
         in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
              ctx <- getAuthContext
              MsgRenderer mr <- getMsgRenderer
              langs <- selectLanguages appLanguages <$> languages
              let cK = MemcachedKeyFavouriteQuickActions cId ctx langs
              $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
              items <- memcachedLimitedKeyTimeoutBy
                MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
                (Right <$> appFavouritesQuickActionsCacheTTL) 
                appFavouritesQuickActionsTimeout
                cK
                cK
                . observeFavouritesQuickActionsDuration $ do
                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
                  items' <- pageQuickActions NavQuickViewFavourite courseRoute
                  items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n
                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
                  return items
              $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
              return (c, courseRoute, items, favouriteReason)

  nav'' <- mconcat <$> sequence
    [ defaultLinks
    , maybe (return []) pageActions mcurrentRoute
    ]
  nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav''
  nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren)

  mmsgs <- if
    | isModal -> return mempty
    | otherwise -> do
        applySystemMessages
        authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
        forM_ authTagPivots $
          \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
        getMessages

  -- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm
  -- let langFormView' = wrapForm langFormView def
  --       { formAction = Just $ SomeRoute LangR
  --       , formSubmit = FormAutoSubmit
  --       , formEncoding = langFormEnctype
  --       }

  let highlight :: HasRoute UniWorX url => url -> Bool
      -- ^ highlight last route in breadcrumbs, favorites taking priority
      highlight = (highR ==) . Just . urlRoute
        where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents
              navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav
              highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
      highlightNav = (||) <$> navForceActive <*> highlight
      favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason)]
      favouriteTermReason tid favReason' = favourites
        & filter (\(Course{..}, _, _, favReason) -> unTermKey courseTerm == tid && favReason == favReason')
        & sortOn (\(Course{..}, _, _, _) -> courseName)

      -- We break up the default layout into two components:
      -- default-layout is the contents of the body tag, and
      -- default-layout-wrapper is the entire page. Since the final
      -- value passed to hamletToRepHtml cannot be a widget, this allows
      -- you to use normal widget features in default-layout.

      navWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) -> Widget
      navWidget (n, navIdent, navRoute', navChildren') = case n of
        NavHeader{ navLink = navLink@NavLink{..}, .. }
          | NavTypeLink{..} <- navType
          , navModal
            -> customModal Modal
                 { modalTriggerId = Just navIdent
                 , modalId = Nothing
                 , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/navbar/item")
                 , modalContent = Left $ SomeRoute navLink
                 }
          | NavTypeLink{} <- navType
            -> let route = navRoute'
                   ident = navIdent
                in $(widgetFile "widgets/navbar/item")
        NavPageActionPrimary{ navLink = navLink@NavLink{..}, .. }
          -> let pWidget
                   | NavTypeLink{..} <- navType
                   , navModal
                     = customModal Modal
                         { modalTriggerId = Just navIdent
                         , modalId = Nothing
                         , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/pageaction/primary")
                         , modalContent = Left $ SomeRoute navLink
                         }
                   | NavTypeLink{} <- navType
                     = let route = navRoute'
                           ident = navIdent
                        in $(widgetFile "widgets/pageaction/primary")
                   | otherwise
                     = error "not implemented"
                 sWidgets = navChildren'
                   & map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, []))
              in $(widgetFile "widgets/pageaction/primary-wrapper")
        NavPageActionSecondary{ navLink = navLink@NavLink{..}, .. }
          | NavTypeLink{..} <- navType
          , navModal
            -> customModal Modal
                 { modalTriggerId = Just navIdent
                 , modalId = Nothing
                 , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/pageaction/secondary")
                 , modalContent = Left $ SomeRoute navLink
                 }
          | NavTypeLink{} <- navType
            -> let route = navRoute'
                   ident = navIdent
                in $(widgetFile "widgets/pageaction/secondary")
        NavHeaderContainer{..} -> $(widgetFile "widgets/navbar/container")
        NavFooter{ navLink = navLink@NavLink{..} }
          | NavTypeLink{..} <- navType
          , not navModal
            -> let route = navRoute'
                   ident = navIdent
                in $(widgetFile "widgets/footer/link")
        _other -> error "not implemented"

      navContainerItemWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)])
                             -> (NavLink, Text, Text)
                             -> Widget
      navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of
        NavHeaderContainer{}
          | NavTypeLink{..} <- navType
          , navModal
            -> customModal Modal
                 { modalTriggerId = Just iNavIdent
                 , modalId = Nothing
                 , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/navbar/navbar-container-item--link")
                 , modalContent = Left $ SomeRoute iN
                 }
          | NavTypeLink{} <- navType
            -> let route = iNavRoute
                   ident = iNavIdent
                in $(widgetFile "widgets/navbar/navbar-container-item--link")
          | NavTypeButton{..} <- navType -> do
              csrfToken <- reqToken <$> getRequest
              wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def
                { formMethod = navMethod
                , formSubmit = FormNoSubmit
                , formAction = Just $ SomeRoute iN
                }
        _other -> error "not implemented"

      navbar :: Widget
      navbar = do
        $(widgetFile "widgets/navbar/navbar")
        forM_ (filter isNavHeaderContainer nav) $ \(_, containerIdent, _, _) ->
          toWidget $(cassiusFile "templates/widgets/navbar/container-radio.cassius")
        where isNavHeaderPrimary   = has $ _1 . _navHeaderRole . only NavHeaderPrimary
              isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary
      asidenav :: Widget
      asidenav = $(widgetFile "widgets/asidenav/asidenav")
        where logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg")
      footer :: Widget
      footer = $(widgetFile "widgets/footer/footer")
        where isNavFooter = has $ _1 . _NavFooter
      alerts :: Widget
      alerts = $(widgetFile "widgets/alerts/alerts")
      contentHeadline :: Maybe Widget
      contentHeadline = headingOverride <|> (pageHeading =<< mcurrentRoute)
      breadcrumbsWgt :: Widget
      breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
      pageaction :: Widget
      pageaction = $(widgetFile "widgets/pageaction/pageaction")
      -- functions to determine if there are page-actions (primary or secondary)
      hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool
      hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
      hasSecondaryPageActions = has (folded . _1 . _NavPageActionSecondary) nav
      hasPrimaryPageActions   = has (folded . _1 . _NavPageActionPrimary  ) nav
      hasPrimarySubActions = has (folded . _1 . filtered (is _NavPageActionPrimary) . _navChildren . folded) nav
      contentRibbon :: Maybe Widget
      contentRibbon = fmap toWidget appRibbon

      isNavHeaderContainer = has $ _1 . _NavHeaderContainer
      isPageActionPrimary = has $ _1 . _NavPageActionPrimary
      isPageActionSecondary = has $ _1 . _NavPageActionSecondary

  MsgRenderer mr <- getMsgRenderer
  let
    -- See Utils.Frontend.I18n and files in messages/frontend for message definitions
    frontendI18n = toJSON (mr :: FrontendMessage -> Text)
  frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales

  pc <- widgetToPageContent $ do
      webpackLinks_main StaticR
      toWidget $(juliusFile "templates/i18n.julius")
      whenIsJust currentApproot' $ \currentApproot ->
        toWidget $(juliusFile "templates/approot.julius")
      whenIsJust mcurrentRoute $ \currentRoute' -> do
        currentRoute <- toTextUrl currentRoute'
        toWidget $(juliusFile "templates/current-route.julius")
      wellKnownHtmlLinks

      $(widgetFile "default-layout")
  withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")


getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX) => SystemMessageId -> m UserSystemMessageState
getSystemMessageState smId = liftHandler $ do
  muid <- maybeAuthId
  reqSt <- $cachedHere getSystemMessageStateRequest
  dbSt <- $cachedHere $ maybe (return mempty) getDBSystemMessageState muid
  let MergeHashMap smSt = reqSt <> dbSt
      smSt' = MergeHashMap $ HashMap.filter (/= mempty) smSt
  when (smSt' /= reqSt) $
        setRegisteredCookieJson CookieSystemMessageState
    =<< ifoldMapM (\smId' v -> MergeHashMap <$> (HashMap.singleton <$> encrypt smId' <*> pure v :: Handler (HashMap CryptoUUIDSystemMessage _))) smSt'

  return . fromMaybe mempty $ HashMap.lookup smId smSt
  where
    getSystemMessageStateRequest =
          (lookupRegisteredCookiesJson id CookieSystemMessageState :: Handler (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState))
      >>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (maybeT (return mempty) . catchMPlus (Proxy @CryptoIDError) $ HashMap.singleton <$> decrypt cID <*> pure v))
    getDBSystemMessageState uid = runDB . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt
      where foldSt (Entity _ SystemMessageHidden{..})
              = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime }

applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
  lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden
  
  cRoute <- lift getCurrentRoute
  guard $ cRoute /= Just NewsR

  lift . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
  where
    syncSystemMessageHidden uid = runDB $ do
      smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: DB (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
      iforM_ smSt $ \cID UserSystemMessageState{..} -> do
        smId <- decrypt cID
        whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $
          upsert SystemMessageHidden
            { systemMessageHiddenMessage = smId
            , systemMessageHiddenUser = uid
            , systemMessageHiddenTime
            }
            [ SystemMessageHiddenTime =. systemMessageHiddenTime ]
        
        when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do
          deleteBy $ UniqueSystemMessageHidden uid smId

        modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
          -> fmap MergeHashMap . assertM' (/= mempty) $
               HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm
    
    applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
      guard $ not systemMessageNewsOnly

      cID <- encrypt smId
      void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False

      now <- liftIO getCurrentTime
      guard $ NTop systemMessageFrom <= NTop (Just now)
      guard $ NTop (Just now) < NTop systemMessageTo

      UserSystemMessageState{..} <- lift $ getSystemMessageState smId
      guard $ userSystemMessageShown <= Just systemMessageLastChanged
      guard $ userSystemMessageHidden <= Just systemMessageLastUnhide

      (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
      let
        (summary, content) = case smTrans of
          Nothing -> (systemMessageSummary, systemMessageContent)
          Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
      case summary of
        Just s ->
          addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
        Nothing -> addMessage systemMessageSeverity content

      tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
        HashMap.singleton cID mempty{ userSystemMessageShown = Just now }

-- Define breadcrumbs.
i18nCrumb :: ( RenderMessage (HandlerSite m) msg, MonadHandler m )
          => msg
          -> Maybe (Route (HandlerSite m))
          -> m (Text, Maybe (Route (HandlerSite m)))
i18nCrumb msg mbR = do
  mr <- getMessageRender
  return (mr msg, mbR)

-- `breadcrumb` _really_ needs to be total for _all_ routes
--
-- Even if routes are POST only or don't usually use `siteLayout` they will if
-- an error occurs.
--
-- Keep in mind that Breadcrumbs are also shown by the 403-Handler,
-- i.e. information might be leaked by not performing permission checks if the
-- breadcrumb value depends on sensitive content (like an user's name).
instance YesodBreadcrumbs UniWorX where
  breadcrumb (AuthR _)        = i18nCrumb MsgMenuLogin         $ Just NewsR
  breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic    Nothing
  breadcrumb (WellKnownR _)   = i18nCrumb MsgBreadcrumbWellKnown Nothing
  breadcrumb MetricsR         = i18nCrumb MsgBreadcrumbMetrics   Nothing

  breadcrumb NewsR            = i18nCrumb MsgMenuNews      Nothing
  breadcrumb UsersR           = i18nCrumb MsgMenuUsers   $ Just AdminR
  breadcrumb AdminUserAddR    = i18nCrumb MsgMenuUserAdd $ Just UsersR
  breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do
    guardM . hasReadAccessTo $ AdminUserR cID
    uid <- decrypt cID
    User{..} <- MaybeT . runDB $ get uid
    return (userDisplayName, Just UsersR)
  breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
  breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID 
  breadcrumb (UserNotificationR cID) = do
    mayList <- hasReadAccessTo UsersR
    if
      | mayList
        -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID
      | otherwise
        -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR
  breadcrumb (UserPasswordR cID) = do
    mayList <- hasReadAccessTo UsersR
    if
      | mayList
        -> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID
      | otherwise
        -> i18nCrumb MsgMenuUserPassword $ Just ProfileR
  breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR
  breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing

  breadcrumb AdminR           = i18nCrumb MsgAdminHeading           Nothing
  breadcrumb AdminFeaturesR   = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR 
  breadcrumb AdminTestR       = i18nCrumb MsgMenuAdminTest        $ Just AdminR
  breadcrumb AdminErrMsgR     = i18nCrumb MsgMenuAdminErrMsg      $ Just AdminR
  breadcrumb AdminTokensR     = i18nCrumb MsgMenuAdminTokens      $ Just AdminR
  
  breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
  breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
    School{..} <- MaybeT . runDB $ get ssh
    return (CI.original schoolName, Just SchoolListR)
  breadcrumb SchoolNewR       = i18nCrumb MsgMenuSchoolNew        $ Just SchoolListR

  breadcrumb (ExamOfficeR EOExamsR)  = i18nCrumb MsgMenuExamOfficeExams    Nothing
  breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $ ExamOfficeR EOExamsR
  breadcrumb (ExamOfficeR EOUsersR)  = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR
  breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing

  breadcrumb InfoR            = i18nCrumb MsgMenuInformation     Nothing
  breadcrumb InfoLecturerR    = i18nCrumb MsgInfoLecturerTitle $ Just InfoR
  breadcrumb LegalR           = i18nCrumb MsgMenuLegal         $ Just InfoR
  breadcrumb InfoAllocationR  = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR
  breadcrumb VersionR         = i18nCrumb MsgMenuVersion       $ Just InfoR
  breadcrumb FaqR             = i18nCrumb MsgBreadcrumbFaq     $ Just InfoR


  breadcrumb HelpR            = i18nCrumb MsgMenuHelp            Nothing


  breadcrumb HealthR          = i18nCrumb MsgMenuHealth          Nothing
  breadcrumb InstanceR        = i18nCrumb MsgMenuInstance        Nothing

  breadcrumb ProfileR         = i18nCrumb MsgBreadcrumbProfile   Nothing
  breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail  $ Just ProfileR
  breadcrumb ProfileDataR     = i18nCrumb MsgMenuProfileData   $ Just ProfileR
  breadcrumb AuthPredsR       = i18nCrumb MsgMenuAuthPreds     $ Just ProfileR
  breadcrumb CsvOptionsR      = i18nCrumb MsgCsvOptions        $ Just ProfileR
  breadcrumb LangR            = i18nCrumb MsgMenuLanguage      $ Just ProfileR

  breadcrumb StorageKeyR      = i18nCrumb MsgBreadcrumbStorageKey Nothing

  breadcrumb TermShowR              = i18nCrumb MsgMenuTermShow    $ Just NewsR
  breadcrumb TermCurrentR           = i18nCrumb MsgMenuTermCurrent $ Just TermShowR
  breadcrumb TermEditR              = i18nCrumb MsgMenuTermCreate  $ Just TermShowR
  breadcrumb (TermEditExistR tid)   = i18nCrumb MsgMenuTermEdit    . Just $ TermCourseListR tid
  breadcrumb (TermCourseListR tid)  = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs
    guardM . lift . runDB $ isJust <$> get tid
    i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR

  breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs
    guardM . lift . runDB $
      (&&) <$> fmap isJust (get ssh)
           <*> fmap isJust (get tid)
    return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)

  breadcrumb AllocationListR        = i18nCrumb MsgAllocationListTitle $ Just NewsR
  breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of
    AShowR      -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
      mr <- getMessageRender
      Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash
      return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR)
    ARegisterR  -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
    AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
      cid <- decrypt cID
      Course{..} <- hoist runDB $ do
        aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash 
        guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ]
        MaybeT $ get cid
      return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR)
    AUsersR     -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR
    APriosR     -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR
    AComputeR   -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR
    AAcceptR    -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR

  breadcrumb ParticipantsListR      = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
  breadcrumb (ParticipantsR _ _)    = i18nCrumb MsgBreadcrumbParticipants     $ Just ParticipantsListR
  breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect  $ Just ParticipantsListR

  breadcrumb  CourseListR                 = i18nCrumb MsgMenuCourseList   Nothing
  breadcrumb  CourseNewR                  = i18nCrumb MsgMenuCourseNew  $ Just CourseListR
  breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do
    guardM . lift . runDB . existsBy $ TermSchoolCourseShort tid ssh csh
    return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
  breadcrumb (CourseR tid ssh csh CEditR)     = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CUsersR)    = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CAddUserR)  = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR
  breadcrumb (CourseR tid ssh csh CInviteR)   = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do
    guardM . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
    uid <- decrypt cID
    User{userDisplayName} <- MaybeT . runDB $ get uid
    return (userDisplayName, Just $ CourseR tid ssh csh CUsersR)
  breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgMenuSubmissions . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CAssignR)   = i18nCrumb MsgMenuCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR
  breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgMenuSheetList . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgMenuSheetNew . Just $ CourseR tid ssh csh SheetListR
  breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgMenuSheetCurrent . Just $ CourseR tid ssh csh SheetListR
  breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgMenuSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR
  breadcrumb (CourseR tid ssh csh CCommR    ) = i18nCrumb MsgMenuCourseCommunication . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgMenuTutorialList . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgMenuTutorialNew . Just $ CourseR tid ssh csh CTutorialListR
  breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CRegisterR)  = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgMenuCourseDelete . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR

  breadcrumb (CourseR tid ssh csh CNewsNewR)    = i18nCrumb MsgMenuCourseNewsNew . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of
    CNShowR   -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR
    CNEditR   -> i18nCrumb MsgMenuCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR
    CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR
    CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR
    CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR
  
  breadcrumb (CourseR tid ssh csh CEventsNewR)    = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of
    CEvEditR   -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR
    CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR

  breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgMenuExamList . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgMenuExamNew . Just $ CourseR tid ssh csh CExamListR

  breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplications . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR

  breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of
    CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do
      guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
      appId <- decrypt cID
      User{..} <- hoist runDB $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser
      return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR)
    CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR

  breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of
    EShowR    -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do
      guardM . hasReadAccessTo $ CExamR tid ssh csh examn EShowR
      return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
    EEditR    -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR
    EUsersR   -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR
    EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR
    EGradesR  -> i18nCrumb MsgMenuExamGrades . Just $ CExamR tid ssh csh examn EShowR
    ECInviteR  -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR
    EInviteR   -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR
    ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
    ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
    EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR
    ECorrectR  -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR

  breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
    TUsersR  -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
      guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
      return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
    TEditR   -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR
    TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR
    TCommR   -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR
    TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR
    TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR

  breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of
    SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do
      guardM . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
      return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
    SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR
    SDelR  -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR
    SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR
    SAssignR -> i18nCrumb MsgMenuCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR
    SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR
    SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR
    SubmissionR cid sRoute' -> case sRoute' of
      SubShowR -> do
        mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
        if
          | mayList
            -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR
          | otherwise
            -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR
      CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR
      SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR
      SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR
      SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR
      SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR
      SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR
    SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR
    SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR
    SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR
    SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR
    SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR
    SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR

  breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR
  breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR
  breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of
    MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do
      guardM . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
      return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
    MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR
    MDelR  -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR
    MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR
    MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR

  breadcrumb CorrectionsR         = i18nCrumb MsgMenuCorrections Nothing
  breadcrumb CorrectionsUploadR   = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR
  breadcrumb CorrectionsCreateR   = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR
  breadcrumb CorrectionsGradeR    = i18nCrumb MsgMenuCorrectionsGrade $ Just CorrectionsR
  breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR

  breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing
  
  breadcrumb (MessageR _) = do
    mayList <- (== Authorized) <$> evalAccess MessageListR False
    if
      | mayList   -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR
      | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR
  breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR
  breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID

  breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR

  breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing
  breadcrumb EExamNewR = do
    isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
    i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if
      | isEO -> ExamOfficeR EOExamsR
      | otherwise -> EExamListR
  breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of
    EEShowR -> do
      isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
      maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do
        guardM . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR
        i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if
          | isEO -> ExamOfficeR EOExamsR
          | otherwise -> EExamListR
    EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR
    EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR
    EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR 
    EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR 
  
  -- breadcrumb  _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all

submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
  E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
  E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId

  E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
       E.&&. sheet E.^. SheetName E.==. E.val shn
       E.&&. course E.^. CourseShorthand E.==. E.val csh
       E.&&. course E.^. CourseTerm E.==. E.val tid

  return $ submission E.^. SubmissionId



defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX) => m [Nav]
defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
  [ return NavHeader
      { navHeaderRole = NavHeaderSecondary
      , navIcon       = IconMenuLogout
      , navLink       = NavLink
        { navLabel       = MsgMenuLogout
        , navRoute       = AuthR LogoutR
        , navAccess'     = is _Just <$> maybeAuthId
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
  , return NavHeader
      { navHeaderRole = NavHeaderSecondary
      , navIcon       = IconMenuLogin
      , navLink       = NavLink
        { navLabel       = MsgMenuLogin
        , navRoute       = AuthR LoginR
        , navAccess'     = is _Nothing <$> maybeAuthId
        , navType        = NavTypeLink { navModal = True }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
  , return NavHeader
      { navHeaderRole = NavHeaderSecondary
      , navIcon       = IconMenuProfile
      , navLink       = NavLink
        { navLabel       = MsgMenuProfile
        , navRoute       = ProfileR
        , navAccess'     = is _Just <$> maybeAuthId
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
  , do
      mCurrentRoute <- getCurrentRoute

      activeLang <- selectLanguage appLanguages

      let navChildren = flip map (toList appLanguages) $ \lang -> NavLink
            { navLabel       = MsgLanguage lang
            , navRoute       = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
            , navAccess'     = return True
            , navType        = NavTypeButton
              { navMethod = POST
              , navData   = [(toPathPiece PostLanguage, lang)]
              }
            , navQuick'      = mempty
            , navForceActive = lang == activeLang
            }

      guard $ length navChildren > 1

      return NavHeaderContainer
        { navHeaderRole = NavHeaderSecondary
        , navLabel      = SomeMessage MsgMenuLanguage
        , navIcon       = IconLanguage
        , navChildren
        }
  , do
      mCurrentRoute <- getCurrentRoute
      
      return NavHeader
        { navHeaderRole = NavHeaderSecondary
        , navIcon       = IconMenuHelp
        , navLink       = NavLink
          { navLabel       = MsgMenuHelp
          , navRoute       = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
          , navAccess'     = return True
          , navType        = NavTypeLink { navModal = True }
          , navQuick'      = mempty
          , navForceActive = False
          }
        } 
  , return $ NavFooter NavLink
      { navLabel       = MsgMenuDataProt
      , navRoute       = LegalR :#: ("data-protection" :: Text)
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
  , return $ NavFooter NavLink
      { navLabel       = MsgMenuTermsUse
      , navRoute       = LegalR :#: ("terms-of-use" :: Text)
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
  , return $ NavFooter NavLink
      { navLabel       = MsgMenuCopyright
      , navRoute       = LegalR :#: ("copyright" :: Text)
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
  , return $ NavFooter NavLink
      { navLabel       = MsgMenuImprint
      , navRoute       = LegalR :#: ("imprint" :: Text)
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
  , return $ NavFooter NavLink
      { navLabel       = MsgMenuInformation
      , navRoute       = InfoR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
  , return $ NavFooter NavLink
      { navLabel       = MsgMenuFaq
      , navRoute       = FaqR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
  , return $ NavFooter NavLink
      { navLabel       = MsgMenuGlossary
      , navRoute       = GlossaryR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
  , return NavHeader
      { navHeaderRole = NavHeaderPrimary
      , navIcon       = IconMenuNews
      , navLink       = NavLink
        { navLabel       = MsgMenuNews
        , navRoute       = NewsR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
  , return NavHeader
      { navHeaderRole = NavHeaderPrimary
      , navIcon       = IconMenuCourseList
      , navLink       = NavLink
        { navLabel       = MsgMenuCourseList
        , navRoute       = CourseListR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
  , return NavHeader
      { navHeaderRole = NavHeaderPrimary
      , navIcon       = IconMenuCorrections
      , navLink       = NavLink
        { navLabel       = MsgMenuCorrections
        , navRoute       = CorrectionsR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
  , return NavHeader
      { navHeaderRole = NavHeaderPrimary
      , navIcon       = IconMenuExams
      , navLink       = NavLink
        { navLabel       = MsgMenuExamOfficeExams
        , navRoute       = ExamOfficeR EOExamsR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
  , return NavHeaderContainer
      { navHeaderRole = NavHeaderPrimary
      , navLabel      = SomeMessage MsgAdminHeading
      , navIcon       = IconMenuAdmin
      , navChildren   = 
          [ NavLink
              { navLabel       = MsgMenuUsers
              , navRoute       = UsersR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgMenuSchoolList
              , navRoute       = SchoolListR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgAdminFeaturesHeading
              , navRoute       = AdminFeaturesR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgMenuMessageList
              , navRoute       = MessageListR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgMenuAdminErrMsg
              , navRoute       = AdminErrMsgR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgMenuAdminTokens
              , navRoute       = AdminTokensR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgMenuAdminTest
              , navRoute       = AdminTestR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          ]
      }
  , return NavHeaderContainer
      { navHeaderRole = NavHeaderPrimary
      , navLabel      = SomeMessage (mempty :: Text)
      , navIcon       = IconMenuExtra
      , navChildren   = 
          [ NavLink
              { navLabel       = MsgMenuCourseNew
              , navRoute       = CourseNewR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgMenuExternalExamList
              , navRoute       = EExamListR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgMenuTermShow
              , navRoute       = TermShowR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgMenuAllocationList
              , navRoute       = AllocationListR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          , NavLink
              { navLabel       = MsgInfoLecturerTitle
              , navRoute       = InfoLecturerR
              , navAccess'     = return True
              , navType        = NavTypeLink { navModal = False }
              , navQuick'      = mempty
              , navForceActive = False
              }
          ]
      }
  ]


pageActions :: ( MonadHandler m
               , HandlerSite m ~ UniWorX
               , MonadCatch m
               )
            => Route UniWorX -> m [Nav]
pageActions NewsR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuOpenCourses
      , navRoute       = (CourseListR, [("courses-openregistration", toPathPiece True)])
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuOpenAllocations
      , navRoute       = (AllocationListR, [("allocations-active", toPathPiece True)])
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CourseR tid ssh csh CShowR) = do
  materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR
  tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR
  sheetListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh SheetListR
  examListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CExamListR
  membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR

  let examListBound :: Num a => a
      examListBound = 4 -- guaranteed random; chosen by fair dice roll
  examListExams <- liftHandler . runDB $ do
    examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do
      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.limit $ succ examListBound
      return $ exam E.^. ExamName
    return $ do
      E.Value examn <- examNames
      return NavLink
        { navLabel       = examn
        , navRoute       = CExamR tid ssh csh examn EShowR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewFavourite
        , navForceActive = False
        }
  let showExamList = length examListExams <= examListBound

  let
    navMembers = NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuCourseMembers
        , navRoute       = CourseR tid ssh csh CUsersR
        , navAccess' =
            let courseWhere course = 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
                hasParticipants = E.selectExists . 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
                  void $ courseWhere course
                mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
             in runDB $ mayRegister `or2M` hasParticipants
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewFavourite
        , navForceActive = False
        }
      , navChildren = membersSecondary
      }
  showMembers <- maybeT (return False) $ True <$ navAccess navMembers

  return $
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuMaterialList
        , navRoute       = CourseR tid ssh csh MaterialListR
        , navAccess' =
            let lecturerAccess     = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR  -- Always show for lecturers to create new material
                materialAccess mnm = hasReadAccessTo  $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents
                existsVisible  = do
                    matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do
                      E.on     $ course   E.^. CourseId   E.==.   material E.^. MaterialCourse
                      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 $ material E.^. MaterialName
                    anyM matNames (materialAccess . E.unValue)
             in runDB $ lecturerAccess `or2M` existsVisible
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewFavourite
        , navForceActive = False
        }
      , navChildren = materialListSecondary
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuSheetList
        , navRoute       = CourseR tid ssh csh SheetListR
        , navAccess' =
            let lecturerAccess  = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR  -- Always show for lecturers to create new sheets
                sheetAccess shn = hasReadAccessTo  $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents
                existsVisible  = do
                    sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
                      E.on     $ course   E.^. CourseId   E.==.   sheet E.^. SheetCourse
                      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 $ sheet E.^. SheetName
                    anyM sheetNames $ sheetAccess . E.unValue
             in runDB $ lecturerAccess `or2M` existsVisible
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewFavourite
        , navForceActive = False
        }
      , navChildren = sheetListSecondary
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuTutorialList
        , navRoute       = CourseR tid ssh csh CTutorialListR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewFavourite
        , navForceActive = False
        }
      , navChildren = tutorialListSecondary
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExamList
        , navRoute       = CourseR tid ssh csh CExamListR
        , navAccess' =
            let lecturerAccess   = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
                examAccess examn = hasReadAccessTo  $ CExamR tid ssh csh examn EShowR
                existsVisible = do
                  examNames <- E.select . 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
                    return $ exam E.^. ExamName
                  anyM examNames $ examAccess . E.unValue
             in runDB $ lecturerAccess `or2M` existsVisible
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = bool (navQuick NavQuickViewFavourite) mempty showExamList
        , navForceActive = False
        }
      , navChildren = examListSecondary ++ guardOnM showExamList examListExams
      }
    , navMembers
    ] ++ guardOnM (not showMembers) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- membersSecondary ] ++
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuCourseCommunication
        , navRoute       = CourseR tid ssh csh CCommR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewFavourite
        , navForceActive = False
        }
      , navChildren = []
      }
    , NavPageActionSecondary
      { navLink = NavLink
        { navLabel       = MsgMenuCourseExamOffice
        , navRoute       = CourseR tid ssh csh CExamOfficeR
        , navAccess' = do
            uid <- requireAuthId
            runDB $ do
              cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh 
              E.selectExists $ do
                (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid)
                E.where_ $ E.not_ isForced
        , navType        = NavTypeLink { navModal = True }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
    , NavPageActionSecondary
      { navLink = NavLink
        { navLabel       = MsgMenuCourseEdit
        , navRoute       = CourseR tid ssh csh CEditR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
    , NavPageActionSecondary
      { navLink = NavLink
        { navLabel       = MsgMenuCourseClone
        , navRoute       = ( CourseNewR
                           , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]
                           )
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
    , NavPageActionSecondary
      { navLink = NavLink
        { navLabel       = MsgMenuCourseDelete
        , navRoute       = CourseR tid ssh csh CDeleteR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
    ]
pageActions (ExamOfficeR EOExamsR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamOfficeFields
      , navRoute       = ExamOfficeR EOFieldsR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamOfficeUsers
      , navRoute       = ExamOfficeR EOUsersR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions SchoolListR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuSchoolNew
      , navRoute       = SchoolNewR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions UsersR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuLecturerInvite
      , navRoute       = AdminNewFunctionaryInviteR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuUserAdd
      , navRoute       = AdminUserAddR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (AdminUserR cID) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuUserNotifications
      , navRoute       = UserNotificationR cID
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuUserPassword
      , navRoute       = UserPasswordR cID
      , navAccess' = do
          uid <- decrypt cID
          User{userAuthentication} <- runDB $ get404 uid
          return $ is _AuthPWHash userAuthentication
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions InfoR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgInfoLecturerTitle
      , navRoute       = InfoLecturerR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuLegal
      , navRoute       = LegalR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuFaq
      , navRoute       = FaqR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuGlossary
      , navRoute       = GlossaryR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions VersionR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgInfoLecturerTitle
      , navRoute       = InfoLecturerR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuLegal
      , navRoute       = LegalR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuFaq
      , navRoute       = FaqR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuGlossary
      , navRoute       = GlossaryR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions HealthR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuInstance
      , navRoute       = InstanceR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions InstanceR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuHealth
      , navRoute       = HealthR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions HelpR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuFaq
      , navRoute       = FaqR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgInfoLecturerTitle
      , navRoute       = InfoLecturerR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = do
        (section, navLabel) <-
          [ ("courses", MsgInfoLecturerCourses)
          , ("exercises", MsgInfoLecturerExercises)
          , ("tutorials", MsgInfoLecturerTutorials)
          , ("exams", MsgInfoLecturerExams)
          , ("allocations", MsgInfoLecturerAllocations)
          ] :: [(Text, UniWorXMessage)]
        return NavLink
          { navLabel 
          , navRoute       = InfoLecturerR :#: section
          , navAccess'     = return True
          , navType        = NavTypeLink { navModal = False }
          , navQuick'      = mempty
          , navForceActive = False
          }
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuGlossary
      , navRoute       = GlossaryR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions ProfileR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuProfileData
      , navRoute       = ProfileDataR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuAuthPreds
      , navRoute       = AuthPredsR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgCsvOptions
      , navRoute       = CsvOptionsR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions TermShowR = do
  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
  return
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuTermCreate
        , navRoute       = TermEditR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuParticipantsList
        , navRoute       = ParticipantsListR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = participantsSecondary
      }
    ]
pageActions (AllocationR tid ssh ash AShowR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuAllocationInfo
      , navRoute       = InfoAllocationR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuAllocationUsers
      , navRoute       = AllocationR tid ssh ash AUsersR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuAllocationCompute
      , navRoute       = AllocationR tid ssh ash AComputeR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]  
pageActions (AllocationR tid ssh ash AUsersR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuAllocationPriorities
      , navRoute       = AllocationR tid ssh ash APriosR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuAllocationCompute
      , navRoute       = AllocationR tid ssh ash AComputeR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]  
pageActions CourseListR = do
  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
  return
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuCourseNew
        , navRoute       = CourseNewR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuAllocationList
        , navRoute       = AllocationListR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuParticipantsList
        , navRoute       = ParticipantsListR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = participantsSecondary
      }
    ] 
pageActions CourseNewR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgInfoLecturerTitle
      , navRoute       = InfoLecturerR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CourseR tid ssh csh CCorrectionsR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCorrectionsAssign
      , navRoute       = CourseR tid ssh csh CAssignR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCorrectionsOwn
      , navRoute       = ( CorrectionsR
                         , [ ("corrections-term", toPathPiece tid)
                           , ("corrections-school", toPathPiece ssh)
                           , ("corrections-course", toPathPiece csh)
                           ]
                         )
      , navAccess' = do
          muid <- maybeAuthId
          case muid of
            Nothing -> return False
            (Just uid) -> do
              ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
                E.on $ submission E.^. SubmissionSheet E.==. sheet  E.^. SheetId
                E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
                E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (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
              return ok
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CourseR tid ssh csh SheetListR) = do
  correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CCorrectionsR

  let
    navCorrections = NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuSubmissions
        , navRoute       = CourseR tid ssh csh CCorrectionsR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
        , navForceActive = False
        }
      , navChildren = correctionsSecondary
      }
  showCorrections <- maybeT (return False) $ True <$ navAccess navCorrections
  
  return $
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuSheetCurrent
        , navRoute       = CourseR tid ssh csh SheetCurrentR
        , navAccess' =
            runDB . maybeT (return False) $ do
              void . MaybeT $ sheetCurrent tid ssh csh
              return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
        , navForceActive = False
        }
      , navChildren = []
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuSheetOldUnassigned
        , navRoute       = CourseR tid ssh csh SheetOldUnassignedR
        , navAccess' =
            runDB . maybeT (return False) $ do
              void . MaybeT $ sheetOldUnassigned tid ssh csh
              return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
        , navForceActive = False
        }
      , navChildren = []
      }
    , navCorrections
    ] ++ guardOnM (not showCorrections) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- correctionsSecondary ] ++
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuSheetNew
        , navRoute       = CourseR tid ssh csh SheetNewR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
        , navForceActive = False
        }
      , navChildren = []
      }
    ]
pageActions (CourseR tid ssh csh CUsersR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCourseAddMembers
      , navRoute       = CourseR tid ssh csh CAddUserR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCourseApplications
      , navRoute       = CourseR tid ssh csh CApplicationsR
      , navAccess' =
          let courseWhere course = 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
              existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
                E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
                void $ courseWhere course
              courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do
                void $ courseWhere course
                return $ course E.^. CourseApplicationsRequired
              courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
                E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
                void $ courseWhere course
           in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CourseR tid ssh csh MaterialListR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuMaterialNew
      , navRoute       = CourseR tid ssh csh MaterialNewR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CMaterialR tid ssh csh mnm MShowR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuMaterialEdit
      , navRoute       = CMaterialR tid ssh csh mnm MEditR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionSecondary
    { navLink = NavLink
      { navLabel       = MsgMenuMaterialDelete
      , navRoute       = CMaterialR tid ssh csh mnm MDelR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    }
  ]
pageActions (CourseR tid ssh csh CTutorialListR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuTutorialNew
      , navRoute       = CourseR tid ssh csh CTutorialNewR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CTutorialR tid ssh csh tutn TEditR) = return
  [ NavPageActionSecondary
    { navLink = NavLink
      { navLabel       = MsgMenuTutorialDelete
      , navRoute       = CTutorialR tid ssh csh tutn TDeleteR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    }
  ]
pageActions (CTutorialR tid ssh csh tutn TUsersR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuTutorialComm
      , navRoute       = CTutorialR tid ssh csh tutn TCommR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuTutorialEdit
      , navRoute       = CTutorialR tid ssh csh tutn TEditR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionSecondary
    { navLink = NavLink
      { navLabel       = MsgMenuTutorialDelete
      , navRoute       = CTutorialR tid ssh csh tutn TDeleteR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    }
  ]
pageActions (CourseR tid ssh csh CExamListR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamNew
      , navRoute       = CourseR tid ssh csh CExamNewR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CExamR tid ssh csh examn EShowR) = do
  usersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CExamR tid ssh csh examn EUsersR

  return
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExamEdit
        , navRoute       = CExamR tid ssh csh examn EEditR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExamUsers
        , navRoute       = CExamR tid ssh csh examn EUsersR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = usersSecondary
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExamGrades
        , navRoute       = CExamR tid ssh csh examn EGradesR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
    , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExamCorrect
        , navRoute       = CExamR tid ssh csh examn ECorrectR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
    ]
pageActions (CExamR tid ssh csh examn ECorrectR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamUsers
      , navRoute       = CExamR tid ssh csh examn EUsersR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamGrades
      , navRoute       = CExamR tid ssh csh examn EGradesR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionSecondary
    { navLink = NavLink
      { navLabel       = MsgMenuExamEdit
      , navRoute       = CExamR tid ssh csh examn EEditR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    }
  ]
pageActions (CExamR tid ssh csh examn EUsersR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamAddMembers
      , navRoute       = CExamR tid ssh csh examn EAddUserR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamGrades
      , navRoute       = CExamR tid ssh csh examn EGradesR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamCorrect
      , navRoute       = CExamR tid ssh csh examn ECorrectR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CExamR tid ssh csh examn EGradesR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamUsers
      , navRoute       = CExamR tid ssh csh examn EUsersR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuExamCorrect
      , navRoute       = CExamR tid ssh csh examn ECorrectR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CSheetR tid ssh csh shn SShowR) = do
  subsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CSheetR tid ssh csh shn SSubsR
  let
    navSubmissions = NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuSubmissions
        , navRoute       = CSheetR tid ssh csh shn SSubsR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = subsSecondary
      }
  showSubmissions <- maybeT (return False) $ True <$ navAccess navSubmissions
  
  return $
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuSubmissionOwn
        , navRoute       = CSheetR tid ssh csh shn SubmissionOwnR
        , navAccess' =
            runDB . maybeT (return False) $ do
              uid <- MaybeT $ liftHandler maybeAuthId
              submissions <- lift $ submissionList tid csh shn uid
              guard . not $ null submissions
              return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
    , navSubmissions
    ] ++ guardOnM (not showSubmissions) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- subsSecondary ] ++
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuSheetEdit
        , navRoute       = CSheetR tid ssh csh shn SEditR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
    , NavPageActionSecondary
      { navLink = NavLink
        { navLabel       = MsgMenuSheetClone
        , navRoute       = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
    , NavPageActionSecondary
      { navLink = NavLink
        { navLabel       = MsgMenuSheetDelete
        , navRoute       = CSheetR tid ssh csh shn SDelR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      }
    ]
pageActions (CSheetR tid ssh csh shn SSubsR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuSubmissionNew
      , navRoute       = CSheetR tid ssh csh shn SubmissionNewR
      , navAccess' =
          let submissionAccess = hasWriteAccessTo $ CSheetR tid ssh csh shn SSubsR
              hasNoSubmission = maybeT (return False) $ do
                uid <- MaybeT $ liftHandler maybeAuthId
                submissions <- lift $ submissionList tid csh shn uid
                guard $ null submissions
                return True
           in runDB $ hasNoSubmission `or2M` submissionAccess
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCorrectionsOwn
      , navRoute       = ( CorrectionsR
                         , [ ("corrections-term", toPathPiece tid)
                           , ("corrections-school", toPathPiece ssh)
                           , ("corrections-course", toPathPiece csh)
                           , ("corrections-sheet", toPathPiece shn)
                           ]
                         )
      , navAccess'     = (== Authorized) <$> evalAccessCorrector tid ssh csh
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCorrectionsAssign
      , navRoute       = CSheetR tid ssh csh shn SAssignR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCorrection
      , navRoute       = CSubmissionR tid ssh csh shn cid CorrectionR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgCorrectorAssignTitle
      , navRoute       = CSubmissionR tid ssh csh shn cid SubAssignR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionSecondary
    { navLink = NavLink
      { navLabel       = MsgMenuSubmissionDelete
      , navRoute       = CSubmissionR tid ssh csh shn cid SubDelR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    }
  ]
pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgCorrectorAssignTitle
      , navRoute       = CSubmissionR tid ssh csh shn cid SubAssignR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionSecondary
    { navLink = NavLink
      { navLabel       = MsgMenuSubmissionDelete
      , navRoute       = CSubmissionR tid ssh csh shn cid SubDelR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    }
  ]
pageActions (CourseR tid ssh csh CApplicationsR) = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCourseApplicationsFiles
      , navRoute       = CourseR tid ssh csh CAppsFilesR
      , navAccess' =
          let appAccess (E.Value appId) = do
                cID <- encrypt appId
                hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
              appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do
                E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
                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.where_ . E.exists . E.from $ \courseApplicationFile ->
                  E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId
                return $ courseApplication E.^. CourseApplicationId
           in runDB . runConduit $ appSource .| anyMC appAccess
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCourseMembers
      , navRoute       = CourseR tid ssh csh CUsersR
      , navAccess' =
          runDB $ do
            cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
            exists [ CourseParticipantCourse ==. cid ]
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions CorrectionsR = return
  [ NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCorrectionsDownload
      , navRoute       = CorrectionsDownloadR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCorrectionsUpload
      , navRoute       = CorrectionsUploadR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = True }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCorrectionsCreate
      , navRoute       = CorrectionsCreateR
      , navAccess'     = runDB . maybeT (return False) $ do
          uid <- MaybeT $ liftHandler maybeAuthId
          sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
            let
              isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
                    $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
                E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
              isLecturer = E.exists . E.from $ \lecturer -> E.where_
                    $ lecturer E.^. LecturerUser E.==. E.val uid
                E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
            E.where_ $ isCorrector' E.||. isLecturer
            return $ sheet E.^. SheetSubmissionMode
          return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuCorrectionsGrade
      , navRoute       = CorrectionsGradeR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False }
      , navQuick'      = mempty
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions CorrectionsGradeR = do
  correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary CorrectionsR
  return
    [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuCorrections
        , navRoute       = CorrectionsR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = correctionsSecondary
      }
    ]
pageActions EExamListR = return
  [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExternalExamNew
        , navRoute       = EExamNewR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
  ]
pageActions (EExamR tid ssh coursen examn EEShowR) = return
  [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExternalExamEdit
        , navRoute       = EExamR tid ssh coursen examn EEEditR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
  , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExternalExamUsers
        , navRoute       = EExamR tid ssh coursen examn EEUsersR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
  , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExternalExamGrades
        , navRoute       = EExamR tid ssh coursen examn EEGradesR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
  ]
pageActions (EExamR tid ssh coursen examn EEGradesR) = return
  [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExternalExamUsers
        , navRoute       = EExamR tid ssh coursen examn EEUsersR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
  , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExternalExamEdit
        , navRoute       = EExamR tid ssh coursen examn EEEditR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
  ]
pageActions (EExamR tid ssh coursen examn EEUsersR) = return
  [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExternalExamGrades
        , navRoute       = EExamR tid ssh coursen examn EEGradesR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
  , NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgMenuExternalExamEdit
        , navRoute       = EExamR tid ssh coursen examn EEEditR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = False }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }
  ]
pageActions ParticipantsListR = return
  [ NavPageActionPrimary
      { navLink = NavLink
        { navLabel       = MsgCsvOptions
        , navRoute       = CsvOptionsR
        , navAccess'     = return True
        , navType        = NavTypeLink { navModal = True }
        , navQuick'      = mempty
        , navForceActive = False
        }
      , navChildren = []
      }

  , NavPageActionPrimary
    { navLink = NavLink
      { navLabel       = MsgMenuParticipantsIntersect
      , navRoute       = ParticipantsIntersectR
      , navAccess'     = return True
      , navType        = NavTypeLink { navModal = False}
      , navQuick'      = navQuick NavQuickViewPageActionSecondary
      , navForceActive = False
      }
    , navChildren = []
    }
  ]
pageActions _ = return []

pageQuickActions :: ( MonadCatch m
                    , MonadHandler m
                    , HandlerSite m ~ UniWorX
                    )
                 => NavQuickView -> Route UniWorX -> m [NavLink]
pageQuickActions qView route = do
  items'' <- pageActions route
  items' <- catMaybes <$> mapM (runMaybeT . navAccess) items''
  filterM navLinkAccess $ items' ^.. typesUsing @NavChildren @NavLink . filtered (getAny . ($ qView) . navQuick')


i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m ()
i18nHeading msg = liftWidget $ toWidget =<< getMessageRender <*> pure msg

-- | only used in defaultLayout; better use siteLayout instead!
pageHeading :: Route UniWorX -> Maybe Widget
pageHeading (AuthR _)
  = Just $ i18nHeading MsgLoginHeading
pageHeading NewsR
  = Just $ i18nHeading MsgNewsHeading
pageHeading UsersR
  = Just $ i18nHeading MsgUsers
pageHeading (AdminUserR _)
  = Just $ i18nHeading MsgAdminUserHeading
pageHeading (AdminTestR)
  = Just $ [whamlet|Internal Code Demonstration Page|]
pageHeading (AdminErrMsgR)
  = Just $ i18nHeading MsgErrMsgHeading

pageHeading (InfoR)
  = Just $ i18nHeading MsgInfoHeading
pageHeading (LegalR)
  = Just $ i18nHeading MsgLegalHeading
pageHeading (VersionR)
  = Just $ i18nHeading MsgVersionHeading

pageHeading (HelpR)
  = Just $ i18nHeading MsgHelpRequest

pageHeading ProfileR
  = Just $ i18nHeading MsgProfileHeading
pageHeading ProfileDataR
  = Just $ i18nHeading MsgProfileDataHeading

pageHeading TermShowR
  = Just $ i18nHeading MsgTermsHeading
pageHeading TermCurrentR
  = Just $ i18nHeading MsgTermCurrent
pageHeading TermEditR
  = Just $ i18nHeading MsgTermEditHeading
pageHeading (TermEditExistR tid)
  = Just $ i18nHeading $ MsgTermEditTid tid
pageHeading (TermCourseListR tid)
  = Just . i18nHeading . MsgTermCourseListHeading $ tid
pageHeading (TermSchoolCourseListR tid ssh)
  = Just $ do
      School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
      i18nHeading $ MsgTermSchoolCourseListHeading tid school

pageHeading (CourseListR)
  = Just $ i18nHeading $ MsgCourseListTitle
pageHeading CourseNewR
  = Just $ i18nHeading MsgCourseNewHeading
pageHeading (CourseR tid ssh csh CShowR)
  = Just $ do
    Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
    toWidget courseName
--          (CourseR tid csh CRegisterR) -- just for POST
pageHeading (CourseR tid ssh csh CEditR)
  = Just $ i18nHeading $ MsgCourseEditHeading tid ssh csh
pageHeading (CourseR tid ssh csh CCorrectionsR)
  = Just $ i18nHeading $ MsgSubmissionsCourse tid ssh csh
pageHeading (CourseR tid ssh csh SheetListR)
  = Just $ i18nHeading $ MsgSheetList tid ssh csh
pageHeading (CourseR tid ssh csh SheetNewR)
  = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh
pageHeading (CSheetR tid ssh csh shn SShowR)
  = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn
  -- = Just $ i18nHeading $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
pageHeading (CSheetR tid ssh csh shn SEditR)
  = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn
pageHeading (CSheetR tid ssh csh shn SDelR)
  = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn
pageHeading (CSheetR _tid _ssh _csh shn SSubsR)
  = Just $ i18nHeading $ MsgSubmissionsSheet shn
pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
  = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
  = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
  = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
--          (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
  = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid
--          (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
--          (CSheetR tid ssh csh shn SFileR) -- just for Downloads

pageHeading CorrectionsR
  = Just $ i18nHeading MsgCorrectionsTitle
pageHeading CorrectionsUploadR
  = Just $ i18nHeading MsgCorrUpload
pageHeading CorrectionsCreateR
  = Just $ i18nHeading MsgCorrCreate
pageHeading CorrectionsGradeR
  = Just $ i18nHeading MsgCorrGrade
pageHeading (MessageR _)
  = Just $ i18nHeading MsgSystemMessageHeading
pageHeading MessageListR
  = Just $ i18nHeading MsgSystemMessageListHeading

-- TODO: add headings for more single course- and single term-pages
pageHeading _
  = Nothing


routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)]
routeNormalizers =
  [ normalizeRender
  , ncSchool
  , ncAllocation
  , ncCourse
  , ncSheet
  , ncMaterial
  , ncTutorial
  , ncExam
  , ncExternalExam
  , verifySubmission
  , verifyCourseApplication
  , verifyCourseNews
  ]
  where
    normalizeRender :: Route UniWorX -> WriterT Any DB (Route UniWorX)
    normalizeRender route = route <$ do
      YesodRequest{..} <- liftHandler getRequest
      let original = (W.pathInfo reqWaiRequest, reqGetParams)
          rendered = renderRoute route
      if
        | (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic
            $logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|]
        | otherwise -> do
            $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
            tell $ Any True

    maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any DB) (Route UniWorX))
              -> Route UniWorX -> WriterT Any DB (Route UniWorX)
    maybeOrig f route = maybeT (return route) $ f route

    caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any DB) ()
    caseChanged a b
      | ((/=) `on` CI.original) a b = do
          $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
          tell $ Any True
      | otherwise                   = return ()

    ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
      let schoolShort :: SchoolShorthand
          schoolShort = unSchoolKey ssh
      Entity ssh' _  <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
      (caseChanged `on` unSchoolKey) ssh ssh'
      return ssh'
    ncAllocation = maybeOrig $ \route -> do
      AllocationR tid ssh ash _ <- return route
      Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
      caseChanged ash allocationShorthand
      return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
    ncCourse = maybeOrig $ \route -> do
      CourseR tid ssh csh _ <- return route
      Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
      caseChanged csh courseShorthand
      return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
    ncSheet = maybeOrig $ \route -> do
      CSheetR tid ssh csh shn _ <- return route
      Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
      Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
      caseChanged shn sheetName
      return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
    ncMaterial = maybeOrig $ \route -> do
      CMaterialR tid ssh csh mnm _ <- return route
      Entity cid Course{..} <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
      Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
      caseChanged mnm materialName
      return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
    ncTutorial = maybeOrig $ \route -> do
      CTutorialR tid ssh csh tutn _ <- return route
      Entity cid Course{..} <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
      Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
      caseChanged tutn tutorialName
      return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
    ncExam = maybeOrig $ \route -> do
      CExamR tid ssh csh examn _ <- return route
      Entity cid Course{..} <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
      Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
      caseChanged examn examName
      return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
    ncExternalExam = maybeOrig $ \route -> do
      EExamR tid ssh coursen examn _ <- return route
      Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn
      caseChanged coursen externalExamCourseName
      caseChanged examn externalExamExamName
      return $ route
        & typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
        & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
    verifySubmission = maybeOrig $ \route -> do
      CSubmissionR _tid _ssh _csh _shn cID sr <- return route
      sId <- $cachedHereBinary cID $ decrypt cID
      Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
      Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
      Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
      let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
      tell . Any $ route /= newRoute
      return newRoute
    verifyCourseApplication = maybeOrig $ \route -> do
      CApplicationR _tid _ssh _csh cID sr <- return route
      aId <- decrypt cID
      CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
      let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
      tell . Any $ route /= newRoute
      return newRoute
    verifyCourseNews = maybeOrig $ \route -> do
      CNewsR _tid _ssh _csh cID sr <- return route
      aId <- decrypt cID
      CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
      let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
      tell . Any $ route /= newRoute
      return newRoute


runDBRead :: ReaderT SqlReadBackend Handler a -> Handler a
runDBRead action = do
  $logDebugS "YesodPersist" "runDBRead"
  runSqlPool (withReaderT SqlReadBackend action) =<< appConnPool <$> getYesod

-- How to run database actions.
instance YesodPersist UniWorX where
    type YesodPersistBackend UniWorX = SqlBackend
    runDB action = do
      -- stack <- liftIO currentCallStack
      -- $logDebugS "YesodPersist" . unlines $ "runDB" : map pack stack
      $logDebugS "YesodPersist" "runDB"
      dryRun <- isDryRun
      let action'
            | dryRun = action <* transactionUndo
            | otherwise = action
      runSqlPool action' =<< appConnPool <$> getYesod
instance YesodPersistRunner UniWorX where
    getDBRunner = do
      (DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool
      return . (, cleanup) $ DBRunner (\action -> do
                                          dryRun <- isDryRun
                                          let action'
                                                | dryRun = action <* transactionUndo
                                                | otherwise = action
                                          $logDebugS "YesodPersist" "runDBRunner"
                                          runDBRunner action'
                                      )

data CampusUserConversionException
  = CampusUserInvalidIdent
  | CampusUserInvalidEmail
  | CampusUserInvalidDisplayName
  | CampusUserInvalidGivenName
  | CampusUserInvalidSurname
  | CampusUserInvalidTitle
  | CampusUserInvalidMatriculation
  | CampusUserInvalidSex
  | CampusUserInvalidFeaturesOfStudy Text
  | CampusUserInvalidAssociatedSchools Text
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (Exception)

_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
_upsertCampusUserMode mMode cs@Creds{..}
  | credsPlugin == "dummy"    = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent)
  | credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent)
  | otherwise                 = setMode <$> mMode  UpsertCampusUser
  where
    setMode UpsertCampusUser
      = cs{ credsPlugin = "LDAP" }
    setMode (UpsertCampusUserDummy ident)
      = cs{ credsPlugin = "dummy", credsIdent = CI.original ident }
    setMode (UpsertCampusUserOther ident)
      = cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident }

    others = "PWHash" :| []

upsertCampusUser :: UpsertCampusUserMode -> Ldap.AttrList [] -> DB (Entity User)
upsertCampusUser plugin ldapData = do
  now <- liftIO getCurrentTime
  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults

  let
    userIdent''         = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
    userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
    userEmail'          = fold $ do
      k' <- toList ldapUserEmail
      (k, v) <- ldapData
      guard $ k' == k
      return v
    userDisplayName''   = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
    userTitle'          = fold [ v | (k, v) <- ldapData, k == ldapUserTitle         ]
    userSex'            = fold [ v | (k, v) <- ldapData, k == ldapSex               ]

    userAuthentication
      | is _UpsertCampusUserOther plugin
      = error "PWHash should only work for users that are already known"
      | otherwise = AuthLDAP
    userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin)

  userIdent <- if
    | [bs] <- userIdent''
    , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
    , hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin
      -> return userIdent'
    | Just userIdent' <- plugin ^? _upsertCampusUserIdent
      -> return userIdent'
    | otherwise
      -> throwM CampusUserInvalidIdent
  userEmail <- if
    | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
      -> return $ CI.mk userEmail
    | otherwise
      -> throwM CampusUserInvalidEmail
  userDisplayName' <- if
    | [bs] <- userDisplayName''
    , Right userDisplayName' <- Text.decodeUtf8' bs
      -> return userDisplayName'
    | otherwise
      -> throwM CampusUserInvalidDisplayName
  userFirstName <- if
    | [bs] <- userFirstName'
    , Right userFirstName <- Text.decodeUtf8' bs
      -> return userFirstName
    | otherwise
      -> throwM CampusUserInvalidGivenName
  userSurname <- if
    | [bs] <- userSurname'
    , Right userSurname <- Text.decodeUtf8' bs
      -> return userSurname
    | otherwise
      -> throwM CampusUserInvalidSurname
  userTitle <- if
    | all ByteString.null userTitle'
      -> return Nothing
    | [bs] <- userTitle'
    , Right userTitle <- Text.decodeUtf8' bs
      -> return $ Just userTitle
    | otherwise
      -> throwM CampusUserInvalidTitle
  userMatrikelnummer <- if
    | [bs] <- userMatrikelnummer'
    , Right userMatrikelnummer <- Text.decodeUtf8' bs
      -> return $ Just userMatrikelnummer
    | [] <- userMatrikelnummer'
      -> return Nothing
    | otherwise
      -> throwM CampusUserInvalidMatriculation
  userSex <- if
    | [bs] <- userSex'
    , Right userSex'' <- Text.decodeUtf8' bs
    , Just userSex''' <- readMay userSex''
    , Just userSex <- userSex''' ^? iso5218
      -> return $ Just userSex
    | [] <- userSex'
      -> return   Nothing
    | otherwise
      -> throwM CampusUserInvalidSex

  let
    newUser = User
      { userMaxFavourites        = userDefaultMaxFavourites
      , userMaxFavouriteTerms    = userDefaultMaxFavouriteTerms
      , userTheme                = userDefaultTheme
      , userDateTimeFormat       = userDefaultDateTimeFormat
      , userDateFormat           = userDefaultDateFormat
      , userTimeFormat           = userDefaultTimeFormat
      , userDownloadFiles        = userDefaultDownloadFiles
      , userWarningDays          = userDefaultWarningDays
      , userShowSex              = userDefaultShowSex
      , userNotificationSettings = def
      , userLanguages            = Nothing
      , userCsvOptions           = def
      , userTokensIssuedAfter    = Nothing
      , userCreated              = now
      , userLastLdapSynchronisation = Just now
      , userDisplayName          = userDisplayName'
      , userDisplayEmail         = userEmail
      , ..
      }
    userUpdate =  [ UserMatrikelnummer          =. userMatrikelnummer
                  -- , UserDisplayName             =. userDisplayName
                  , UserFirstName               =. userFirstName
                  , UserSurname                 =. userSurname
                  , UserTitle                   =. userTitle  
                  , UserEmail                   =. userEmail
                  , UserSex                     =. userSex
                  , UserLastLdapSynchronisation =. Just now
                  ] ++
                  [ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ]

  user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate
  unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
    update userId [ UserDisplayName =. userDisplayName' ]

  let
    userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
    userStudyFeatures' = do
      (k, v) <- ldapData
      guard $ k == ldapUserStudyFeatures
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      return str

    termNames = nubBy ((==) `on` CI.mk) $ do
      (k, v) <- ldapData
      guard $ k == ldapUserFieldName
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      return str

    userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
    userSubTermsSemesters' = do
      (k, v) <- ldapData
      guard $ k == ldapUserSubTermsSemester
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      return str

  fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
  sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters

  let
    studyTermCandidates = Set.fromList $ do
      let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
          subTermsKeys = unStudyTermsKey . fst <$> sts

      (,) <$> sfKeys ++ subTermsKeys <*> termNames

  let
    assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) DB [StudyFeatures]
    assimilateSubTerms [] xs = return xs
    assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
      standalone <- lift $ get subterm
      case standalone of
        _other
          | (match : matches, unusedFeats') <- partition
              (\StudyFeatures{..} -> subterm     == studyFeaturesField
                                  && subSemester == studyFeaturesSemester
              ) unusedFeats
            -> do
              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
              (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
          | any ((== subterm) . studyFeaturesField) unusedFeats
            -> do
              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
              assimilateSubTerms subterms unusedFeats
        Just StudyTerms{..}
          | Just defDegree <- studyTermsDefaultDegree
          , Just defType   <- studyTermsDefaultType
            -> do
              $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
              (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
        Nothing
          | [] <- unusedFeats -> do
              $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
              tell $ Set.singleton (subterm, Nothing)
              assimilateSubTerms subterms []
        _other -> do
          knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
          let matchingFeatures = case knownParents of
                []      -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
                ps      -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats
          when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
            tell $ Set.singleton (subterm, Just studyFeaturesField)
          if
            | not $ null knownParents -> do
                $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
                let setSuperField sf = sf
                      & _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField))
                      & _studyFeaturesField .~ subterm
                (++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
            | otherwise -> do
                $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
                assimilateSubTerms subterms unusedFeats
  $logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|]
  (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'

  let
    studyTermCandidateIncidence
      = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
      . UUID.fromByteString
      . fromStrict
      . (convert :: Digest (SHAKE128 128) -> ByteString)
      . runConduitPure
      $ sourceList ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash

  candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
    E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
         E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
         E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)

  unless candidatesRecorded $ do
    let
      studyTermCandidates' = do
        (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
        let studyTermNameCandidateIncidence = studyTermCandidateIncidence
        return StudyTermNameCandidate{..}
    insertMany_ studyTermCandidates'

    let
      studySubTermParentCandidates' = do
        (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
        let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
        return StudySubTermParentCandidate{..}
    insertMany_ studySubTermParentCandidates'

    let
      studyTermStandaloneCandidates' = do
        (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
        let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
        return StudyTermStandaloneCandidate{..}
    insertMany_ studyTermStandaloneCandidates'

  E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
  forM_ fs $ \f@StudyFeatures{..} -> do
    insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
    insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
    oldFs <- selectKeysList
      ([ StudyFeaturesUser ==. studyFeaturesUser
       , StudyFeaturesDegree ==. studyFeaturesDegree
       , StudyFeaturesField ==. studyFeaturesField
       , StudyFeaturesType ==. studyFeaturesType
       , StudyFeaturesSemester ==. studyFeaturesSemester
       ])
      []
    case oldFs of
      [oldF] -> update oldF
        [ StudyFeaturesUpdated =. now
        , StudyFeaturesValid =. True
        , StudyFeaturesField =. studyFeaturesField
        , StudyFeaturesSuperField =. studyFeaturesSuperField
        ]
      _other -> void $ upsert f
        [ StudyFeaturesUpdated =. now
        , StudyFeaturesValid =. True
        , StudyFeaturesSuperField =. studyFeaturesSuperField
        ]
  associateUserSchoolsByTerms userId

  let
    userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools
    userAssociatedSchools' = do
      (k, v) <- ldapData
      guard $ k == ldapUserSchoolAssociation
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      return str
  
  ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools

  forM_ ss $ \frag -> void . runMaybeT $ do
    let
      exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
      infixMatch = (hoistMaybe . preview _head =<<) . lift . E.select . E.from $ \schoolLdap -> do
        E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
             E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
        return schoolLdap
    Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
    ssh <- hoistMaybe schoolLdapSchool

    lift . void $ insertUnique UserSchool
      { userSchoolUser     = userId
      , userSchoolSchool   = ssh
      , userSchoolIsOptOut = False
      }

  forM_ ss $ void . insertUnique . SchoolLdap Nothing
  
  return user
  where
    insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())

associateUserSchoolsByTerms :: UserId -> DB ()
associateUserSchoolsByTerms uid = do
  sfs <- selectList [StudyFeaturesUser ==. uid] []

  forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
    schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
    forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
      void $ insertUnique UserSchool
        { userSchoolUser     = uid
        , userSchoolSchool   = schoolTermsSchool
        , userSchoolIsOptOut = False
        }

updateUserLanguage :: Maybe Lang -> DB (Maybe Lang)
updateUserLanguage (Just lang) = do
  unless (lang `elem` appLanguages) $
    invalidArgs ["Unsupported language"]

  muid <- maybeAuthId
  for_ muid $ \uid -> do
    langs <- languages
    update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
  setRegisteredCookie CookieLang lang
  return $ Just lang
updateUserLanguage Nothing = runMaybeT $ do
  uid <- MaybeT maybeAuthId
  User{..} <- MaybeT $ get uid
  setLangs <- toList . selectLanguages appLanguages <$> languages
  highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
  let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
  lang <- case (userLanguages', setLangs, highPrioSetLangs) of
    (_, _, hpl : _)
      -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
    (Just (l : _), _, _)
      -> return l
    (Nothing, l : _, _)
      -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
    (Just [], l : _, _)
      -> return l
    (_, [], _)
      -> mzero
  setRegisteredCookie CookieLang lang
  return lang


instance YesodAuth UniWorX where
    type AuthId UniWorX = UserId

    -- Where to send a user after successful login
    loginDest _ = NewsR
    -- Where to send a user after logout
    logoutDest _ = NewsR
    -- Override the above two destinations when a Referer: header is present
    redirectToReferer _ = True

    loginHandler = do
      toParent <- getRouteToParent
      liftHandler . defaultLayout $ do
        plugins <- getsYesod authPlugins
        $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)

        setTitleI MsgLoginTitle
        $(widgetFile "login")

    authenticate creds@Creds{..} = liftHandler . runDB $ do
      now <- liftIO getCurrentTime

      let
        uAuth = UniqueAuthentication $ CI.mk credsIdent
        upsertMode = creds ^? _upsertCampusUserMode

        isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode
        isOther = is (_Just . _UpsertCampusUserOther) upsertMode

        excRecovery res
          | isDummy || isOther
          = do
              case res of
                UserError   err -> addMessageI Error   err
                ServerError err -> addMessage  Error $ toHtml err
                _other          -> return ()
              acceptExisting
          | otherwise
          = return res

        excHandlers =
          [ C.Handler $ \case
              CampusUserNoResult -> do
                $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
                excRecovery . UserError $ IdentifierNotFound credsIdent
              CampusUserAmbiguous -> do
                $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
                excRecovery . UserError $ IdentifierNotFound credsIdent
              err -> do
                $logErrorS "LDAP" $ tshow err
                mr <- getMessageRender
                excRecovery . ServerError $ mr MsgInternalLdapError
          , C.Handler $ \(cExc :: CampusUserConversionException) -> do
              $logErrorS "LDAP" $ tshow cExc
              mr <- getMessageRender
              excRecovery . ServerError $ mr cExc
          ]

        acceptExisting = do
          res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
          case res of
            Authenticated uid
              -> associateUserSchoolsByTerms uid
            _other
              -> return ()
          case res of
            Authenticated uid
              | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
            _other -> return res

      $logDebugS "auth" $ tshow Creds{..}
      UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod

      flip catches excHandlers $ case appLdapPool of
        Just ldapPool
          | Just upsertMode' <- upsertMode -> do
              ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
              $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
              Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
        _other
          -> acceptExisting

    authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
      [ flip campusLogin campusUserFailoverMode <$> appLdapPool
      , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
      , dummyLogin <$ guard appAuthDummyLogin
      ]

    authHttpManager = getsYesod appHttpManager

    onLogin = liftHandler $ do
      mlang <- runDB $ updateUserLanguage Nothing
      app <- getYesod
      let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
             | otherwise = renderMessage app []
      addMessage Success . toHtml $ mr Auth.NowLoggedIn

    onErrorHtml dest msg = do
      addMessage Error $ toHtml msg
      redirect dest

    renderAuthMessage _ ls = case lang of
      ("en" : _) -> Auth.englishMessage
      _other     -> Auth.germanMessage
      where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls

campusUserFailoverMode :: FailoverMode
campusUserFailoverMode = FailoverUnlimited

instance YesodAuthPersist UniWorX where
  getAuthEntity = liftHandler . runDBRead . get

  
unsafeHandler :: UniWorX -> Handler a -> IO a
unsafeHandler f h = do
  logger <- makeLogger f
  Unsafe.fakeHandlerGetLogger (const logger) f h


instance YesodMail UniWorX where
  defaultFromAddress = getsYesod $ view _appMailFrom
  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
  mailVerp = getsYesod $ view _appMailVerp
  mailDateTZ = return appTZ
  mailSmtp act = do
    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
    withResource pool act
  mailT ctx mail = defMailT ctx $ do
    void setMailObjectIdRandom
    setDateCurrent
    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)

    (mRes, smtpData) <- listen mail
    unless (view _MailSmtpDataSet smtpData)
      setMailSmtpData

    return mRes


instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
  type MonadCryptoKey m = CryptoIDKey
  cryptoIDKey f = getsYesod appCryptoIDKey >>= f

instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
  secretBoxKey = getsYesod appSecretBoxKey

-- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful
-- links:
--
-- https://github.com/yesodweb/yesod/wiki/Sending-email
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding


embedRenderMessage ''UniWorX ''ButtonSubmit id

embedRenderMessage ''UniWorX ''CampusUserConversionException id