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

module Foundation where

import Import.NoFoundation
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 (CI)
import qualified Data.CaseInsensitive as CI

import qualified Data.CryptoID as E

import Data.ByteArray (convert)
import Crypto.Hash (Digest, SHAKE256)
import Crypto.Hash.Conduit (sinkHash)

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

import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as Lazy.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 Data.Monoid (Any(..))

import Data.Pool

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

import qualified Database.Esqueleto as E

import Control.Monad.Except (MonadError(..), runExceptT)
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 (MemoT, startEvalMemoT, MonadMemo(..))
import qualified Control.Monad.Catch as C

import Handler.Utils.StudyFeatures
import Handler.Utils.Templates
import Utils.Lens
import Utils.Form
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 Database.Memcached.Binary.IO as Memcached
import Data.Bits (Bits(zeroBits))


instance DisplayAble b => DisplayAble (E.CryptoID a b) where
  display = display . ciphertext

instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => DisplayAble (E.CryptoID namespace (CI FilePath)) where
  display = toPathPiece

instance DisplayAble TermId where
  display = termToText . unTermKey

instance DisplayAble SchoolId where
  display = CI.original . unSchoolKey

-- 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
    , appHttpManager     :: Manager
    , appLogger          :: (ReleaseKey, TVar Logger)
    , appLogSettings     :: TVar LogSettings
    , appCryptoIDKey     :: CryptoIDKey
    , appInstanceID      :: InstanceId
    , appJobCtl          :: TVar (Map ThreadId (TMChan JobCtl))
    , appCronThread      :: TMVar (ReleaseKey, ThreadId)
    , appSessionKey      :: ClientSession.Key
    , appSecretBoxKey    :: SecretBox.Key
    }

type SMTPPool = Pool SMTPConnection

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

-- | Convenient Type Synonyms:
type DB a = YesodDB UniWorX a
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 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)


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

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

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

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 (Route UniWorX)) where
  renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)

embedRenderMessage ''UniWorX ''MessageClass ("Message" <>)
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''StudyFieldType id
embedRenderMessage ''UniWorX ''SheetFileType 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 ''SheetSubmissionMode ("Sheet" <>)
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id

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

instance RenderMessage UniWorX UploadMode where
  renderMessage foundation ls uploadMode = case uploadMode of
    NoUpload     -> mr MsgUploadModeNone
    Upload False -> mr MsgUploadModeNoUnpack
    Upload True  -> mr MsgUploadModeUnpack
    where
      mr = renderMessage foundation ls

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

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)

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
  }

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

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

$(return [])


data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance Button UniWorX SubmitButton where
  label BtnSubmit = [whamlet|_{MsgBtnSubmit}|]

  cssClass BtnSubmit = 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


