fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(news): show system messages

Browse Source
This commit is contained in:
Gregor Kleen 2020-04-09 11:56:29 +02:00
parent bc47dcf43f
commit 0d39924777
10 changed files with 95 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
frontend/src/app.sass
View File

@ -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)

1
messages/uniworx/de-de-formal.msg
View File

@ -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

1
messages/uniworx/en-eu.msg
View File

@ -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

1
models/system-messages.model
View File

@ -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?

2
src/Foundation.hs
View File

@ -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

22
src/Handler/News.hs
View File

@ -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

38
src/Handler/SystemMessage.hs
View File

@ -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 ()

12
src/Utils/SystemMessage.hs
View File

@ -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

9
templates/news/system-messages.hamlet Normal file
View File

@ -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}

9
test/Database/Fill.hs
View File

@ -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