{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto

module Foundation where

import Import.NoFoundation hiding (embedFile)
import qualified ClassyPrelude.Yesod as Yesod (getHttpManager)
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet          (hamletFile)

import qualified Web.ClientSession as ClientSession

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

import qualified Network.Wai as W (pathInfo)

import Yesod.Core.Types     (Logger)
import qualified Yesod.Core.Unsafe as Unsafe
import Data.CaseInsensitive (original, mk)

import Data.ByteArray (convert)
import Crypto.Hash (Digest, 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 Data.ByteString (ByteString)
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 Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map, (!?))
import qualified Data.Map as Map
import qualified Data.HashSet as HashSet

import Data.List (nubBy, (!!), findIndex)

import Data.Monoid (Any(..))

import Data.Pool

import Data.Conduit (($$))
import Data.Conduit.List (sourceList)

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

import Control.Monad.Except (MonadError(..), ExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Reader (runReader, mapReaderT)
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Memo.Class (MonadMemo(..), for4)
import qualified Control.Monad.Catch as C

import Handler.Utils.StudyFeatures
import Utils.Form
import Utils.Sheet
import Utils.SystemMessage

import Text.Shakespeare.Text (st)

import Yesod.Form.I18n.German
import qualified Yesod.Auth.Message as Auth

import qualified Data.Conduit.List as C

import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Jose.Jwk as Jose

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.FileEmbed (embedFile)

import qualified Ldap.Client as Ldap


type SMTPPool = Pool SMTPConnection

-- infixl 9 :$:
-- pattern a :$: b = a b

-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data UniWorX = UniWorX
    { appSettings'       :: AppSettings
    , appStatic          :: EmbeddedStatic -- ^ Settings for static file serving.
    , appConnPool        :: ConnectionPool -- ^ Database connection pool.
    , appSmtpPool        :: Maybe SMTPPool
    , appLdapPool        :: Maybe LdapPool
    , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
    , appHttpManager     :: Manager
    , appLogger          :: (ReleaseKey, TVar Logger)
    , appLogSettings     :: TVar LogSettings
    , appCryptoIDKey     :: CryptoIDKey
    , appClusterID       :: ClusterId
    , appInstanceID      :: InstanceId
    , appJobState        :: TMVar JobState
    , appSessionKey      :: ClientSession.Key
    , appSecretBoxKey    :: SecretBox.Key
    , appJSONWebKeySet   :: Jose.JwkSet
    , appHealthReport    :: TVar (Set (UTCTime, HealthReport))
    }

makeLenses_ ''UniWorX
instance HasInstanceID UniWorX InstanceId where
  instanceID = _appInstanceID
instance HasJSONWebKeySet UniWorX Jose.JwkSet where
  jsonWebKeySet = _appJSONWebKeySet
instance HasHttpManager UniWorX Manager where
  httpManager = _appHttpManager
instance HasAppSettings UniWorX where
  appSettings = _appSettings'

-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
--
-- Note that this is really half the story; in Application.hs, mkYesodDispatch
-- generates the rest of the code. Please see the following documentation
-- for an explanation for this split:
-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
--
-- This function also generates the following type synonyms:
-- type Handler x = HandlerT UniWorX IO x
-- type Widget    = WidgetT  UniWorX IO ()
mkYesodData "UniWorX" $(parseRoutesFile "routes")

deriving instance Generic CourseR
deriving instance Generic SheetR
deriving instance Generic SubmissionR
deriving instance Generic MaterialR
deriving instance Generic TutorialR
deriving instance Generic ExamR
deriving instance Generic CourseApplicationR
deriving instance Generic AllocationR
deriving instance Generic (Route UniWorX)

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

-- Pattern Synonyms for convenience
pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX
pattern CSheetR tid ssh csh shn ptn
  = CourseR tid ssh csh (SheetR shn ptn)

pattern CMaterialR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> MaterialR -> Route UniWorX
pattern CMaterialR tid ssh csh mnm ptn
  = CourseR tid ssh csh (MaterialR mnm ptn)

pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX
pattern CTutorialR tid ssh csh tnm ptn
  = CourseR tid ssh csh (TutorialR tnm ptn)

pattern CExamR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamR -> Route UniWorX
pattern CExamR tid ssh csh tnm ptn
  = CourseR tid ssh csh (ExamR tnm ptn)

pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX
pattern CSubmissionR tid ssh csh shn cid ptn
  = CSheetR tid ssh csh shn (SubmissionR cid ptn)

pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX
pattern CApplicationR tid ssh csh appId ptn
  = CourseR tid ssh csh (CourseApplicationR appId ptn)


pluralDE :: (Eq a, Num a)
            =>    a -- ^ Count
            -> Text -- ^ Singular
            -> Text -- ^ Plural
            -> Text
pluralDE num singularForm pluralForm
  | num == 1  = singularForm
  | otherwise = pluralForm

noneOneMoreDE :: (Eq a, Num a)
            =>    a -- ^ Count
            -> Text -- ^ None
            -> Text -- ^ Singular
            -> Text -- ^ Plural
            -> Text
noneOneMoreDE num noneText singularForm pluralForm
  | num == 0  = noneText
  | num == 1  = singularForm
  | otherwise = pluralForm

noneMoreDE :: (Eq a, Num a)
            =>    a -- ^ Count
            -> Text -- ^ None
            -> Text -- ^ Some
            -> Text
noneMoreDE num noneText someText
  | num == 0  = noneText
  | otherwise = someText

-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
type IntMaybe  = Maybe Int
type TextList  = [Text]

-- | Convenience function for i18n messages definitions
maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text
maybeToMessage _      Nothing  _     = mempty
maybeToMessage before (Just x) after = before <> (toMessage x) <> after

-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
mkMessage "UniWorX" "messages/uniworx" "de"
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
mkMessageVariant "UniWorX" "Button" "messages/button" "de"
mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de"

-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage UniWorX FormMessage where
    renderMessage _ _  = germanFormMessage -- TODO

instance RenderMessage UniWorX TermIdentifier where
  renderMessage foundation ls TermIdentifier{..} = case season of
    Summer -> renderMessage' $ MsgSummerTerm year
    Winter -> renderMessage' $ MsgWinterTerm year
    where renderMessage' = renderMessage foundation ls

newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
  deriving (Eq, Ord, Read, Show)
instance RenderMessage UniWorX ShortTermIdentifier where
  renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
    Summer -> renderMessage' $ MsgSummerTermShort year
    Winter -> renderMessage' $ MsgWinterTermShort year
    where renderMessage' = renderMessage foundation ls

instance RenderMessage UniWorX String where
  renderMessage f ls str = renderMessage f ls $ Text.pack str

-- TODO: raw number representation; instead, display e.g. 1000 as 1.000 or 1,000 or ... (language-dependent!)
instance RenderMessage UniWorX Int where
  renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Int64 where
  renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Integer where
  renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Natural where
  renderMessage f ls = renderMessage f ls . tshow

instance HasResolution a => RenderMessage UniWorX (Fixed a) where
  renderMessage f ls = renderMessage f ls . showFixed True

instance RenderMessage UniWorX Load where
  renderMessage foundation ls = renderMessage foundation ls . \case
      (Load {byTutorial=Nothing   , byProportion=p}) -> MsgCorByProportionOnly p
      (Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p
      (Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p

newtype MsgLanguage = MsgLanguage Lang
  deriving (Eq, Ord, Show, Read)
instance RenderMessage UniWorX MsgLanguage where
  renderMessage foundation ls (MsgLanguage lang@(Text.splitOn "-" -> lang'))
    | ["de", "DE"] <- lang' = mr MsgGermanGermany
    | ("de" : _)   <- lang' = mr MsgGerman
    | otherwise = lang
    where
      mr = renderMessage foundation ls

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

embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''StudyFieldType id
embedRenderMessage ''UniWorX ''SheetFileType id
embedRenderMessage ''UniWorX ''SubmissionFileType id
embedRenderMessage ''UniWorX ''CorrectorState id
embedRenderMessage ''UniWorX ''RatingException id
embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
embedRenderMessage ''UniWorX ''LecturerType id
embedRenderMessage ''UniWorX ''SubmissionModeDescr
  $ let verbMap [_, _, "None"] = "NoSubmissions"
        verbMap [_, _, v] = v <> "Submissions"
        verbMap _ = error "Invalid number of verbs"
     in verbMap . splitCamel
embedRenderMessage ''UniWorX ''UploadModeDescr id
embedRenderMessage ''UniWorX ''SecretJSONFieldException id
embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel

embedRenderMessage ''UniWorX ''AuthenticationMode id

newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)

instance RenderMessage UniWorX SheetType where
  renderMessage foundation ls sheetType = case sheetType of
      NotGraded -> mr $ SheetTypeHeader NotGraded
      other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

instance RenderMessage UniWorX StudyDegree where
  renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)

newtype ShortStudyDegree = ShortStudyDegree StudyDegree

instance RenderMessage UniWorX ShortStudyDegree where
  renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand

instance RenderMessage UniWorX StudyTerms where
  renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)

newtype ShortStudyTerms = ShortStudyTerms StudyTerms

instance RenderMessage UniWorX ShortStudyTerms where
  renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand

data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms

instance RenderMessage UniWorX StudyDegreeTerm where
  renderMessage foundation ls (StudyDegreeTerm deg trm) = (mr trm) <> " (" <> (mr $ ShortStudyDegree deg) <> ")"
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

instance RenderMessage UniWorX ExamGrade where
  renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade

instance RenderMessage UniWorX ExamPassed where
  renderMessage foundation ls = \case
    ExamPassed True  -> mr MsgExamPassed
    ExamPassed False -> mr MsgExamNotPassed
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
  renderMessage foundation ls = \case
    ExamAttended{..} -> mr examResult
    ExamNoShow       -> mr MsgExamResultNoShow
    ExamVoided       -> mr MsgExamResultVoided
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls


-- ToMessage instances for converting raw numbers to Text (no internationalization)

instance ToMessage Int where
  toMessage = tshow
instance ToMessage Int64 where
  toMessage = tshow
instance ToMessage Integer where
  toMessage = tshow
instance ToMessage Natural where
  toMessage = tshow

instance HasResolution a => ToMessage (Fixed a) where
  toMessage = toMessage . showFixed True

-- Do not use toMessage on Rationals and round them automatically. Instead, use rationalToFixed3 (declared in src/Utils.hs) to convert a Rational to Fixed E3!
-- instance ToMessage Rational where
--   toMessage = toMessage . fromRational'
--     where fromRational' = fromRational :: Rational -> Fixed E3


newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)

newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
  deriving (Generic, Typeable)
  deriving newtype (Semigroup, Monoid, IsList)

instance RenderMessage UniWorX UniWorXMessages where
  renderMessage foundation ls (UniWorXMessages msgs) =
    intercalate " " $ map (renderMessage foundation ls) msgs

uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
uniworxMessages = UniWorXMessages . map SomeMessage

-- Menus and Favourites
data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary | Footer
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

instance Universe MenuType
instance Finite MenuType

makePrisms ''MenuType

data MenuItem = MenuItem
  { menuItemLabel :: UniWorXMessage
  , menuItemIcon  :: Maybe Text     -- currently from: https://fontawesome.com/icons?d=gallery
  , menuItemRoute :: SomeRoute UniWorX
  , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked)
  , menuItemModal :: Bool
  , menuItemType :: MenuType
  }

makeLenses_ ''MenuItem

instance RedirectUrl UniWorX MenuItem where
  toTextUrl MenuItem{..} = toTextUrl menuItemRoute
instance HasRoute UniWorX MenuItem where
  urlRoute MenuItem{..} = urlRoute menuItemRoute

menuItemAccessCallback :: MenuItem -> Handler Bool
menuItemAccessCallback MenuItem{..} = and2M ((==) Authorized <$> authCheck) menuItemAccessCallback'
  where
    authCheck = handleAny (\_ -> return . Unauthorized $ error "authCheck caught exception") $ isAuthorized (urlRoute menuItemRoute) False

$(return [])


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

instance PathPiece (ButtonClass UniWorX) where
  toPathPiece BCIsButton = "btn"
  toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
  fromPathPiece = finiteFromPathPiece


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


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

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

appLanguages :: NonEmpty Lang
appLanguages = "de-DE" :| []

appLanguagesOpts :: ( MonadHandler m
                    , HandlerSite m ~ UniWorX
                    ) => m (OptionList Lang)
-- ^ Authoritive list of supported Languages
appLanguagesOpts = do
  mr <- getsYesod renderMessage
  let mkOption l = Option
        { optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l)
        , optionInternalValue = l
        , optionExternalValue = l
        }
      langOptions = map mkOption $ toList appLanguages
  return $ mkOptionList langOptions