-- Access Control
data AccessPredicate
  = APPure     (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
  | APHandler  (Route UniWorX -> Bool -> Handler AuthResult)
  | APDB       (Route UniWorX -> Bool -> DB AuthResult)

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

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

instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
  evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of
    (APPure    p) -> lift $ runReader (p r w) <$> getMsgRenderer
    (APHandler p) -> lift $ p r w
    (APDB      p) -> p 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

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

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


tagAccessPredicate :: AuthTag -> AccessPredicate
tagAccessPredicate AuthFree = trueAP
tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
  -- Courses: access only to school admins
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
    [E.Value c] <- lift . E.select . 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
      return (E.countRows :: E.SqlExpr (E.Value Int64))
    guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
    return Authorized
  -- other routes: access to any admin is granted here
  _other -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
    adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
    guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
    return Authorized
tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
  AdminHijackUserR cID -> exceptT return return $ do
    myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
    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 <- appAllowDeprecated . appSettings <$> getYesod
  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 $ \route _ -> case route of
  CourseR tid ssh csh _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
     [E.Value c] <- lift . E.select . 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
       return (E.countRows :: E.SqlExpr (E.Value Int64))
     guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
     return Authorized
  _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
     return Authorized
tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
  authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
  resList <- 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 _ -> 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 _ -> 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 _ -> 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 AuthTime = APDB $ \route _ -> case route of
  CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
    Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _sid Sheet{..} <- 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
      SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
      SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
      SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
      SubmissionNewR         -> guard   active
      SubmissionR _ SAssignR -> 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 CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
    Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    cTime <- (NTop . Just) <$> liftIO getCurrentTime
    guard $ NTop courseRegisterFrom <= cTime
         && NTop courseRegisterTo   >= cTime
    return Authorized

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

  r -> $unsupportedAuthPredicate AuthTime r
tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
    [E.Value c] <- lift . E.select . 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
      return (E.countRows :: E.SqlExpr (E.Value Int64))
    guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthRegistered r
tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of
  CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
    let authorizedIfExists f = do
          [E.Value ok] <- lift . E.select . return . E.exists $ E.from f
          whenExceptT ok Authorized
    participant <- decrypt cID
    -- participant is currently registered
    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
    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
    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
    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
    authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
      E.on $ tutorial  E.^. TutorialId   E.==. tutorialUser E.^. TutorialUserTutorial
      E.on $ course E.^. CourseId  E.==. tutorial E.^. TutorialCourse
      E.where_ $ tutorialUser E.^. TutorialUserUser 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
    authorizedIfExists $ \(course `E.InnerJoin` tutorial) -> do
      E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
      E.where_ $ tutorial E.^. TutorialTutor 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
    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
    unauthorizedI MsgUnauthorizedParticipant
  r -> $unsupportedAuthPredicate AuthParticipant r
tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
    Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
    guard $ NTop courseCapacity > NTop (Just registered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthCapacity 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 <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ]
    assertM_ ((<= 0) :: Int -> Bool) . lift . fmap (E.unValue . unsafeHead) $ E.select . 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 E.countRows
    return Authorized
  r -> $unsupportedAuthPredicate AuthEmpty r
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
    Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    guard courseMaterialFree
    return Authorized
  r -> $unsupportedAuthPredicate AuthMaterials r
tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
  CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
    sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
    void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
    return Authorized
  r -> $unsupportedAuthPredicate AuthOwner r
tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
  CSubmissionR _ _ _ _ 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 _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
    Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
    guard $ sheetSubmissionMode == UserSubmissions
    return Authorized
  r -> $unsupportedAuthPredicate AuthUserSubmissions r
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
  CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
    Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
    guard $ sheetSubmissionMode == CorrectorSubmissions
    return Authorized
  r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
  MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
    smId <- decrypt cID
    SystemMessage{..} <- MaybeT $ get smId
    isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
    guard $ not systemMessageAuthenticatedOnly || isAuthenticated
    return Authorized
  r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)


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

type DNF a = Set (NonNull (Set a))

data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe SessionAuthTags
instance Finite SessionAuthTags
nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)

routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
-- ^ DNF up to entailment:
--
-- > (A_1 && A_2 && ...) OR' B OR' ...
--
-- > A OR' B := ((A |- B) ==> A) && (A || B)
routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs
  where
    partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
    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 -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
-- ^ `tell`s disabled predicates, identified as pivots
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite
  = startEvalMemoT $ do
      mr <- lift getMsgRenderer
      let
        authTagIsInactive = not . authTagIsActive

        evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
        evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite

        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 :: [[AuthTag]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
        evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)

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

      result <- evalDNF $ filter (all authTagIsActive) authDNF

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

      return result

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

evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessDB = evalAccess

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 appRoot $ appSettings app 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 UniWorX{appSessionKey,appSettings=AppSettings{appSessionTimeout}} = do
      (getCachedDate, _) <- clientSessionDateCacher appSessionTimeout
      return . Just $ clientSessionBackend appSessionKey getCachedDate

    maximumContentLength _ _ = Just $ 50 * 2^20

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

    -- 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 <- getsYesod $ appEncryptErrors . appSettings
          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 (Just . toHtml . 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

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


siteLayout :: Maybe Html -- ^ Optionally override `pageHeading`
           -> Widget -> Handler Html
siteLayout headingOverride widget = do
  master <- getYesod
  let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master

  isModal <- hasCustomHeader HeaderIsModal

  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 <$> getSessionJson SessionInactiveAuthTags
        forM_ authTagPivots $
          \authTag -> addMessageWidget Info $ modal [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 snd3 favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes
                      highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 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.

      navbar :: Widget
      navbar = $(widgetFile "widgets/navbar")
      asidenav :: Widget
      asidenav = $(widgetFile "widgets/asidenav")
      footer :: Widget
      footer = $(widgetFile "widgets/footer")
      contentHeadline :: Maybe Widget
      contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute)
      breadcrumbsWgt :: Widget
      breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs")
      pageactionprime :: Widget
      pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now
      -- functions to determine if there are page-actions (primary or secondary)
      isPageAction :: MenuType -> Bool
      isPageAction PageActionPrime     = True
      isPageAction PageActionSecondary = True
      isPageAction _                   = False
      hasPageActions :: Bool
      hasPageActions = any (isPageAction . menuItemType . view _1) menuTypes

  pc <- widgetToPageContent $ do
      addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600"
      addScript $ StaticR js_zepto_js
      addScript $ StaticR js_fetchPolyfill_js
      addScript $ StaticR js_urlPolyfill_js
      addScript $ StaticR js_featureChecker_js
      addScript $ StaticR js_flatpickr_js
      addScript $ StaticR js_tabber_js
      addStylesheet $ StaticR css_flatpickr_css
      addStylesheet $ StaticR css_tabber_css
      addStylesheet $ StaticR css_fonts_css
      addStylesheet $ StaticR css_fontawesome_css
      $(widgetFile "default-layout")
      $(widgetFile "standalone/modal")
      $(widgetFile "standalone/showHide")
      $(widgetFile "standalone/inputs")
      $(widgetFile "standalone/tooltip")
      $(widgetFile "standalone/tabber")
      $(widgetFile "standalone/alerts")
      $(widgetFile "standalone/datepicker")
  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

      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 -> do
          html <- withUrlRenderer [hamlet|
              <a href=@{MessageR cID}>
                #{s}
            |]
          addMessage systemMessageSeverity html
        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 HomeR)
  breadcrumb AdminTestR       = return ("Test"    , Just HomeR)
  breadcrumb (AdminUserR _)   = return ("Users"   , Just UsersR)
  breadcrumb VersionR         = return ("Impressum"    , Just HomeR)

  breadcrumb ProfileR         = return ("Profile" , Just HomeR)
  breadcrumb ProfileDataR     = return ("Data"    , 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, Nothing)

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

  breadcrumb  CourseListR                 = return ("Kurse"    , Just HomeR)
  breadcrumb  CourseNewR                  = return ("Neu"      , Just CourseListR)
  breadcrumb (CourseR tid ssh csh CShowR) = return (CI.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 CCorrectionsR) = return ("Abgaben",Just $ CourseR tid ssh csh CShowR)
  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 (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
  breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit",    Just $ CSheetR tid ssh csh shn SShowR)
  breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE",  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 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
  -- 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 HomeR)
  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 = MsgMenuVersion
      , menuItemIcon  = Just "book"
      , menuItemRoute = SomeRoute VersionR
      , 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 = MsgMenuCourseList
      , menuItemIcon = Just "calendar-alt"
      , menuItemRoute = SomeRoute CourseListR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , return MenuItem
      { menuItemType = NavbarAside
      , menuItemLabel = MsgMenuTermShow
      , menuItemIcon = Just "graduation-cap"
      , menuItemRoute = SomeRoute TermShowR
      , 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
      }
  ]


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) =
  [
--     NavbarAside $ MenuItem
--       { menuItemLabel = "Benutzer"
--       , menuItemIcon = Just "users"
--       , menuItemRoute = UsersR
--       , menuItemAccessCallback' = return True
--       }
--   ,
    MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuAdminTest
      , menuItemIcon  = Just "screwdriver"
      , menuItemRoute = SomeRoute AdminTestR
      , 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
      }
  ]
