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

feat(system-messages): hiding

Browse Source
This commit is contained in:
Gregor Kleen 2020-04-15 12:34:20 +02:00
parent ead6015dfe
commit c81bc2314e
11 changed files with 211 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
frontend/src/app.sass
View File

@ -236,10 +236,10 @@ h4
margin-top: 20px
// GENERAL BUTTON STYLES
input[type="submit"],
input[type="button"],
button,
.btn
input[type="submit"]:not(.btn-link),
input[type="button"]:not(.btn-link),
button:not(.btn-link),
.btn:not(.btn-link)
font-family: var(--font-base)
outline: 0
border: 0
@ -272,39 +272,59 @@ button,
display: grid
grid: min-content / auto-flow 1fr
input[type="submit"][disabled],
input[type="button"][disabled],
button[disabled],
.btn[disabled]
input[type="submit"][disabled]:not(.btn-link),
input[type="button"][disabled]:not(.btn-link),
button[disabled]:not(.btn-link),
.btn[disabled]:not(.btn-link)
opacity: 0.3
background-color: var(--color-grey)
cursor: default
input[type="submit"]:not([disabled]):hover,
input[type="button"]:not([disabled]):hover,
button:not([disabled]):hover,
.btn:not([disabled]):hover
input[type="submit"]:not([disabled]):not(.btn-link):hover,
input[type="button"]:not([disabled]):not(.btn-link):hover,
button:not([disabled]):not(.btn-link):hover,
.btn:not([disabled]):not(.btn-link):hover
background-color: var(--color-light)
color: white
&.btn-danger
background-color: var(--color-error)
.btn-primary
.btn-primary:not(.btn-link)
background-color: var(--color-primary)
.btn-info
.btn-info:not(.btn-link)
background-color: var(--color-info)
.btn--small
.btn--small:not(.btn-link)
padding: 4px 7px
background-color: var(--color-darker)
input[type="submit"].btn-info:hover,
input[type="button"].btn-info:hover,
.btn-info:hover
input[type="submit"].btn-info:not(.btn-link):hover,
input[type="button"].btn-info:not(.btn-link):hover,
.btn-info:not(.btn-link):hover
background-color: var(--color-grey)
.btn-link
font-family: var(--font-base)
outline: 0
border: 0
box-shadow: 0
background: none
color: inherit
padding: 0
min-width: unset
font-size: inherit
cursor: pointer
display: inline
text-decoration: underline
font-weight: 600
font-style: inherit
transition: color .2s ease, background-color .2s ease
&:not([disabled]):hover
color: var(--color-link-hover)
// GENERAL TABLE STYLES
.table
margin: 21px 0
@ -1270,6 +1290,15 @@ a.breadcrumbs__home
overflow-y: auto
max-height: 75vh
.news__system-message-detail
font-style: italic
font-size: 0.9rem
font-weight: 600
color: var(--color-fontsec)
.news__system-message-content + &
margin-top: 10px
.news__system-message
border-left: 3px solid var(--color-info)
padding-left: 17px

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

@ -34,6 +34,8 @@ BtnCorrInvDecline: Ablehnen
BtnSubmissionsAssign: Abgaben automatisch zuteilen
BtnAllocationCompute: Vergabe berechnen
BtnAllocationAccept: Vergabe akzeptieren
BtnSystemMessageHide: Verstecken
BtnSystemMessageUnhide: Nicht mehr verstecken
Aborted: Abgebrochen
@ -523,6 +525,9 @@ NewsOpenAllocations: Offene Zentralanmeldungen
NewsUpcomingSheets: Anstehende Übungsblätter
NewsUpcomingExams: Bevorstehende Prüfungen
NewsHideHiddenSystemMessages: Versteckte Nachrichten nicht mehr anzeigen
NewsShowHiddenSystemMessages: Versteckte Nachrichten anzeigen
NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"}
CloseAlert: Schliessen
@ -1071,6 +1076,7 @@ SystemMessageUnhide: "Verstecken" ignorieren
SystemMessageUnhideTip: Soll die Nachricht für Benutzer, die sie aktiv versteckt haben, erneut angezeigt werden?
SystemMessageCreated: Erstellt
SystemMessageLastChanged: Zuletzt geändert
SystemMessageLastChangedAt time@Text: Zuletzt geändert: #{time}
SystemMessageLastUnhide: Zuletzt un-versteckt
SystemMessageFrom: Sichtbar ab
SystemMessageTo: Sichtbar bis

2
models/system-messages.model
View File

@ -3,7 +3,7 @@
SystemMessage
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)
newsOnly Bool default=False
newsOnly Bool default=false
authenticatedOnly Bool -- Show message to all users upon visiting the site or only upon login?
severity MessageStatus -- Success, Warning, Error, Info, ...
created UTCTime default=now()

2
routes
View File

@ -224,7 +224,7 @@
/msgs MessageListR GET POST
/msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDreadANDauthentication
/msg/#{CryptoUUIDSystemMessage}/hide MessageHideR POST
/msg/#{CryptoUUIDSystemMessage}/hide MessageHideR POST !timeANDauthentication
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists

