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

module Foundation where

import Import.NoFoundation
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet          (hamletFile)
import Text.Jasmine         (minifym)

import qualified Web.ClientSession as ClientSession

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

import Handler.Utils.Templates (siteModalId, modalParameter)

import qualified Network.Wai as W (pathInfo)

import Yesod.Default.Util   (addStaticContentExternal)
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 Data.Aeson hiding (Error, Success)

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 Crypto.Saltine.Class as Saltine


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      :: Static -- ^ Settings for static file serving.
    , appConnPool    :: ConnectionPool -- ^ Database connection pool.
    , appSmtpPool    :: Maybe SMTPPool
    , appHttpManager :: Manager
    , appLogger      :: Logger
    , appLogSettings :: TVar LogSettings
    , appCryptoIDKey :: CryptoIDKey
    , appInstanceID  :: InstanceId
    , appJobCtl      :: TVar (Map ThreadId (TMChan JobCtl))
    , appCronThread  :: TMVar (ReleaseKey, ThreadId)
    , appErrorMsgKey :: SecretBox.Key
    , appSessionKey  :: ClientSession.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)

-- Messages
mkMessage "UniWorX" "messages/uniworx" "de"
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "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 ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel

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

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


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

class RedirectUrl site url => HasRoute site url where
  urlRoute :: url -> Route site

instance HasRoute site (Route site) where
  urlRoute = id
instance (key ~ Text, val ~ Text) => HasRoute site (Route site, Map key val) where
  urlRoute = view _1
instance (key ~ Text, val ~ Text) => HasRoute site (Route site, [(key, val)]) where
  urlRoute = view _1
instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where
  urlRoute (a :#: _) = urlRoute a

data SomeRoute site = forall url. HasRoute site url => SomeRoute url

instance RedirectUrl site (SomeRoute site) where
  toTextUrl (SomeRoute url) = toTextUrl url
instance HasRoute site (SomeRoute site) where
  urlRoute (SomeRoute url) = urlRoute url

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 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 _ _        -> guard   active
      SubmissionR _ SAssignR -> guard $ marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
      _                      -> 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 "time" 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 MsgUnauthorizedParticipant)
    return Authorized
  r -> $unsupportedAuthPredicate "registered" 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 "capacity" 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 "materials" 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 "owner" 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 "rated" 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 "user-submissions" 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 "corrector-submissions" 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 "authentication" r
tagAccessPredicate AuthIsRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
tagAccessPredicate AuthIsWrite = 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
$(return [])
instance PathPiece SessionAuthTags where
  toPathPiece = $(nullaryToPathPiece ''SessionAuthTags [intercalate "-" . map toLower . splitCamel])
  fromPathPiece = finiteFromPathPiece

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 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, (Set.toList -> 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


-- 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
          errKey <- getsYesod appErrorMsgKey
          if
            | shouldEncrypt
            , not canDecrypt -> do
                nonce <- liftIO SecretBox.newNonce
                let ciphertext = SecretBox.secretbox errKey nonce . Lazy.ByteString.toStrict $ encode plaintextJson
                    encoded = decodeUtf8 . Base64.encode $ Saltine.encode nonce <> ciphertext
                    formatted = Text.intercalate "\n" $ Text.chunksOf 76 encoded
                [whamlet|
                  <p>_{MsgErrorResponseEncrypted}
                  <pre .errMsg>
                    #{formatted}
                |]
            | 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

    -- This function creates static content files in the static folder
    -- and names them based on a hash of their content. This allows
    -- expiration dates to be set far in the future without worry of
    -- users receiving stale content.
    addStaticContent ext mime content = do
        master <- getYesod
        let staticDir = appStaticDir $ appSettings master
        addStaticContentExternal
            minifym
            genFileName
            staticDir
            (StaticR . flip StaticRoute [])
            ext
            mime
            content
      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
        genFileName lbs = Text.unpack
                        . Text.decodeUtf8
                        . Base64.encode
                        . (convert :: Digest (SHAKE256 144) -> ByteString)
                        . runIdentity
                        $ sourceList (Lazy.ByteString.toChunks lbs) $$ 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 = return . appLogger


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

  isModal <- isJust <$> siteModalId

  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 -> return []
    | otherwise -> do
        applySystemMessages
        authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags
        forM_ authTagPivots $ \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left AuthPredsR)
        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")
      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 = NavbarRight
      , 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 [("site", ) . 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) <$> (isAuthorized (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
      }
  , MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuCorrections
      , menuItemIcon = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , MenuItem
      { menuItemType = PageActionPrime
      , menuItemLabel = MsgMenuSheetNew
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR
      , 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 = MsgMenuCourseNewTemplate
      , menuItemIcon  = Nothing
      , menuItemRoute = SomeRoute $ CourseNewTemplateR (Just tid) (Just ssh) (Just csh)
      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
pageActions (CourseR tid ssh csh SheetListR) =
  [ 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 = 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 = MsgMenuCorrections
      , 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
      }
  ]
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
      }
  ]
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 = True
      , menuItemAccessCallback' = runDB $ do
          uid <- liftHandlerT requireAuthId
          [E.Value corrCount] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
            E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
                 E.&&. sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
            return E.countRows
          return $ (corrCount :: 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 = True
      , menuItemAccessCallback' = runDB $ do
          uid <- liftHandlerT requireAuthId
          [E.Value corrCount] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
            E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
                 E.&&. sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
            return E.countRows
          return $ (corrCount :: 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{..}
      AppSettings{ appUserDefaults = UserDefaultConf{..},  ..} <- getsYesod appSettings

      flip catches excHandlers $ case appLdapConf of
        Just ldapConf -> fmap (either id id) . runExceptT $ do
          ldapData <- campusUser ldapConf $ 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 (appSettings -> AppSettings{..}) = catMaybes
      [ campusLogin <$> appLdapConf
      , 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 = Unsafe.fakeHandlerGetLogger appLogger


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

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