feat(system-messages): hiding

frontend/src/app.sass

@@ -236,10 +236,10 @@ h4
     margin-top: 20px
 
 // GENERAL BUTTON STYLES
-input[type="submit"],
+input[type="submit"]:not(.btn-link),
-input[type="button"],
+input[type="button"]:not(.btn-link),
-button,
+button:not(.btn-link),
-.btn
+.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="submit"][disabled]:not(.btn-link),
-input[type="button"][disabled],
+input[type="button"][disabled]:not(.btn-link),
-button[disabled],
+button[disabled]:not(.btn-link),
-.btn[disabled]
+.btn[disabled]:not(.btn-link)
   opacity: 0.3
   background-color: var(--color-grey)
   cursor: default
 
-input[type="submit"]:not([disabled]):hover,
+input[type="submit"]:not([disabled]):not(.btn-link):hover,
-input[type="button"]:not([disabled]):hover,
+input[type="button"]:not([disabled]):not(.btn-link):hover,
-button:not([disabled]):hover,
+button:not([disabled]):not(.btn-link):hover,
-.btn:not([disabled]):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="submit"].btn-info:not(.btn-link):hover,
-input[type="button"].btn-info:hover,
+input[type="button"].btn-info:not(.btn-link):hover,
-.btn-info: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

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

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

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

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
 

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 $
+        (btnView, btnEnctype) <- generateFormPost . buttonForm' $ bool [BtnSystemMessageHide] [BtnSystemMessageUnhide] hidden
-       selectKeys [] []
+        return $ wrapForm btnView def
-    .| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
+          { formSubmit = FormNoSubmit
-    .| C.mapMaybeM (\smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId)
+          , formEncoding = btnEnctype
-    .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
+          , formAction = Just . SomeRoute $ MessageHideR cID
-    .| C.iterM (\(smId, _, _) -> tellShown smId)
+          , formAttrs = [("class", "form--inline")]
-    .| C.map ((,) <$> view _2 <*> view _3)
+          }
-    .| C.consume
+      checkHidden (smId, sm@SystemMessage{..}, trans) = do
-  let messages = sortOn (\(SystemMessage{..}, _) -> (Down systemMessageLastChanged, systemMessageSeverity)) messages'
+        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")
 
 

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
+  ((btnRes, _), _) <- runFormPost buttonForm
-    existsKey404 smId
 
-    whenIsJust muid $ \uid -> void $
+  formResult btnRes $ \case
-      upsert SystemMessageHidden
+    BtnSystemMessageHide -> runDB $ do
-        { systemMessageHiddenMessage = smId
+      existsKey404 smId
-        , systemMessageHiddenUser    = uid
-        , systemMessageHiddenTime    = now
-        }
-        [ SystemMessageHiddenTime =. now ]
 
-    tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
+      whenIsJust muid $ \uid -> void $
-      HashMap.singleton cID mempty{ userSystemMessageHidden = Just now }
+        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

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

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

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
+    { userSystemMessageShown    = (max `on` userSystemMessageShown ) a b
-    , userSystemMessageHidden = (max `on` userSystemMessageHidden) 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

templates/news/system-messages.hamlet

@@ -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}
+        <h2>
-        #{systemMessageTranslationContent}
+          $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}
+