570 lines
27 KiB
Haskell
570 lines
27 KiB
Haskell
{-# 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
|