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

Slightly better system messages

Browse Source
This commit is contained in:
Gregor Kleen 2019-05-10 19:19:15 +02:00
parent 1b0a4762c9
commit 9f9312661d
4 changed files with 13 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Foundation.hs
View File

@ -1379,6 +1379,10 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .|
cID <- encrypt smId cID <- encrypt smId
void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
now <- liftIO getCurrentTime
guard $ NTop systemMessageFrom <= NTop (Just now)
guard $ NTop (Just now) < NTop systemMessageTo
let sessionKey = "sm-" <> tshow (ciphertext cID) let sessionKey = "sm-" <> tshow (ciphertext cID)
_ <- assertM isNothing $ lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ()) _ <- assertM isNothing $ lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())
setSessionJson sessionKey () setSessionJson sessionKey ()

2
src/Handler/SystemMessage.hs
View File

@ -121,7 +121,7 @@ postMessageR cID = do
maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
forms <- traverse (const mkForm) $ () <$ guard maySubmit forms <- traverse (const mkForm) $ () <$ guard maySubmit
defaultLayout siteLayout' (toWidget <$> summary)
$(widgetFile "system-message") $(widgetFile "system-message")
where where
modifySystemMessage smId SystemMessage{..} = do modifySystemMessage smId SystemMessage{..} = do

6
templates/system-message.hamlet
View File

@ -1,7 +1,7 @@
<section> <section>
$maybe summary' <- summary $# $maybe summary' <- summary
<h2> $# <h2>
#{summary'} $# #{summary'}
<p> <p>
#{content} #{content}

5
test/Database.hs
View File

@ -571,3 +571,8 @@ fillDb = do
void . insert' $ DegreeCourse dbs sdBsc sdMath void . insert' $ DegreeCourse dbs sdBsc sdMath
void . insert' $ Lecturer gkleen dbs CourseLecturer void . insert' $ Lecturer gkleen dbs CourseLecturer
void . insert' $ Lecturer jost dbs CourseAssistant void . insert' $ Lecturer jost dbs CourseAssistant
void . insert $ SystemMessage (Just now) Nothing False Success "de" "System-Nachrichten werden angezeigt" 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