feat(news): show system messages

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)

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

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

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?

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
 

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

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)
+          <$> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just systemMessageNewsOnly)
-          <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
+          <*> aopt  utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
-          <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
+          <*> 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)
+          <*> areq  htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent)
-          <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary)
+          <*> 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
+    modifySystemMessage smId sm = do
-      runDB $ update smId
+      runDB $ replace smId sm
-        [ SystemMessageFrom =. systemMessageFrom
-        , SystemMessageTo =. systemMessageTo
-        , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
-        , SystemMessageSeverity =. systemMessageSeverity
-        , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
-        , SystemMessageContent =. systemMessageContent
-        , SystemMessageSummary =. systemMessageSummary
-        ]
       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
+    <$> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just False)
-    <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
+    <*> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just Nothing)
-    <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
+    <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just Nothing)
-    <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) 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 ()

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

templates/news/system-messages.hamlet

@@ -0,0 +1,9 @@
+$newline never
+<section .news__system-messages>
+  $forall (SystemMessage{systemMessageSeverity}, SystemMessageTranslation{systemMessageTranslationSummary, systemMessageTranslationContent}) <- messages
+    <div .news__system-message .news__system-message--#{toPathPiece systemMessageSeverity}>
+      $maybe summary <- systemMessageTranslationSummary
+        <h2>#{summary}
+        #{systemMessageTranslationContent}
+      $nothing
+        <h2>#{systemMessageTranslationContent}

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 False (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 False (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 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