700 lines
34 KiB
Haskell
700 lines
34 KiB
Haskell
-- 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
|