From 0d399247773a0e4799602c49e6c06de906b43fec Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 9 Apr 2020 11:56:29 +0200 Subject: [PATCH] feat(news): show system messages --- frontend/src/app.sass | 24 +++++++++++++++++ messages/uniworx/de-de-formal.msg | 1 + messages/uniworx/en-eu.msg | 1 + models/system-messages.model | 1 + src/Foundation.hs | 2 ++ src/Handler/News.hs | 22 ++++++++++++++++ src/Handler/SystemMessage.hs | 38 +++++++++++++-------------- src/Utils/SystemMessage.hs | 12 +++++++++ templates/news/system-messages.hamlet | 9 +++++++ test/Database/Fill.hs | 9 ++++--- 10 files changed, 95 insertions(+), 24 deletions(-) create mode 100644 templates/news/system-messages.hamlet diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 265d516b2..220f09d1c 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1265,3 +1265,27 @@ a.breadcrumbs__home &__label grid-area: label + +.news__system-messages + overflow-y: auto + max-height: 75vh + +.news__system-message + border-left: 3px solid var(--color-info) + padding-left: 17px + background-color: rgba(0,0,0,0.015) + + & + .news__system-message + margin-top: 17px + + &--info + border-left-color: var(--color-info) + + &--error + border-left-color: var(--color-error) + + &--warning + border-left-color: var(--color-warning) + + &--success + border-left-color: var(--color-success) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 6bd109c2c..8f0a55fa7 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1064,6 +1064,7 @@ HelpSent: Ihre Supportanfrage wurde weitergeleitet. InfoLecturerTitle: Hinweise für Veranstalter +SystemMessageNewsOnly: Nur auf "Aktuelles" SystemMessageFrom: Sichtbar ab SystemMessageTo: Sichtbar bis SystemMessageAuthenticatedOnly: Nur angemeldet diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index ccef9a61e..2d107c14b 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1063,6 +1063,7 @@ HelpSent: Your support request has been sent. InfoLecturerTitle: Information for lecturers +SystemMessageNewsOnly: Only on "News" SystemMessageFrom: Visible from SystemMessageTo: Visible to SystemMessageAuthenticatedOnly: Only logged in users diff --git a/models/system-messages.model b/models/system-messages.model index f2692ab64..7722e9b85 100644 --- a/models/system-messages.model +++ b/models/system-messages.model @@ -1,6 +1,7 @@ -- Messages shown to all users as soon as they visit the site/log in (i.e.: "System is going down for maintenance next sunday") -- Only administrators (of any school) should be able to create these via a web-interface SystemMessage + newsOnly Bool default=False from UTCTime Maybe -- Message is not shown before this date has passed (never shown, if null) to UTCTime Maybe -- Message is shown until this date has passed (shown forever, if null) authenticatedOnly Bool -- Show message to all users upon visiting the site or only upon login? diff --git a/src/Foundation.hs b/src/Foundation.hs index cba51a599..350076572 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1936,6 +1936,8 @@ applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage where applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do + guard $ not systemMessageNewsOnly + cID <- encrypt smId void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 9ae8ec113..19f579046 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -9,12 +9,18 @@ import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E +import qualified Data.Conduit.List as C (consume, mapMaybeM) +import qualified Data.Conduit.Combinators as C + + getNewsR :: Handler Html getNewsR = do muid <- maybeAuthId defaultLayout $ do setTitleI MsgNewsHeading + newsSystemMessages + when (is _Nothing muid) $ notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch") @@ -26,6 +32,22 @@ getNewsR = do $(i18nWidgetFile "unauth-news") +newsSystemMessages :: Widget +newsSystemMessages = do + now <- liftIO getCurrentTime + + messages' <- liftHandler . runDB . runConduit $ + selectKeys [] [] + .| C.filterM (hasReadAccessTo . MessageR <=< encrypt) + .| C.mapMaybeM (\smId -> fmap (view _1 &&& systemMessageToTranslation smId) <$> getSystemMessage appLanguages smId) + .| C.filter (\(SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo) + .| C.consume + let messages = sortOn (\(SystemMessage{..}, _) -> (NTop systemMessageFrom, systemMessageSeverity)) messages' + + unless (null messages) + $(widgetFile "news/system-messages") + + newsUpcomingSheets :: UserId -> Widget newsUpcomingSheets uid = do cTime <- liftIO getCurrentTime diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 28a9b94e9..c82faa5b0 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -28,13 +28,14 @@ postMessageR cID = do mkForm = do ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard $ SystemMessage - <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom) - <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo) - <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly) + <$> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just systemMessageNewsOnly) + <*> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom) + <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo) + <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly) <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity) <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageDefaultLanguage) - <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent) - <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary) + <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent) + <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary) ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage] let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts @@ -122,16 +123,8 @@ postMessageR cID = do siteLayout' (toWidget <$> summary) $(widgetFile "system-message") where - modifySystemMessage smId SystemMessage{..} = do - runDB $ update smId - [ SystemMessageFrom =. systemMessageFrom - , SystemMessageTo =. systemMessageTo - , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly - , SystemMessageSeverity =. systemMessageSeverity - , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage - , SystemMessageContent =. systemMessageContent - , SystemMessageSummary =. systemMessageSummary - ] + modifySystemMessage smId sm = do + runDB $ replace smId sm addMessageI Success MsgSystemMessageEditSuccess redirect $ MessageR cID @@ -165,6 +158,7 @@ postMessageListR = do , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR ciphertext , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo + , sortable (Just "news-only") (i18nCell MsgSystemMessageNewsOnly) $ \DBRow { dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageNewsOnly , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly , sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity , sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let @@ -192,6 +186,9 @@ postMessageListR = do , ( "to" , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo ) + , ( "news-only" + , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageNewsOnly + ) , ( "authenticated" , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly ) @@ -254,13 +251,14 @@ postMessageListR = do MsgRenderer mr <- getMsgRenderer ((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage - <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing - <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing - <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing - <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) Nothing + <$> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just False) + <*> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just Nothing) + <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just Nothing) + <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just False) + <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just Info) <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just $ NonEmpty.head appLanguages) <*> areq htmlField (fslI MsgSystemMessageContent) Nothing - <*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing + <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just Nothing) case addRes of FormMissing -> return () diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs index 8de3add92..713e2dd93 100644 --- a/src/Utils/SystemMessage.hs +++ b/src/Utils/SystemMessage.hs @@ -17,3 +17,15 @@ getSystemMessage appLanguages smId = runMaybeT $ do avL = NonEmpty.sortWith (\l -> NTop $ findIndex (langMatches l) $ NonEmpty.toList appLanguages) $ systemMessageDefaultLanguage :| map (systemMessageTranslationLanguage . entityVal) translations lang <- selectLanguage avL return (SystemMessage{..}, find (langMatches lang . systemMessageTranslationLanguage) $ map entityVal translations) + +systemMessageToTranslation :: SystemMessageId + -> (SystemMessage, Maybe SystemMessageTranslation) + -> SystemMessageTranslation +systemMessageToTranslation systemMessageTranslationMessage (SystemMessage{..}, Nothing) + = SystemMessageTranslation + { systemMessageTranslationMessage + , systemMessageTranslationLanguage = systemMessageDefaultLanguage + , systemMessageTranslationContent = systemMessageContent + , systemMessageTranslationSummary = systemMessageSummary + } +systemMessageToTranslation _ (_, Just t) = t diff --git a/templates/news/system-messages.hamlet b/templates/news/system-messages.hamlet new file mode 100644 index 000000000..b3e008779 --- /dev/null +++ b/templates/news/system-messages.hamlet @@ -0,0 +1,9 @@ +$newline never +
+ $forall (SystemMessage{systemMessageSeverity}, SystemMessageTranslation{systemMessageTranslationSummary, systemMessageTranslationContent}) <- messages +
+ $maybe summary <- systemMessageTranslationSummary +