pageActions (ProfileR) =
  [ MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuProfileData
      , menuItemIcon  = Just "book"
      , menuItemRoute = SomeRoute ProfileDataR
      , menuItemModal = False
      , 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 (CourseListR) =
  [ MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuCourseNew
      , menuItemIcon  = Just "book"
      , menuItemRoute = SomeRoute CourseNewR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseR tid ssh csh CShowR) =
  [ MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuSheetList
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
      , menuItemModal = False
      , menuItemAccessCallback' = do --TODO always show for lecturer
          let sheetRouteAccess shn = (== Authorized) <$> evalAccess (CSheetR tid ssh csh shn SShowR) False
          muid <- maybeAuthId
          (sheets,lecturer) <- runDB $ do
            cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
            sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
            lecturer <- case muid of
                Nothing    -> return False
                (Just uid) -> existsBy $ UniqueLecturer uid cid
            return (sheets,lecturer)
          or2M (return lecturer) $ anyM sheets sheetRouteAccess
      }
  ] ++ pageActions (CourseR tid ssh csh SheetListR) ++
  [ MenuItem
      { menuItemType = PageActionSecondary
      , menuItemLabel = MsgMenuCourseEdit
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType = PageActionSecondary
      , menuItemLabel = MsgMenuCourseNewTemplate
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)])
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType = PageActionSecondary
      , menuItemLabel = MsgMenuCourseDelete
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR
      , 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' = do
          now <- liftIO getCurrentTime
          sheets <- runDB . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
            E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
            E.where_ $ sheet E.^. SheetActiveTo   E.>.  E.val now
                 E.&&.  sheet E.^. SheetActiveFrom E.<=. E.val now
                 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.orderBy [E.asc $ sheet E.^. SheetActiveTo]
            E.limit 1
            return $ sheet E.^. SheetName
          case sheets of
            (E.Value shn):_ -> (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False
            _ -> return False
      }
  , MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuSheetLastInactive
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetLastInactiveR
      , menuItemModal = False
      , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
      }
  , MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuSubmissions
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuCorrectionsOwn
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term"  , termToText $ unTermKey tid)
                                                 , ("corrections-school", CI.original $ unSchoolKey ssh)
                                                 , ("corrections-course", CI.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 (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 = MsgMenuCorrectionsOwn
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term"  , termToText $ unTermKey tid)
                                                 , ("corrections-school", CI.original $ unSchoolKey ssh)
                                                 , ("corrections-course", CI.original csh)
                                                 , ("corrections-sheet" , CI.original shn)
                                                 ])
      , menuItemModal = False
      , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
      }
  , 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 = 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 = MsgMenuSheetEdit
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType = PageActionSecondary
      , menuItemLabel = MsgMenuSheetDelete
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CSheetR tid ssh csh shn SSubsR) =
  [ MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuCorrectors
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
      , 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 SAssignR
      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType = PageActionSecondary
      , menuItemLabel = MsgMenuSubmissionDelete
      , menuItemIcon  = Nothing
      , 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 = MsgMenuCorrections
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
      , 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 = 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
          [E.Value sheetCount] <- 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_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
                 E.&&. ( isCorrector' E.||. isLecturer )
            return E.countRows
          return $ (sheetCount :: Int) /= 0
      }
  , 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
          [E.Value sheetCount] <- 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_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
                 E.&&. ( isCorrector' E.||. isLecturer )
            return E.countRows
          return $ (sheetCount :: Int) /= 0
      }
  ]
pageActions _ = []


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

pageHeading :: Route UniWorX -> Maybe Widget
pageHeading (AuthR _)
  = Just $ i18nHeading MsgLoginHeading
pageHeading HomeR
  = Just $ i18nHeading MsgHomeHeading
pageHeading UsersR
  = Just $ i18nHeading MsgUsers
pageHeading (AdminTestR)
  = Just $ [whamlet|Internal Code Demonstration Page|]
pageHeading (AdminUserR _)
  = Just $ [whamlet|User Display for Admin|]
pageHeading (AdminErrMsgR)
  = Just $ i18nHeading MsgErrMsgHeading
