-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE UndecidableInstances #-} -- for `MemcachedKeyFavourites`
{-# OPTIONS_GHC -fprof-auto #-}

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

import Import.NoFoundation hiding (embedFile, runDB)

import Foundation.Type
import Foundation.Authorization
import Foundation.Routes
import Foundation.Navigation
import Foundation.I18n
import Foundation.Yesod.Persist
import Foundation.Instances.ButtonClass

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 Data.Text.Lazy.Builder as LTB

import qualified Database.Esqueleto.Legacy 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)

import Utils.VolatileClusterSettings


data CourseFavouriteToggleButton
  = BtnCourseFavouriteToggleManual
  | BtnCourseFavouriteToggleAutomatic
  | BtnCourseFavouriteToggleOff
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''CourseFavouriteToggleButton $ camelToPathPiece' 4

instance Button UniWorX CourseFavouriteToggleButton where
  btnLabel BtnCourseFavouriteToggleManual
    = toWidget $ iconFixed IconCourseFavouriteManual
  btnLabel BtnCourseFavouriteToggleAutomatic
    = toWidget $ iconFixed IconCourseFavouriteAutomatic
  btnLabel BtnCourseFavouriteToggleOff
    = toWidget $ iconStacked IconCourseFavouriteManual IconCourseFavouriteOff

  btnClasses _ = [BCIsButton, BCLink]

-- inspired by examAutoOccurrenceIgnoreRoomsForm
courseFavouriteToggleForm :: Maybe FavouriteReason -> Form ()
courseFavouriteToggleForm currentReason html
  = over _1 void <$> identifyForm FIDCourseFavouriteToggle (buttonForm' [btn]) html
  where
    btn :: CourseFavouriteToggleButton
    btn = case currentReason of
      Nothing -> BtnCourseFavouriteToggleOff
      (Just FavouriteVisited) -> BtnCourseFavouriteToggleAutomatic
      (Just FavouriteParticipant) -> BtnCourseFavouriteToggleAutomatic
      (Just FavouriteManual) -> BtnCourseFavouriteToggleManual
      (Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic

-- (storedReason, isBlacklist)
-- Will never return FavouriteCurrent
-- Nothing if no entry for current user (e.g. not logged in)
storedFavouriteReason :: (MonadIO m, BearerAuthSite UniWorX) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX)
                        -> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, Bool))
storedFavouriteReason tid ssh csh muid = fmap unValueFirst . 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)
      E.where_ $  course E.^. CourseTerm E.==. E.val tid
            E.&&. course E.^. CourseSchool E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
      E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
      let isBlacklist = 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
          reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool))
          reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist)
      pure reason
  where
    unValueFirst :: [(E.Value (Maybe a), E.Value Bool)] -> Maybe (Maybe a, Bool)
    -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised
    unValueFirst = fmap (bimap E.unValue E.unValue) . listToMaybe


data MemcachedKeyFavourites
  = MemcachedKeyFavouriteQuickActions (TermId, SchoolId, CourseShorthand) AuthContext (NonEmpty Lang)
  deriving (Generic)

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)
  deriving anyclass (Hashable, Binary)


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

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

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