35
src/Foundation.hs
View File

@ -769,6 +769,14 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
&& NTop systemMessageTo >= cTime
return Authorized
MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime
&& NTop systemMessageTo >= cTime
return Authorized
CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
@ -1266,6 +1274,12 @@ tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
let isAuthenticated = isJust mAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
let isAuthenticated = isJust mAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
@ -1977,11 +1991,32 @@ getSystemMessageState smId = liftHandler $ do
applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
applySystemMessages = liftHandler . maybeT_ $ do
lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden
cRoute <- lift getCurrentRoute
guard $ cRoute /= Just NewsR
lift . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
where
syncSystemMessageHidden uid = runDB $ do
smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: DB (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 smId SystemMessage{..}) = maybeT_ $ do
guard $ not systemMessageNewsOnly

46
src/Handler/News.hs
View File

@ -3,6 +3,9 @@ module Handler.News where
import Import
import Handler.Utils
import Handler.Utils.News
import Handler.SystemMessage
import qualified Data.Map as Map
import Database.Esqueleto.Utils.TH
@ -11,6 +14,7 @@ import qualified Database.Esqueleto.Utils as E
import qualified Data.Conduit.List as C (consume, mapMaybeM)
import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.Lift as C
import qualified Data.HashMap.Strict as HashMap
@ -38,22 +42,44 @@ newsSystemMessages :: Widget
newsSystemMessages = do
now <- liftIO getCurrentTime
showHidden <- isJust <$> lookupGetParam (toPathPiece GetHidden)
let tellShown smId = liftHandler $ do
cID <- encrypt smId :: Handler CryptoUUIDSystemMessage
tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
mkHideForm smId SystemMessage{..} = liftHandler $ do
cID <- encrypt smId
hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide
messages' <- liftHandler . runDB . runConduit $
selectKeys [] []
.| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
.| C.mapMaybeM (\smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId)
.| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
.| C.iterM (\(smId, _, _) -> tellShown smId)
.| C.map ((,) <$> view _2 <*> view _3)
.| C.consume
let messages = sortOn (\(SystemMessage{..}, _) -> (Down systemMessageLastChanged, systemMessageSeverity)) messages'
(btnView, btnEnctype) <- generateFormPost . buttonForm' $ bool [BtnSystemMessageHide] [BtnSystemMessageUnhide] hidden
return $ wrapForm btnView def
{ formSubmit = FormNoSubmit
, formEncoding = btnEnctype
, formAction = Just . SomeRoute $ MessageHideR cID
, formAttrs = [("class", "form--inline")]
}
checkHidden (smId, sm@SystemMessage{..}, trans) = do
hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide
unless (null messages)
tell $ Any hidden
return $ guardOn (not hidden || showHidden) (smId, sm, trans, hidden)
(messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
transPipe lift (selectKeys [] [])
.| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
.| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId)
.| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
.| C.mapMaybeM checkHidden
.| C.iterM (\(smId, _, _, _) -> tellShown smId)
.| C.mapM (\(smId, sm@SystemMessage{..}, trans, hidden) -> (sm, trans, hidden,,) <$> formatTime SelFormatDateTime (maybe id max systemMessageFrom systemMessageLastChanged) <*> mkHideForm smId sm)
.| C.consume
let messages = sortOn (\(SystemMessage{..}, _, _, _, _) -> (Down $ maybe id max systemMessageFrom systemMessageLastChanged, systemMessageSeverity)) messages'
hiddenUrl <- toTextUrl (NewsR, [(toPathPiece GetHidden, "")])
unless (not anyHidden && null messages)
$(widgetFile "news/system-messages")

53
src/Handler/SystemMessage.hs
View File