instance RenderMessage UniWorX WeekDay where
  renderMessage _ ls wDay = pack $ map fst (wDays $ getTimeLocale' ls) !! fromEnum wDay

newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }

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

-- 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 -> DB 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 = liftHandlerT $ case aPred of
    (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
    (APHandler p) -> p aid r w
    (APDB      p) -> runDB $ p aid r w

instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
  evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ 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


askTokenUnsafe :: forall m.
                  ( MonadHandler m
                  , HandlerSite m ~ UniWorX
                  , MonadLogger m
                  , MonadCatch m
                  )
               => ExceptT AuthResult m (BearerToken (UniWorX))
-- | This performs /no/ meaningful validation of the `BearerToken`
--
-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
askTokenUnsafe = $cachedHere $ do
  jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
  catch (decodeToken jwt) $ \case
    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
    other -> do
      $logWarnS "AuthToken" $ tshow other
      throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid

validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
  where
    validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
    validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
      guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)

      User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
      guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)

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

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

      whenIsJust tokenAddAuth $ \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


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.^. UserAdminSchool
      E.where_  $ userAdmin E.^. UserAdminUser 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 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.^. UserAdminSchool
      E.where_  $ userAdmin E.^. UserAdminUser 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 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 [UserAdminUser ==. authId] []
    guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
    return Authorized
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
  lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
  AdminHijackUserR cID -> exceptT return return $ do
    myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
    uid <- decrypt cID
    otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
    otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
    mySchools <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
    guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `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 <- 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 (AApplicationR cID) -> $cachedHereBinary (mAuthId, tid, ssh, ash, cID) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedLecturer) (const True :: CryptoIDError -> Bool) $ decrypt cID
    isLecturer <- lift . E.selectExists . E.from $ \(courseApplication `E.InnerJoin` 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.on $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
       E.&&. courseApplication E.^. CourseApplicationCourse E.==. course E.^. CourseId
      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
           E.&&. courseApplication E.^. CourseApplicationId E.==. E.val appId
    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
  -- lecturer for any school will do
  _ -> $cachedHereBinary mAuthId . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
     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 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 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
    registered <- case mAuthId of
      Just uid -> $cachedHereBinary (eId, uid) . lift . existsBy $ UniqueExamRegistration eId uid
      Nothing  -> return False

    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
        | not registered -> guard $ visible
                                 && NTop examRegisterFrom <= NTop (Just cTime)
                                 && NTop (Just cTime) <= NTop examRegisterTo
        | otherwise      -> guard $ visible
                                 && NTop (Just cTime) <= NTop examDeregisterUntil
      _          -> 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 = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
      marking = cTime > sheetActiveTo

    guard visible

    case subRoute of
      -- Single Files
      SFileR                SheetExercise _ -> guard $ sheetActiveFrom <= cTime
      SFileR                SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
      SFileR                SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
      SFileR                _             _ -> mzero
      -- Archives of SheetFileType
      SZipR                 SheetExercise   -> guard $ sheetActiveFrom <= 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) $ isJust <$> (getBy $ UniqueParticipant uid cid)
      _ -> 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
            return Authorized
      _other -> unauthorizedI MsgUnauthorizedCourseTime

  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

  r -> $unsupportedAuthPredicate AuthTime r
tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of
  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 allocationStaffRegisterTo <= NTop (Just now)
          || NTop allocationStaffRegisterFrom >= 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.&&. 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 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 `E.FullOuterJoin` (examPartResult `E.InnerJoin` examPart))) -> do
      E.on $ examPartResult E.?. ExamPartResultExamPart E.==. examPart E.?. ExamPartId
      E.on $ examResult E.?. ExamResultExam E.==. examPart E.?. ExamPartExam
      E.on $ E.just (exam E.^. ExamId) E.==. examResult E.?. ExamResultExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ (examResult E.?. ExamResultUser E.==. E.just (E.val authId) E.||. examPartResult E.?. ExamPartResultUser E.==. E.just (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 (unauthorizedI MsgUnauthorizedExamResult)
    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 `E.FullOuterJoin` (examPartResult `E.InnerJoin` examPart))) -> do
      E.on $ examPartResult E.?. ExamPartResultExamPart E.==. examPart E.?. ExamPartId
      E.on $ examResult E.?. ExamResultExam E.==. examPart E.?. ExamPartExam
      E.on $ E.just (exam E.^. ExamId) E.==. examResult E.?. ExamResultExam
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.where_ $ (examResult E.?. ExamResultUser E.==. E.just (E.val authId) E.||. examPartResult E.?. ExamPartResultUser E.==. E.just (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 (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 $ \_ route _ -> case route of
  CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
    cTime <- liftIO getCurrentTime
    let authorizedIfExists f = do
          [E.Value ok] <- lift . E.select . return . E.exists $ E.from f
          whenExceptT ok Authorized
    participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
    -- participant is currently registered
    $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
    -- participant has at least one submission
    $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
    $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
    $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
    $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
    $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 lecturer for this course
    $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 is applicant for this course
    $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \((course `E.InnerJoin` courseApplication) `E.LeftOuterJoin` allocation) -> do
      E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
      E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
      E.where_ $ courseApplication E.^. CourseApplicationUser 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
      E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom)
           E.&&. E.maybe E.true (E.maybe E.true  $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo)
      
    unauthorizedI MsgUnauthorizedParticipant
  r -> $unsupportedAuthPredicate AuthParticipant r
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
  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 $ fromIntegral <$> 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 $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
    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
        [E.Value hasOther] <- $cachedHereBinary (uid, rGroup) . lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do
          E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
          E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid
               E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup)
        guard $ not hasOther
        return Authorized
  r -> $unsupportedAuthPredicate AuthRegisterGroup r
tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
  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
    AllocationR _ _ _ (AApplicationR 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
  r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)


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, MonadLogger 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 :: (MonadLogger 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 :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessForDB = evalAccessFor

evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess route isWrite = do
  mAuthId <- liftHandlerT 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 :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) 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 :: (MonadLogger 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 :: (MonadLogger 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 :: (MonadLogger 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 :: (MonadLogger 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

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


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

    -- Store session data on the client in encrypted cookies,
    -- default session idle timeout is 120 minutes
    makeSessionBackend app = do
      (getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout)
      return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate

    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 = headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
      where
        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
                $logDebugS "updateFavourites" "Updating favourites"

                now <- liftIO $ getCurrentTime
                uid <- MaybeT $ liftHandlerT maybeAuthId
                cid  <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
                user <- MaybeT $ get uid
                let courseFavourite = CourseFavourite uid now cid

                $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|]
                -- update Favourites
                void . lift $ upsertBy
                  (UniqueCourseFavourite uid cid)
                  courseFavourite
                  [CourseFavouriteTime =. now]
                -- prune Favourites to user-defined size
                oldFavs <- lift $ selectKeysList
                  [ CourseFavouriteUser ==. uid]
                  [ Desc CourseFavouriteTime
                  , OffsetBy $ userMaxFavourites user
                  ]
                lift . forM_ oldFavs $ \fav -> do
                  $logDebugS "updateFavourites" "Deleting old favourite."
                  delete fav
            _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

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

    errorHandler err = do
      mr <- getMessageRender
      let
        encrypted :: ToJSON a => a -> Widget -> Widget
        encrypted plaintextJson plaintext = do
          canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
          shouldEncrypt <- view _appEncryptErrors
          if
            | shouldEncrypt
            , not canDecrypt -> 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)}|]
      fmap toTypedContent . siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
        toWidget
          [cassius|
            .errMsg
              white-space: pre-wrap
              font-family: monospace
          |]
        errPage

    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{ widgetMemcachedConnectInfo = _, .. }) -> do
        let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
            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)
                 . runIdentity
                 $ 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.
    shouldLog _ _ _ = error "Must use shouldLogIO"
    shouldLogIO app _source level = do
      LogSettings{..} <- readTVarIO $ appLogSettings app
      return $ logAll || level >= logMinimumLevel

    makeLogger = readTVarIO . snd . appLogger


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{..}, .. } <- view appSettings

  isModal <- hasCustomHeader HeaderIsModal

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

  mcurrentRoute <- getCurrentRoute

  -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
  (title, parents) <- breadcrumbs

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

  defaultLinks' <- defaultLinks
  let menu :: [MenuItem]
      menu = defaultLinks' ++ maybe [] pageActions mcurrentRoute

  menuTypes <- mapM (\x -> (,,) <$> pure x <*> newIdent <*> toTextUrl x) =<< filterM menuItemAccessCallback menu

  isAuth <- isJust <$> maybeAuthId

  -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?!
  (favourites', currentTheme) <- do
      muid <- maybeAuthPair
      case muid of
          Nothing         -> return ([],userDefaultTheme)
          (Just (uid,user)) -> do
              favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
                  E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
                  E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
                  E.orderBy [ E.asc $ course E.^. CourseShorthand ]
                  return course
              return (favs, userTheme user)
  favourites <- forM favourites' $ \(Entity _ c@Course{..})
      -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
         in do
           items <- filterM menuItemAccessCallback (pageActions courseRoute)
           items' <- forM items $ \i -> (i, ) <$> toTextUrl i
           return (c, courseRoute, items')

  mmsgs <- if
    | isModal -> getMessages
    | 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

  let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
      highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
                      navItems = map (view _2) favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes
                      highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
                  in \r -> Just r == highR
      favouriteTerms :: [TermIdentifier]
      favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
      favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])]
      favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites

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

      navbarModal (MenuItem{..}, menuIdent') = customModal Modal
        { modalTriggerId = Just menuIdent'
        , modalId = Nothing
        , modalTrigger = \(Just route) menuIdent -> $(widgetFile "widgets/navbar/item")
        , modalContent = Left menuItemRoute
        }

      navbarItem (MenuItem{..}, menuIdent) = do
        route <- toTextUrl menuItemRoute
        $(widgetFile "widgets/navbar/item")

      navbar :: Widget
      navbar = $(widgetFile "widgets/navbar/navbar")
      asidenav :: Widget
      asidenav = $(widgetFile "widgets/asidenav/asidenav")
        where logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg")
      footer :: Widget
      footer = $(widgetFile "widgets/footer/footer")
      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 = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes
      hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes

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

  pc <- widgetToPageContent $ do
      -- fonts
      addStylesheet $ StaticR fonts_fonts_css
      -- SCSS
      addStylesheet $ StaticR bundles_css_vendor_css
      addStylesheet $ StaticR bundles_css_main_css
      -- JavaScript
      addScript $ StaticR bundles_js_polyfills_js
      addScript $ StaticR bundles_js_vendor_js
      addScript $ StaticR bundles_js_main_js
      toWidget $(juliusFile "templates/i18n.julius")
      -- widgets
      $(widgetFile "default-layout")
  withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")


applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
  where
    applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
      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

      let sessionKey = "sm-" <> tshow (ciphertext cID)
      _ <- assertM isNothing $ lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())
      setSessionJson sessionKey ()

      (_, 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

-- Define breadcrumbs.
instance YesodBreadcrumbs UniWorX where
  breadcrumb (AuthR _)        = return ("Login"        , Just HomeR)
  breadcrumb HomeR            = return ("Uni2work"     , Nothing)
  breadcrumb UsersR           = return ("Benutzer"     , Just AdminR)
  breadcrumb (AdminUserR _)   = return ("Users"        , Just UsersR)
  breadcrumb AdminR           = return ("Administration", Nothing)
  breadcrumb AdminFeaturesR   = return ("Test"         , Just AdminR)
  breadcrumb AdminTestR       = return ("Test"         , Just AdminR)
  breadcrumb AdminErrMsgR     = return ("Test"         , Just AdminR)

  breadcrumb InfoR            = return ("Information"  , Nothing)
  breadcrumb InfoLecturerR    = return ("Veranstalter" , Just InfoR)
  breadcrumb DataProtR        = return ("Datenschutz"  , Just InfoR)
  breadcrumb ImpressumR       = return ("Impressum"    , Just InfoR)
  breadcrumb VersionR         = return ("Versionsgeschichte", Just InfoR)


  breadcrumb HelpR            = return ("Hilfe"        , Just HomeR)


  breadcrumb HealthR          = return ("Status"        , Nothing)
  breadcrumb InstanceR        = return ("Identifikation", Nothing)


  breadcrumb ProfileR         = return ("User"             , Just HomeR)
  breadcrumb ProfileDataR     = return ("Profile"          , Just ProfileR)
  breadcrumb AuthPredsR       = return ("Authentifizierung", Just ProfileR)

  breadcrumb TermShowR              = return ("Semester"  , Just HomeR)
  breadcrumb TermCurrentR           = return ("Aktuell"   , Just TermShowR)
  breadcrumb TermEditR              = return ("Neu"       , Just TermCurrentR)
  breadcrumb (TermEditExistR tid)   = return ("Editieren" , Just $ TermCourseListR tid)
  breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just CourseListR)

  breadcrumb (TermSchoolCourseListR tid ssh)  = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid)

  breadcrumb AllocationListR        = return ("Zentralanmeldungen", Just HomeR)
  breadcrumb (AllocationR tid ssh ash AShowR) = do
    mr <- getMessageRender
    Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
    return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ AllocationListR)
  breadcrumb (AllocationR tid ssh ash (AApplicationR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR)

  breadcrumb  CourseListR                 = return ("Kurse"    , Nothing)
  breadcrumb  CourseNewR                  = return ("Neu"      , Just CourseListR)
  breadcrumb (CourseR tid ssh csh CShowR) = return (original csh, Just $ TermSchoolCourseListR tid ssh)
  --         (CourseR tid ssh csh CRegisterR) -- is POST only
  breadcrumb (CourseR tid ssh csh CEditR)     = return ("Editieren"  , Just $ CourseR tid ssh csh CShowR)
  breadcrumb (CourseR tid ssh csh CUsersR)    = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
  breadcrumb (CourseR tid ssh csh CAddUserR)  = return ("Kursteilnehmer hinzufügen", Just $ CourseR tid ssh csh CUsersR)
  breadcrumb (CourseR tid ssh csh CInviteR)   = return ("Einladung", Just $ CourseR tid ssh csh CShowR)
  breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
  breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
  breadcrumb (CourseR tid ssh csh CAssignR)   = return ("Zuteilung Korrekturen"  , Just $ CourseR tid ssh csh CCorrectionsR)
  breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen"    , Just $ CourseR tid ssh csh CShowR)
  breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu",         Just $ CourseR tid ssh csh SheetListR)
  breadcrumb (CourseR tid ssh csh SheetCurrentR) = return ("Aktuelles Blatt", Just $ CourseR tid ssh csh SheetListR)
  breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = return ("Offene Abgaben", Just $ CourseR tid ssh csh SheetListR)
  breadcrumb (CourseR tid ssh csh CCommR    ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR)
  breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR)
  breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR)

  breadcrumb (CourseR tid ssh csh CExamListR) = return ("Prüfungen", Just $ CourseR tid ssh csh CShowR)
  breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)

  breadcrumb (CourseR tid ssh csh CApplicationsR) = return ("Bewerbungen", Just $ CourseR tid ssh csh CShowR)

  breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
  breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
  breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
  breadcrumb (CExamR tid ssh csh examn EAddUserR)  = return ("Prüfungsteilnehmer hinzufügen", Just $ CExamR tid ssh csh examn EUsersR)

  breadcrumb (CTutorialR tid ssh csh tutn TUsersR)   = return (original tutn, Just $ CourseR tid ssh csh CTutorialListR)
  breadcrumb (CTutorialR tid ssh csh tutn TEditR)    = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR)
  breadcrumb (CTutorialR tid ssh csh tutn TDeleteR)  = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR)
  breadcrumb (CTutorialR tid ssh csh tutn TCommR)    = return ("Mitteilung", Just $ CTutorialR tid ssh csh tutn TUsersR)

  breadcrumb (CSheetR tid ssh csh shn SShowR)   = return (original shn, Just $ CourseR tid ssh csh SheetListR)
  breadcrumb (CSheetR tid ssh csh shn SEditR)   = return ("Bearbeiten"   , Just $ CSheetR tid ssh csh shn SShowR)
  breadcrumb (CSheetR tid ssh csh shn SDelR )   = return ("Löschen"      , Just $ CSheetR tid ssh csh shn SShowR)
  breadcrumb (CSheetR tid ssh csh shn SSubsR)   = return ("Abgaben"      , Just $ CSheetR tid ssh csh shn SShowR)
  breadcrumb (CSheetR tid ssh csh shn SAssignR) = return ("Zuteilung Korrekturen"     , Just $ CSheetR tid ssh csh shn SSubsR)
  breadcrumb (CSheetR tid ssh csh shn SubmissionNewR)  = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
  breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR)  = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
  breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
--           (CSubmissionR tid ssh csh shn _ SubArchiveR)  -- just for Download
  breadcrumb (CSubmissionR tid ssh csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid ssh csh shn cid SubShowR)
--           (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download
  breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR)
  --         (CSheetR tid ssh csh shn SFileR) -- just for Downloads

  breadcrumb (CourseR tid ssh csh MaterialListR) = return ("Material"     , Just $ CourseR tid ssh csh CShowR)
  breadcrumb (CourseR tid ssh csh MaterialNewR ) = return ("Neu"          , Just $ CourseR tid ssh csh MaterialListR)
  breadcrumb (CMaterialR tid ssh csh mnm MShowR) = return (original mnm, Just $ CourseR tid ssh csh MaterialListR)
  breadcrumb (CMaterialR tid ssh csh mnm MEditR) = return ("Bearbeiten"   , Just $ CMaterialR tid ssh csh mnm MShowR)
  breadcrumb (CMaterialR tid ssh csh mnm MDelR)  = return ("Löschen"      , Just $ CMaterialR tid ssh csh mnm MShowR)
  --         (CMaterialR tid ssh csh mnm MFileR) -- just for Downloads

  -- Others
  breadcrumb (CorrectionsR)       = return ("Korrekturen", Just HomeR)
  breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
  breadcrumb (MessageR _) = do
    mayList <- (== Authorized) <$> evalAccess MessageListR False
    return $ if
      | mayList   -> ("Statusmeldung", Just MessageListR)
      | otherwise -> ("Statusmeldung", Just HomeR)
  breadcrumb (MessageListR) = return ("Statusmeldungen", Just AdminR)
  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 [MenuItem]
defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
  [ return MenuItem
      { menuItemType  = NavbarAside
      , menuItemLabel = MsgMenuHome
      , menuItemIcon  = Just "home"
      , menuItemRoute = SomeRoute HomeR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , return MenuItem
      { menuItemType  = Footer
      , menuItemLabel = MsgMenuDataProt
      , menuItemIcon  = Just "shield"
      , menuItemRoute = SomeRoute DataProtR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , return MenuItem
      { menuItemType  = Footer
      , menuItemLabel = MsgMenuImpressum
      , menuItemIcon  = Just "file-signature"
      , menuItemRoute = SomeRoute ImpressumR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , return MenuItem
      { menuItemType  = Footer
      , menuItemLabel = MsgMenuInformation
      , menuItemIcon  = Just "info"
      , menuItemRoute = SomeRoute InfoR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , do
      mCurrentRoute <- getCurrentRoute

      return MenuItem
        { menuItemType  = NavbarRight
        , menuItemLabel = MsgMenuHelp
        , menuItemIcon  = Just "question"
        , menuItemRoute = SomeRoute (HelpR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mCurrentRoute])
        , menuItemModal = True
        , menuItemAccessCallback' = return True
        }
  , return MenuItem
      { menuItemType  = NavbarRight
      , menuItemLabel = MsgMenuProfile
      , menuItemIcon  = Just "cogs"
      , menuItemRoute = SomeRoute ProfileR
      , menuItemModal = False
      , menuItemAccessCallback' = isJust <$> maybeAuthPair
      }
  , return MenuItem
      { menuItemType  = NavbarSecondary
      , menuItemLabel = MsgMenuLogin
      , menuItemIcon  = Just "sign-in-alt"
      , menuItemRoute = SomeRoute $ AuthR LoginR
      , menuItemModal = True
      , menuItemAccessCallback' = isNothing <$> maybeAuthPair
      }
  , return MenuItem
      { menuItemType  = NavbarSecondary
      , menuItemLabel = MsgMenuLogout
      , menuItemIcon  = Just "sign-out-alt"
      , menuItemRoute = SomeRoute $ AuthR LogoutR
      , menuItemModal = False
      , menuItemAccessCallback' = isJust <$> maybeAuthPair
      }
  , return MenuItem
      { menuItemType  = NavbarAside
      , menuItemLabel = MsgMenuTermShow
      , menuItemIcon  = Just "calendar-alt" -- SJ wrote: calendar icon, since Term will be repleaced with TimeTable in the future; arguably Term is more calendar-like than courses anyway!!!
      , menuItemRoute = SomeRoute TermShowR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , return MenuItem
      { menuItemType  = NavbarAside
      , menuItemLabel = MsgMenuCourseList
      , menuItemIcon  = Just "graduation-cap"
      , menuItemRoute = SomeRoute CourseListR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , return MenuItem
      { menuItemType  = NavbarAside
      , menuItemLabel = MsgMenuCorrections
      , menuItemIcon  = Just "check"
      , menuItemRoute = SomeRoute CorrectionsR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , return MenuItem
      { menuItemType  = NavbarAside
      , menuItemLabel = MsgMenuUsers
      , menuItemIcon  = Just "users"
      , menuItemRoute = SomeRoute UsersR
      , menuItemModal = False
      , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
      }
  , return MenuItem
      { menuItemType  = NavbarAside
      , menuItemLabel = MsgAdminHeading
      , menuItemIcon  = Just "screwdriver"
      , menuItemRoute = SomeRoute AdminR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]


pageActions :: Route UniWorX -> [MenuItem]
{-
  Icons: https://fontawesome.com/icons?d=gallery
  Guideline: use icons without boxes/frames, only non-pro

  Please keep sorted according to routes
-}
pageActions (HomeR) =
  [
    MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgInfoLecturerTitle
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute InfoLecturerR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCourseNew
      , menuItemIcon  = Just "book"
      , menuItemRoute = SomeRoute CourseNewR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuAllocationList
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute AllocationListR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (AdminR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgAdminFeaturesHeading
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute AdminFeaturesR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuMessageList
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute MessageListR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuAdminErrMsg
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute AdminErrMsgR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuAdminTest
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute AdminTestR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (UsersR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuLecturerInvite
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute AdminNewLecturerInviteR
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (AdminUserR cID) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuUserNotifications
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ UserNotificationR cID
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuUserPassword
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ UserPasswordR cID
      , menuItemModal = True
      , menuItemAccessCallback' = do
          uid <- decrypt cID
          User{userAuthentication} <- runDB $ get404 uid
          return $ is _AuthPWHash userAuthentication
      }
  ]
pageActions (InfoR) = [
    MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgInfoLecturerTitle
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute InfoLecturerR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (VersionR) = [
    MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgInfoLecturerTitle
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute InfoLecturerR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions  HealthR = [
    MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuInstance
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute InstanceR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions  InstanceR = [
    MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuHealth
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute HealthR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (HelpR) = [
    -- MenuItem
    --   { menuItemType  = PageActionPrime
    --   , menuItemLabel = MsgInfoLecturerTitle
    --   , menuItemIcon  = Nothing
    --   , menuItemRoute = SomeRoute InfoLecturerR
    --   , menuItemModal = False
    --   , menuItemAccessCallback' = return True
    --   }
  ]
pageActions (ProfileR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuProfileData
      , menuItemIcon  = Just "book"
      , menuItemRoute = SomeRoute ProfileDataR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuAuthPreds
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute AuthPredsR
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  ]
pageActions TermShowR =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuTermCreate
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute TermEditR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (TermCourseListR tid) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCourseNew
      , menuItemIcon  = Just "book"
      , menuItemRoute = SomeRoute CourseNewR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuTermEdit
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ TermEditExistR tid
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (TermSchoolCourseListR _tid _ssh) =
  [ MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuCourseNew
      , menuItemIcon  = Just "book"
      , menuItemRoute = SomeRoute CourseNewR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseListR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCourseNew
      , menuItemIcon  = Just "book"
      , menuItemRoute = SomeRoute CourseNewR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuAllocationList
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute AllocationListR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseNewR) = [
    MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgInfoLecturerTitle
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute InfoLecturerR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseR tid ssh csh CShowR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuMaterialList
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR
      , menuItemModal = False
      , menuItemAccessCallback' =
          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
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSheetList
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
      , menuItemModal = False
      , menuItemAccessCallback' =
          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
      }
  ] ++ pageActions (CourseR tid ssh csh SheetListR) ++
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuTutorialList
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialListR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuExamList
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamListR
      , menuItemModal = False
      , menuItemAccessCallback' =
          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
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuCourseApplications
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR
      , menuItemModal = False
      , menuItemAccessCallback' =
          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
      }
  , MenuItem
      { menuItemType = PageActionSecondary
      , menuItemLabel = MsgMenuCourseMembers
      , menuItemIcon  = Just "user-graduate"
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuCourseCommunication
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuCourseEdit
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuCourseClone
      , menuItemIcon  = Just "copy"
      , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)])
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuCourseDelete
      , menuItemIcon  = Just "trash"
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseR tid ssh csh CCorrectionsR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsAssign
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseR tid ssh csh SheetListR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSheetCurrent
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR
      , menuItemModal = False
      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
          void . MaybeT $ sheetCurrent tid ssh csh
          return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSheetOldUnassigned
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR
      , menuItemModal = False
      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
          void . MaybeT $ sheetOldUnassigned tid ssh csh
          return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSubmissions
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsAssign
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsOwn
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term"  , termToText $ unTermKey tid)
                                                 , ("corrections-school", original $ unSchoolKey ssh)
                                                 , ("corrections-course", original csh)
                                                 ])
      , menuItemModal = False
      , menuItemAccessCallback' = do
          muid <- maybeAuthId
          case muid of
            Nothing -> return False
            (Just uid) -> do
              [E.Value ok] <- runDB . E.select . return . E.exists . 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
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSheetNew
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseR tid ssh csh CUsersR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCourseAddMembers
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAddUserR
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseR tid ssh csh MaterialListR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuMaterialNew
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialNewR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CMaterialR tid ssh csh mnm MShowR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuMaterialEdit
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MEditR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuMaterialDelete
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MDelR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseR tid ssh csh CTutorialListR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuTutorialNew
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialNewR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CTutorialR tid ssh csh tutn TEditR) =
  [ MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuTutorialDelete
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CTutorialR tid ssh csh tutn TUsersR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuTutorialComm
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuTutorialEdit
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TEditR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuTutorialDelete
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseR tid ssh csh CExamListR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuExamNew
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamNewR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CExamR tid ssh csh examn EShowR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuExamEdit
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EEditR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuExamUsers
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CExamR tid ssh csh examn EUsersR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuExamAddMembers
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EAddUserR
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CSheetR tid ssh csh shn SShowR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSubmissionNew
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
      , menuItemModal = True
      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
          uid <- MaybeT $ liftHandlerT maybeAuthId
          submissions <- lift $ submissionList tid csh shn uid
          guard $ null submissions
          return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSubmissionOwn
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR
      , menuItemModal = False
      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
          uid <- MaybeT $ liftHandlerT maybeAuthId
          submissions <- lift $ submissionList tid csh shn uid
          guard . not $ null submissions
          return True
      }
  , MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsOwn
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term"  , termToText $ unTermKey tid)
                                                 , ("corrections-school", original $ unSchoolKey ssh)
                                                 , ("corrections-course", original csh)
                                                 , ("corrections-sheet" , original shn)
                                                 ])
      , menuItemModal = False
      , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectors
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSubmissions
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
   , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsAssign
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSheetEdit
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuSheetClone
      , menuItemIcon  = Just "copy"
      , menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuSheetDelete
      , menuItemIcon  = Just "trash"
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CSheetR tid ssh csh shn SSubsR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSubmissionNew
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectors
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
 , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsAssign
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrection
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgCorrectorAssignTitle
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuSubmissionDelete
      , menuItemIcon  = Just "trash"
      , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
  [ MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuSubmissionDelete
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CSheetR tid ssh csh shn SCorrR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuSubmissions
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsAssign
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionSecondary
      , menuItemLabel = MsgMenuSheetEdit
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CorrectionsR) =
  [ MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsDownload
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute CorrectionsDownloadR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsUpload
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute CorrectionsUploadR
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType  = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsCreate
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute CorrectionsCreateR
      , menuItemModal = False
      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
          uid <- MaybeT $ liftHandlerT 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
      }
  , MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsGrade
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute CorrectionsGradeR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CorrectionsGradeR) =
  [ MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsUpload
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute CorrectionsUploadR
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsCreate
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute CorrectionsCreateR
      , menuItemModal = False
      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
          uid <- MaybeT $ liftHandlerT 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
      }
  ]
pageActions _ = []


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

-- | only used in defaultLayout; better use siteLayout instead!
pageHeading :: Route UniWorX -> Maybe Widget
pageHeading (AuthR _)
  = Just $ i18nHeading MsgLoginHeading
pageHeading HomeR
  = Just $ i18nHeading MsgHomeHeading
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 (DataProtR)
  = Just $ i18nHeading MsgDataProtHeading
pageHeading (ImpressumR)
  = Just $ i18nHeading MsgImpressumHeading
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 (SchoolListR)
  = Just $ i18nHeading MsgSchoolListHeading
pageHeading (SchoolShowR ssh)
  = Just $ do
      School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
      i18nHeading $ MsgSchoolHeading 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
pageHeading (CSheetR _tid _ssh _csh shn SCorrR)
  = Just $ i18nHeading $ MsgCorrectorsHead shn
--          (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 (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)]
routeNormalizers =
  [ normalizeRender
  , ncSchool
  , ncCourse
  , ncSheet
  , verifySubmission
  , verifyCourseApplication
  ]
  where
    normalizeRender route = route <$ do
      YesodRequest{..} <- liftHandlerT 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 f route = maybeT (return route) $ f route
    hasChanged a b
      | ((/=) `on` original) a b = do
          $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
          tell $ Any True
      | otherwise                   = return ()
    ncSchool = maybeOrig $ \route -> do
      TermSchoolCourseListR tid ssh <- return route
      let schoolShort :: SchoolShorthand
          schoolShort = unSchoolKey ssh
      Entity ssh' _  <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
      (hasChanged `on` unSchoolKey)ssh ssh'
      return $ TermSchoolCourseListR tid ssh'
    ncCourse = maybeOrig $ \route -> do
      CourseR tid ssh csh subRoute <- return route
      Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
      hasChanged csh courseShorthand
      (hasChanged `on` unSchoolKey) ssh courseSchool
      return $ CourseR tid courseSchool courseShorthand subRoute
    ncSheet = maybeOrig $ \route -> do
      CSheetR tid ssh csh shn subRoute <- return route
      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
      Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
      hasChanged shn sheetName
      return $ CSheetR tid ssh csh sheetName subRoute
    verifySubmission = maybeOrig $ \route -> do
      CSubmissionR _tid _ssh _csh _shn cID sr <- return route
      sId <- decrypt cID
      Submission{submissionSheet}   <- lift . lift $ get404 sId
      Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 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


-- How to run database actions.
instance YesodPersist UniWorX where
    type YesodPersistBackend UniWorX = SqlBackend
    runDB action = do
      $logDebugS "YesodPersist" "runDB"
      runSqlPool action =<< appConnPool <$> getYesod
instance YesodPersistRunner UniWorX where
    getDBRunner = defaultGetDBRunner appConnPool

data CampusUserConversionException
  = CampusUserInvalidEmail
  | CampusUserInvalidDisplayName
  | CampusUserInvalidGivenName
  | CampusUserInvalidSurname
  | CampusUserInvalidTitle
  | CampusUserInvalidMatriculation
  | CampusUserInvalidFeaturesOfStudy String
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Exception CampusUserConversionException

embedRenderMessage ''UniWorX ''CampusUserConversionException id

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

  let
    userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
    userEmail'          = fold [ v | (k, v) <- ldapData, k == ldapUserEmail         ]
    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         ]

    userAuthentication
      | isPWHash  = error "PWHash should only work for users that are already known"
      | otherwise = AuthLDAP
    userLastAuthentication = now <$ guard (not isDummy)

  userEmail <- if
    | [bs] <- userEmail'
    , Right userEmail <- Text.decodeUtf8' bs
      -> return $ 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

  let
    newUser = User
      { userIdent                = mk credsIdent
      , userMaxFavourites        = userDefaultMaxFavourites
      , userTheme                = userDefaultTheme
      , userDateTimeFormat       = userDefaultDateTimeFormat
      , userDateFormat           = userDefaultDateFormat
      , userTimeFormat           = userDefaultTimeFormat
      , userDownloadFiles        = userDefaultDownloadFiles
      , userNotificationSettings = def
      , userMailLanguages        = def
      , userTokensIssuedAfter    = Nothing
      , ..
      }
    userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
                  , UserDisplayName        =. userDisplayName
                  , UserSurname            =. userSurname
                  , UserEmail              =. userEmail
                  ] ++
                  [ UserLastAuthentication =. Just now | not isDummy ]

  user@(Entity userId _) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate

  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` mk) $ do
      (k, v) <- ldapData
      guard $ k == ldapUserFieldName
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      return str

  fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures

  let
    studyTermCandidates = Set.fromList $ do
      name <- termNames
      StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
      return (key, name)
    studyTermCandidateIncidence
      = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
      . UUID.fromByteString
      . fromStrict
      . (convert :: Digest (SHAKE128 128) -> ByteString)
      . runIdentity
      $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash

  [E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate ->
    E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence

  unless candidatesRecorded $ do
    let
      studyTermCandidates' = do
        (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
        return StudyTermCandidate{..}
    insertMany_ studyTermCandidates'

  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
    void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]

  return user
  where
    insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
    isDummy  = credsPlugin == "dummy"
    isPWHash = credsPlugin == "PWHash"


instance YesodAuth UniWorX where
    type AuthId UniWorX = UserId

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

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

        setTitleI MsgLoginTitle
        $(widgetFile "login")

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

      let
        userIdent = mk credsIdent
        uAuth = UniqueAuthentication userIdent

        isDummy = credsPlugin == "dummy"
        isPWHash = credsPlugin == "PWHash"

        excRecovery res
          | isDummy || isPWHash
          = 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
              | 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 (,) <$> appLdapConf <*> appLdapPool of
        Just (ldapConf, ldapPool) -> do
          let userCreds = Creds credsPlugin (original userIdent) credsExtra
          ldapData <- campusUser ldapConf ldapPool userCreds
          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
          Authenticated . entityKey <$> upsertCampusUser ldapData userCreds
        Nothing
          -> acceptExisting

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

    authHttpManager = Yesod.getHttpManager

    onLogin = addMessageI Success Auth.NowLoggedIn

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

    renderAuthMessage _ _ = Auth.germanMessage -- TODO

instance YesodAuthPersist UniWorX

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