siteLayout' :: ( BearerAuthSite UniWorX
               , YesodPersistBackend UniWorX ~ SqlBackend
               , MonadSecretBox (HandlerFor UniWorX)
               )
            => 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)

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

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

  muid <- maybeAuthPair
  -- Lookup Favourites, Breadcrumbs, Headline, & Theme if possible
  (favourites', (title, parents), nav', contentHeadline, mmsgs, maxFavouriteTerms, currentTheme, storedReasonAndToggleRoute) <- do

    (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs, storedReasonAndToggleRoute) <- runDB $ do
      favCourses'' <- withReaderT (projectBackend @SqlReadBackend) . 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

            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 E.^. CourseName
                 , course E.^. CourseTerm
                 , course E.^. CourseSchool
                 , course E.^. CourseShorthand
                 )
               , reason
               , courseVisible
               )

      favCourses' <- withReaderT (projectBackend @SqlReadBackend) . forM favCourses'' $ \((E.Value cName, E.Value tid, E.Value ssh, E.Value csh), reason, E.Value courseVisible) -> do
        mayView <- hasReadAccessTo $ CourseR tid ssh csh CShowR
        mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
        return ((cName, tid, ssh, csh), reason, courseVisible, mayView, mayEdit)

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

      breadcrumbs''
        <- 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
            in withReaderT (projectBackend @SqlReadBackend) $ breadcrumbs' mcurrentRoute

      nav'' <- withReaderT (projectBackend @SqlReadBackend) $ mconcat <$> sequence
        [ defaultLinks
        , maybe (return []) pageActions mcurrentRoute
        ]
      nav' <- withReaderT (projectBackend @SqlReadBackend) $ catMaybes <$> mapM (runMaybeT . navAccess) nav''

      -- contentHeadline :: Maybe (WidgetFor UniWorX ())
      contentHeadline <- withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ hoistMaybe overrideHeading <|> (pageHeading =<< hoistMaybe mcurrentRoute)

      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
    
      storedReasonAndToggleRoute <- case mcurrentRoute of
        (Just (CourseR tid ssh csh _)) -> (, Just . SomeRoute $ CourseR tid ssh csh CFavouriteR) <$> storedFavouriteReason tid ssh csh muid
        _otherwise -> pure (Nothing, Nothing)

      return (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs, storedReasonAndToggleRoute)

    return ( favCourses
           , breadcrumbs''
           , nav'
           , contentHeadline
           , mmsgs
           , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
           , maybe userDefaultTheme userTheme $ view _2 <$> muid
           , storedReasonAndToggleRoute
           )

  let (currentReason', maybeRoute) = storedReasonAndToggleRoute
      currentReason = case currentReason' of
        -- (reason, blacklist)
        (Just (_reason, True))      -> Nothing
        (Just (Just reason, False)) -> Just reason
        (Just (Nothing, False))     -> Just FavouriteCurrent
        Nothing                     -> Just FavouriteCurrent
      showFavToggle :: FavouriteReason -> Bool
      showFavToggle FavouriteCurrent = isJust muid
      showFavToggle _favouriteReason = False
  favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm currentReason
  let _favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) ->
        wrapForm favouriteToggleView def
          { formAction   = maybeRoute
          , formEncoding = favouriteToggleEncoding
          , formSubmit   = FormNoSubmit
          , formAttrs = [("class", "buttongroup buttongroup--inline")]
          }

  let favouriteTerms :: [TermIdentifier]
      favouriteTerms = Set.toDescList . prune $ toTermKeySet favourites'
        where
          prune ts = currentTerms `Set.union` setTakeEnd (maxFavouriteTerms - Set.size currentTerms) (ts `Set.difference` currentTerms)
          setTakeEnd n ts
            | n <= 0 = Set.empty
            | otherwise = Set.drop (Set.size ts - n) ts
          currentTerms = toTermKeySet $ filter (views (_2 . _Value) . maybe True $ is _FavouriteCurrent) favourites'
          toTermKeySet = setOf $ folded . _1 . _2 . to unTermKey
  
  favourites <- fmap catMaybes . forM favourites' $ \(c@(_, tid, ssh, csh), E.Value mFavourite, courseVisible, mayView, mayEdit)
      -> let courseRoute = CourseR tid ssh csh CShowR
             favouriteReason = fromMaybe FavouriteCurrent mFavourite
         in runMaybeT . guardOnM (unTermKey tid `elem` favouriteTerms) . lift $ do
              ctx <- getAuthContext
              MsgRenderer mr <- getMsgRenderer
              langs <- selectLanguages appLanguages <$> languages
              let cK = MemcachedKeyFavouriteQuickActions (tid, ssh, csh) ctx langs
              $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
              poolIsPressured <- dbPoolPressured
              items <- volatileBool clusterVolatileQuickActionsEnabled (return Nothing) $ if
                | poolIsPressured -> Nothing <$ observeFavouritesSkippedDueToDBLoad
                | otherwise -> memcachedLimitedKeyTimeoutBy
                    MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
                    (Right <$> appFavouritesQuickActionsCacheTTL)
                    appFavouritesQuickActionsTimeout
                    cK
                    cK
                    . observeFavouritesQuickActionsDuration . runDBRead $ do
                      $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
                      items' <- pageQuickActions NavQuickViewFavourite courseRoute
                      items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute 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 <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse (toTextUrl <=< navLinkRoute) (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> (toTextUrl <=< navLinkRoute) nc) (n ^. _navChildren)

  -- (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 navBaseRoute) nav
              highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
      highlightNav = (||) <$> navForceActive <*> (highlight . navBaseRoute)
      _favouriteTermReason :: TermIdentifier -> FavouriteReason -> [((CourseName, TermId, SchoolId, CourseShorthand), Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
      _favouriteTermReason tid favReason' = favourites
        & filter (\((_, tid', _, _), _, _, favReason, _, _, _) -> unTermKey tid' == tid && favReason == favReason')
        & sortOn (\((cName, _, _, _), _, _, _, _, _, _) -> cName)
      _anyFavToggle = flip any ((,) <$> universeF <*> favouriteTerms) $ \(reason, term) ->
        showFavToggle reason && not (null $ _favouriteTermReason term reason)

      -- 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 -> do
              modalContent <- liftHandler $ Left <$> navLinkRoute navLink
              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
                }
          | NavTypeLink{} <- navType
            -> let route = navRoute'
                   ident = navIdent
                in $(widgetFile "widgets/navbar/item")
        NavPageActionPrimary{ navLink = navLink@NavLink{..} }
          -> let pWidget
                   | NavTypeLink{..} <- navType
                   , navModal = do
                       modalContent <- liftHandler $ Left <$> navLinkRoute navLink
                       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
                         }
                   | 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 -> do
              modalContent <- liftHandler $ Left <$> navLinkRoute navLink
              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
                }
          | 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 "Treatment of this kind of Nav is 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 -> do
              modalContent <- liftHandler $ Left <$> navLinkRoute iN
              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
                }
          | NavTypeLink{} <- navType
            -> let route = iNavRoute
                   ident = iNavIdent
                in $(widgetFile "widgets/navbar/navbar-container-item--link")
          | NavTypeButton{..} <- navType -> do
              csrfToken <- reqToken <$> getRequest
              formAction <- liftHandler $ Just <$> navLinkRoute iN
              wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def
                { formMethod = navMethod
                , formSubmit = FormNoSubmit
                , formAction
                }
        _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
              logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/fraport_logo_text.svg")
      footer :: WidgetFor UniWorX ()
      footer = $(widgetFile "widgets/footer/footer")
        where isNavFooter = has $ _1 . _NavFooter
      alerts :: WidgetFor UniWorX ()
      alerts = $(widgetFile "widgets/alerts/alerts")
      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

      whenM doFormHoneypots $ do
        honeypotSecrets' <- liftHandler $ sortOn (view _2) . ifoldMap (\isHoneypot -> map (isHoneypot, ) . otoList) <$> honeypotSecrets
        forM_ honeypotSecrets' $ \(isHoneypot, hpSecret) -> toWidget $ if
          | isHoneypot -> CssBuilder . LTB.fromLazyText $ "[data-uw-field-display=\"" <> fromStrict hpSecret <> "\"]{display:none!important}"
          | otherwise  -> CssBuilder . LTB.fromLazyText $ "[data-uw-field-display=\"" <> fromStrict hpSecret <> "\"]{/*display:none!important*/}"

      $(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 :: forall m.
                       ( MonadHandler m, HandlerSite m ~ UniWorX
                       , YesodPersistBackend UniWorX ~ SqlBackend
                       , BearerAuthSite UniWorX
                       , WithRunDB SqlBackend (HandlerFor UniWorX) m
                       , MonadCatch m
                       ) => m ()
applySystemMessages = maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
  lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden

  cRoute <- getCurrentRoute
  guard $ cRoute /= Just NewsR

  lift . useRunDB . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
  where
    syncSystemMessageHidden :: UserId -> m ()
    syncSystemMessageHidden uid = do
      smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: m (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
      iforM_ smSt $ \cID UserSystemMessageState{..} -> useRunDB $ 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 SqlBackend (HandlerFor UniWorX) ()
    applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
      guard $ not systemMessageNewsOnly

      cID <- lift $ encrypt smId
      guardM . lift . hasReadAccessTo $ MessageR cID

      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 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 $ toHtml 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 :: ( YesodPersistBackend UniWorX ~ SqlBackend
               , WithRunDB SqlReadBackend (HandlerFor UniWorX) m
               , MonadHandler m
               ) => Route UniWorX -> MaybeT m Widget
pageHeading (AuthR _)
  = return $ i18n MsgLoginHeading
pageHeading NewsR
  = return $ i18n MsgNewsHeading
pageHeading UsersR
  = return $ i18n MsgUsers
pageHeading (AdminUserR _)
  = return $ i18n MsgAdminUserHeading
pageHeading AdminTestR
  = return [whamlet|Internal Code Demonstration Page|]
pageHeading AdminErrMsgR
  = return $ i18n MsgErrMsgHeading

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

pageHeading HelpR
  = return $ i18n MsgHeadingHelpRequest

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

pageHeading TermShowR
  = pure $ i18n MsgHeadingTermsHeading
pageHeading TermCurrentR
  = return $ i18n MsgHeadingTermCurrent
pageHeading TermEditR
  = pure $ i18n MsgHeadingTermEditHeading
pageHeading (TermEditExistR tid)
  = return $ i18n $ MsgHeadingTermEditTid tid
pageHeading (TermCourseListR tid)
  = return . i18n . MsgTermCourseListHeading $ tid
pageHeading (TermSchoolCourseListR tid ssh) = do
  School{schoolName=school} <- MaybeT . useRunDB $ get ssh
  return . i18n $ MsgTermSchoolCourseListHeading tid school

pageHeading CourseListR
  = return $ i18n MsgCourseListTitle
pageHeading CourseNewR
  = return $ i18n MsgCourseNewHeading
pageHeading (CourseR tid ssh csh CShowR) = do
  Entity _ Course{..} <- MaybeT . useRunDB . getBy $ TermSchoolCourseShort tid ssh csh
  return $ toWidget courseName
--          (CourseR tid csh CRegisterR) -- just for POST
pageHeading (CourseR tid ssh csh CEditR)
  = return $ i18n $ MsgCourseEditHeading tid ssh csh
pageHeading (CourseR tid ssh csh CCorrectionsR)
  = return $ i18n $ MsgSubmissionsCourse tid ssh csh
pageHeading (CourseR tid ssh csh SheetListR)
  = return $ i18n $ MsgSheetList tid ssh csh
pageHeading (CourseR tid ssh csh SheetNewR)
  = return $ i18n $ MsgSheetNewHeading tid ssh csh
pageHeading (CSheetR tid ssh csh shn SShowR)
  = return $ i18n $ MsgSheetTitle tid ssh csh shn
  -- = return $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
pageHeading (CSheetR tid ssh csh shn SEditR)
  = return $ i18n $ MsgSheetEditHead tid ssh csh shn
pageHeading (CSheetR tid ssh csh shn SDelR)
  = return $ i18n $ MsgSheetDelHead tid ssh csh shn
pageHeading (CSheetR _tid _ssh _csh shn SSubsR)
  = return $ i18n $ MsgSubmissionsSheet shn
pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
  = return $ i18n $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
  = return $ i18n $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
  = return $ i18n $ MsgSubmissionEditHead tid ssh csh shn
--          (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
  = return $ 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
  = return $ i18n MsgCorrectionsTitle
pageHeading CorrectionsUploadR
  = return $ i18n MsgCorrUpload
pageHeading CorrectionsCreateR
  = return $ i18n MsgCorrCreate
pageHeading CorrectionsGradeR
  = return $ i18n MsgCorrGrade
pageHeading (MessageR _)
  = return $ i18n MsgSystemMessageHeading
pageHeading MessageListR
  = return $ i18n MsgSystemMessageListHeading

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