#{summary} + #{systemMessageTranslationContent} + $nothing +

#{systemMessageTranslationContent} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 26a0399fb..1e848143d 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -894,11 +894,12 @@ fillDb = do void . insert' $ Lecturer gkleen dbs CourseLecturer void . insert' $ Lecturer jost dbs CourseAssistant - testMsg <- insert $ SystemMessage (Just now) Nothing False Success "de" "System-Nachrichten werden angezeigt" Nothing + testMsg <- insert $ SystemMessage False (Just now) Nothing False Success "de" "System-Nachrichten werden angezeigt" Nothing void . insert $ SystemMessageTranslation testMsg "en" "System messages may be translated" Nothing - void . insert $ SystemMessage (Just now) Nothing False Info "de" "System-Nachrichten können längeren Inhalt enthalten" (Just "System-Nachricht Zusammenfassung") - void . insert $ SystemMessage (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing - void . insert $ SystemMessage Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing + void . insert $ SystemMessage False (Just now) Nothing False Info "de" "System-Nachrichten können längeren Inhalt enthalten" (Just "System-Nachricht Zusammenfassung") + void . insert $ SystemMessage False (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing + void . insert $ SystemMessage False Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing + void . insert $ SystemMessage True (Just now) Nothing False Error "de" "System-Nachrichten können nur auf \"Aktuelles\" angezeigt werden" Nothing funAlloc <- insert' Allocation