pageHeading (VersionR)
  = Just $ i18nHeading MsgImpressumHeading
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
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
  ]
  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` CI.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


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

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
      let
        userIdent = CI.mk credsIdent
        uAuth = UniqueAuthentication userIdent

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

        excHandlers
          | isDummy || isPWHash
          = [ C.Handler $ \err -> do
                addMessage Error (toHtml $ tshow (err :: CampusUserException))
                $logErrorS "LDAP" $ tshow err
                acceptExisting
            ]
          | otherwise
          = [ C.Handler $ \case
                CampusUserNoResult -> do
                  $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
                  return . UserError $ IdentifierNotFound credsIdent
                CampusUserAmbiguous -> do
                  $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
                  return . UserError $ IdentifierNotFound credsIdent
                err -> do
                  $logErrorS "LDAP" $ tshow err
                  return $ ServerError "LDAP lookup failed"
            ]

        acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth

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

      flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
        Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
          ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (CI.original userIdent) credsExtra
          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData

          let
            userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
            userEmail' = lookup (Attr "mail") ldapData
            userDisplayName' = lookup (Attr "displayName") ldapData
            userSurname' = lookup (Attr "sn") ldapData

            userAuthentication
              | isPWHash  = error "PWHash should only work for users that are already known"
              | otherwise = AuthLDAP

          userEmail <- if
            | Just [bs] <- userEmail'
            , Right userEmail <- Text.decodeUtf8' bs
              -> return $ CI.mk userEmail
            | otherwise
              -> throwError $ ServerError "Could not retrieve user email"
          userDisplayName <- if
            | Just [bs] <- userDisplayName'
            , Right userDisplayName <- Text.decodeUtf8' bs
              -> return userDisplayName
            | otherwise
              -> throwError $ ServerError "Could not retrieve user name"
          userSurname <- if
            | Just [bs] <- userSurname'
            , Right userSurname <- Text.decodeUtf8' bs
              -> return userSurname
            | otherwise
              -> throwError $ ServerError "Could not retrieve user surname"
          userMatrikelnummer <- if
            | Just [bs] <- userMatrikelnummer'
            , Right userMatrikelnummer <- Text.decodeUtf8' bs
              -> return $ Just userMatrikelnummer
            | Nothing <- userMatrikelnummer'
              -> return Nothing
            | otherwise
              -> throwError $ ServerError "Could not decode user matriculation"

          let
            newUser = User
              { userMaxFavourites        = userDefaultMaxFavourites
              , userTheme                = userDefaultTheme
              , userDateTimeFormat       = userDefaultDateTimeFormat
              , userDateFormat           = userDefaultDateFormat
              , userTimeFormat           = userDefaultTimeFormat
              , userDownloadFiles        = userDefaultDownloadFiles
              , userNotificationSettings = def
              , userMailLanguages        = def
              , ..
              }
            userUpdate =  [ UserMatrikelnummer =. userMatrikelnummer
                          , UserDisplayName    =. userDisplayName
                          , UserSurname        =. userSurname
                          , UserEmail          =. userEmail
                          ]

          userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate

          let
            userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
            userStudyFeatures' = do
              (k, v) <- ldapData
              guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
              v' <- v
              Right str <- return $ Text.decodeUtf8' v'
              return str

          fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures

          lift $ deleteWhere [StudyFeaturesUser ==. userId]

          forM_ fs $ \StudyFeatures{..} -> do
            lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
            lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing

          lift $ insertMany_ fs
          return $ Authenticated userId
        Nothing -> acceptExisting

      where
        insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())

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

    authHttpManager = getHttpManager

    renderAuthMessage _ _ = Auth.germanMessage -- TODO

instance YesodAuthPersist UniWorX

-- Useful when writing code that is re-usable outside of the Handler context.
-- An example is background jobs that send email.
-- This can also be useful for writing code that works across multiple Yesod applications.
instance HasHttpManager UniWorX where
    getHttpManager = appHttpManager

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 $ appMailFrom . appSettings
  mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
  mailVerp = getsYesod $ appMailVerp . appSettings
  mailDateTZ = return appTZ
  mailSmtp act = do
    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
    withResource pool act
  mailT ctx mail = defMailT ctx $ do
    void setMailObjectId
    setDateCurrent
    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"

    ret <- mail

    setMailSmtpData
    return ret


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