@ -1,6 +1,7 @@
module Handler.SystemMessage
( getMessageR, postMessageR
, getMessageListR, postMessageListR
, ButtonSystemMessageHide(..)
, postMessageHideR
) where
@ -14,6 +15,7 @@ import qualified Data.HashMap.Strict as HashMap
import qualified Data.List.NonEmpty as NonEmpty
import Handler.Utils
import Handler.Utils.News
import qualified Database.Esqueleto as E
@ -304,24 +306,51 @@ postMessageListR = do
$(widgetFile "system-message-list")
data ButtonSystemMessageHide
= BtnSystemMessageHide
| BtnSystemMessageUnhide
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''ButtonSystemMessageHide $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''ButtonSystemMessageHide id
instance Button UniWorX ButtonSystemMessageHide where
btnClasses BtnSystemMessageHide = [BCLink]
btnClasses BtnSystemMessageUnhide = [BCLink]
postMessageHideR :: CryptoUUIDSystemMessage -> Handler Void
postMessageHideR cID = do
now <- liftIO getCurrentTime
muid <- maybeAuthId
smId <- decrypt cID
runDB $ do
existsKey404 smId
((btnRes, _), _) <- runFormPost buttonForm
whenIsJust muid $ \uid -> void $
upsert SystemMessageHidden
{ systemMessageHiddenMessage = smId
, systemMessageHiddenUser = uid
, systemMessageHiddenTime = now
}
[ SystemMessageHiddenTime =. now ]
formResult btnRes $ \case
BtnSystemMessageHide -> runDB $ do
existsKey404 smId
tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
HashMap.singleton cID mempty{ userSystemMessageHidden = Just now }
whenIsJust muid $ \uid -> void $
upsert SystemMessageHidden
{ systemMessageHiddenMessage = smId
, systemMessageHiddenUser = uid
, systemMessageHiddenTime = now
}
[ SystemMessageHiddenTime =. now ]
redirect NewsR
modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
-> fmap MergeHashMap . assertM' (/= mempty) $
HashMap.update (\smSt -> assertM' (/= mempty) $ smSt { userSystemMessageUnhidden = Nothing, userSystemMessageHidden = guardOn (is _Nothing muid) now }) cID hm
BtnSystemMessageUnhide -> runDB $ do
existsKey404 smId
whenIsJust muid $ \uid ->
deleteBy $ UniqueSystemMessageHidden uid smId
modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
-> fmap MergeHashMap . assertM' (/= mempty) $
HashMap.update (\smSt -> assertM' (/= mempty) $ smSt { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = guardOn (is _Nothing muid) now }) cID hm
redirect . (NewsR, ) . bool [] [(toPathPiece GetHidden, "")] $ btnRes == FormSuccess BtnSystemMessageUnhide

11
src/Handler/Utils/News.hs Normal file
View File

@ -0,0 +1,11 @@
module Handler.Utils.News
( NewsGetParam(..)
) where
import Import
data NewsGetParam = GetHidden
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''NewsGetParam $ camelToPathPiece' 1

8
src/Utils/DB.hs
View File

@ -56,9 +56,9 @@ existsBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity
=> Unique record -> ReaderT backend m ()
existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
=> Key record -> ReaderT backend m Bool
existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
existsKey = exists . pure . (persistIdField ==.)
exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
=> [Filter record] -> ReaderT backend m Bool
@ -68,9 +68,9 @@ exists404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity r
=> [Filter record] -> ReaderT backend m ()
exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
existsKey404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadHandler m)
existsKey404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
=> Key record -> ReaderT backend m ()
existsKey404 = bool (return ()) notFound <=< existsKey
existsKey404 = bool notFound (return ()) <=< existsKey
updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
=> Unique record -> [Update record] -> ReaderT backend m ()

10
src/Utils/SystemMessage.hs
View File

@ -34,7 +34,8 @@ systemMessageToTranslation _ (_, Just t) = t
data UserSystemMessageState = UserSystemMessageState
{ userSystemMessageShown
, userSystemMessageHidden :: Maybe UTCTime
, userSystemMessageHidden
, userSystemMessageUnhidden :: Maybe UTCTime
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
@ -44,8 +45,9 @@ deriveJSON defaultOptions
instance Semigroup UserSystemMessageState where
a <> b = UserSystemMessageState
{ userSystemMessageShown = (max `on` userSystemMessageShown ) a b
, userSystemMessageHidden = (max `on` userSystemMessageHidden) a b
{ userSystemMessageShown = (max `on` userSystemMessageShown ) a b
, userSystemMessageHidden = (max `on` userSystemMessageHidden) a b
, userSystemMessageUnhidden = (max `on` userSystemMessageUnhidden) a b
}
instance Monoid UserSystemMessageState where
mempty = UserSystemMessageState Nothing Nothing
mempty = UserSystemMessageState Nothing Nothing Nothing

27
templates/news/system-messages.hamlet
View File

@ -1,9 +1,28 @@
$newline never
<section .news__system-messages>
$forall (SystemMessage{systemMessageSeverity}, SystemMessageTranslation{systemMessageTranslationSummary, systemMessageTranslationContent}) <- messages
$forall (SystemMessage{systemMessageSeverity}, SystemMessageTranslation{systemMessageTranslationSummary, systemMessageTranslationContent}, hidden, time, hideForm) <- messages
<div .news__system-message .news__system-message--#{toPathPiece systemMessageSeverity}>
$maybe summary <- systemMessageTranslationSummary
<h2>#{summary}
#{systemMessageTranslationContent}
<h2>
$if hidden
#{iconInvisible} #
#{summary}
<div .news__system-message-content>
#{systemMessageTranslationContent}
$nothing
<h2>#{systemMessageTranslationContent}
<h2>
$if hidden
#{iconInvisible} #
#{systemMessageTranslationContent}
<div .news__system-message-detail>
_{MsgSystemMessageLastChangedAt time}, #
^{hideForm}
$if anyHidden
<p .news__system-message-detail>
$if showHidden
<a href=@{NewsR}>
_{MsgNewsHideHiddenSystemMessages}
$else
<a href=#{hiddenUrl}>
_{MsgNewsShowHiddenSystemMessages}