{-# LANGUAGE UndecidableInstances #-} -- for `MemcachedKeyFavourites`

module Foundation.SiteLayout
  ( siteLayout', siteLayout
  , siteLayoutMsg', siteLayoutMsg
  , getSystemMessageState
  ) where

import Import.NoFoundation hiding (embedFile)

import Foundation.Type
import Foundation.Authorization
import Foundation.Routes
import Foundation.Navigation
import Foundation.I18n
import Foundation.DB

import Utils.SystemMessage
import Utils.Form
import Utils.Course
import Utils.Metrics

import Handler.Utils.Routes
import Handler.Utils.Memcached

import qualified Data.Text as Text
import qualified Data.Set as Set
import qualified Data.HashMap.Strict as HashMap

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

import qualified Data.Conduit.Combinators as C

import Text.Cassius (cassiusFile)
import Text.Hamlet (hamletFile)
import Data.FileEmbed (embedFile)


data MemcachedKeyFavourites
  = MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
  deriving (Generic, Typeable)

deriving instance Eq AuthContext => Eq MemcachedKeyFavourites
deriving instance Read AuthContext => Read MemcachedKeyFavourites
deriving instance Show AuthContext => Show MemcachedKeyFavourites
deriving instance Hashable AuthContext => Hashable MemcachedKeyFavourites
deriving instance Binary AuthContext => Binary MemcachedKeyFavourites

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


siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
siteLayoutMsg = siteLayout . i18n

{-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-}
siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
siteLayoutMsg' = siteLayoutMsg

siteLayout :: ( BearerAuthSite UniWorX
              , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
              , Button UniWorX ButtonSubmit
              )
           => WidgetFor UniWorX () -- ^ `pageHeading`
           -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
siteLayout = siteLayout' . Just

siteLayout' :: ( BearerAuthSite UniWorX
               , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
               , Button UniWorX ButtonSubmit
               )
            => Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading`
            -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
siteLayout' overrideHeading widget = do
  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings

  isModal <- hasCustomHeader HeaderIsModal

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

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

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

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

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

  isAuth <- isJust <$> maybeAuthId
  
  now <- liftIO getCurrentTime

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

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

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

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

        E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent

        return (course, reason, courseVisible)

      favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do
        mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR
        mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
        return (course, reason, courseVisible, mayView, mayEdit)

      let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BearerAuthSite UniWorX) => m ()
applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
  lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden

  cRoute <- lift getCurrentRoute
  guard $ cRoute /= Just NewsR

  lift . runDBRead . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
  where
    syncSystemMessageHidden :: UserId -> HandlerFor UniWorX ()
    syncSystemMessageHidden uid = runDB . withReaderT projectBackend $ do
      smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: SqlPersistT (HandlerFor UniWorX) (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
      iforM_ smSt $ \cID UserSystemMessageState{..} -> do
        smId <- decrypt cID
        whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $
          upsert SystemMessageHidden
            { systemMessageHiddenMessage = smId
            , systemMessageHiddenUser = uid
            , systemMessageHiddenTime
            }
            [ SystemMessageHiddenTime =. systemMessageHiddenTime ]

        when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do
          deleteBy $ UniqueSystemMessageHidden uid smId

        modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
          -> fmap MergeHashMap . assertM' (/= mempty) $
               HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm

    applyMessage :: Entity SystemMessage -> ReaderT SqlReadBackend (HandlerFor UniWorX) ()
    applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
      guard $ not systemMessageNewsOnly

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

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

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

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

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


-- FIXME: Move headings into their respective handlers
  
-- | Method for specifying page heading for handlers that call defaultLayout
--
-- All handlers whose code is under our control should use
-- `siteLayout` instead; `pageHeading` is only a fallback solution for
-- e.g. subsites like `AuthR`
pageHeading :: ( YesodPersist UniWorX
               , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
               ) => Route UniWorX -> Maybe Widget
pageHeading (AuthR _)
  = Just $ i18n MsgLoginHeading
pageHeading NewsR
  = Just $ i18n MsgNewsHeading
pageHeading UsersR
  = Just $ i18n MsgUsers
pageHeading (AdminUserR _)
  = Just $ i18n MsgAdminUserHeading
pageHeading AdminTestR
  = Just [whamlet|Internal Code Demonstration Page|]
pageHeading AdminErrMsgR
  = Just $ i18n MsgErrMsgHeading

pageHeading InfoR
  = Just $ i18n MsgInfoHeading
pageHeading LegalR
  = Just $ i18n MsgLegalHeading
pageHeading VersionR
  = Just $ i18n MsgVersionHeading

pageHeading HelpR
  = Just $ i18n MsgHelpRequest

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

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

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

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

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