From c81bc2314e75d82ad2a246218b7e077d5cb02781 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 15 Apr 2020 12:34:20 +0200 Subject: [PATCH] feat(system-messages): hiding --- frontend/src/app.sass | 65 +++++++++++++++++++-------- messages/uniworx/de-de-formal.msg | 6 +++ models/system-messages.model | 2 +- routes | 2 +- src/Foundation.hs | 35 +++++++++++++++ src/Handler/News.hs | 46 ++++++++++++++----- src/Handler/SystemMessage.hs | 53 +++++++++++++++++----- src/Handler/Utils/News.hs | 11 +++++ src/Utils/DB.hs | 8 ++-- src/Utils/SystemMessage.hs | 10 +++-- templates/news/system-messages.hamlet | 27 +++++++++-- 11 files changed, 211 insertions(+), 54 deletions(-) create mode 100644 src/Handler/Utils/News.hs diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 220f09d1c..81687f70a 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 799fc17d7..3225592d5 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -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 diff --git a/models/system-messages.model b/models/system-messages.model index 32703fd40..1ba853a41 100644 --- a/models/system-messages.model +++ b/models/system-messages.model @@ -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() diff --git a/routes b/routes index 12f4c788b..eb115bc59 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 9aa6498e7..8cbe2940a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 6929a6249..f6d91519e 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -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") diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index c335f2331..555cda2df 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -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 diff --git a/src/Handler/Utils/News.hs b/src/Handler/Utils/News.hs new file mode 100644 index 000000000..f514aca75 --- /dev/null +++ b/src/Handler/Utils/News.hs @@ -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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 150a5c1f6..5b514261b 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -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 () diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs index 619dc765f..75d016c7e 100644 --- a/src/Utils/SystemMessage.hs +++ b/src/Utils/SystemMessage.hs @@ -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 diff --git a/templates/news/system-messages.hamlet b/templates/news/system-messages.hamlet index b3e008779..be9b82148 100644 --- a/templates/news/system-messages.hamlet +++ b/templates/news/system-messages.hamlet @@ -1,9 +1,28 @@ $newline never
- $forall (SystemMessage{systemMessageSeverity}, SystemMessageTranslation{systemMessageTranslationSummary, systemMessageTranslationContent}) <- messages + $forall (SystemMessage{systemMessageSeverity}, SystemMessageTranslation{systemMessageTranslationSummary, systemMessageTranslationContent}, hidden, time, hideForm) <- messages
$maybe summary <- systemMessageTranslationSummary -

#{summary} - #{systemMessageTranslationContent} +

+ $if hidden + #{iconInvisible} # + #{summary} +
+ #{systemMessageTranslationContent} $nothing -

#{systemMessageTranslationContent} +

+ $if hidden + #{iconInvisible} # + #{systemMessageTranslationContent} +
+ _{MsgSystemMessageLastChangedAt time}, # + ^{hideForm} + $if anyHidden +

+ $if showHidden + + _{MsgNewsHideHiddenSystemMessages} + $else + + _{MsgNewsShowHiddenSystemMessages} +