feat(system-messages): refactor cookies & improve system messages

BREAKING CHANGE: names of cookies & configuration changed

config/settings.yml

@@ -137,16 +137,33 @@ session-memcached:
   expiration: "_env:SESSION_MEMCACHED_EXPIRATION:28807"
 
 server-sessions:
-  cookie-name: _SESSION
   idle-timeout: 28807
   absolute-timeout: 604801
   timeout-resolution: 601
   persistent-cookies: true
-  http-only-cookies: true
-  secure-cookies: "_env:SERVER_SESSION_COOKIES_SECURE:true"
 session-token-expiration: 28807
 session-token-encoding: HS256
-session-samesite: strict
+
+cookies:
+  SESSION:
+    same-site: lax
+    http-only: true
+    secure: "_env:SERVER_SESSION_COOKIES_SECURE:true"
+  XSRF-TOKEN:
+    expires: null
+    same-site: strict
+    http-only: false
+    secure: "_env:COOKIES_SECURE:true"
+  LANG:
+    expires: 12622780800
+    same-site: lax
+    http-only: false
+    secure: "_env:COOKIES_SECURE:true"
+  SYSTEM-MESSAGE-STATE:
+    expires: 12622780800
+    same-site: lax
+    http-only: false
+    secure: "_env:COOKIES_SECURE:true"
 
 user-defaults:
   max-favourites:      12

messages/uniworx/de-de-formal.msg

@@ -1065,6 +1065,13 @@ InfoLecturerTitle: Hinweise für Veranstalter
 
 
 SystemMessageNewsOnly: Nur auf "Aktuelles"
+SystemMessageRecordChanged: Signifikante Änderung
+SystemMessageRecordChangedTip: Soll der "zuletzt geändert"-Zeitstempel gesetzt werden? Nachrichten werden auf "Aktuelles" danach sortiert und bei signifikanten Änderungen erneut als Benachrichtigung unten rechts angezeigt.
+SystemMessageUnhide: "Verstecken" ignorieren
+SystemMessageUnhideTip: Soll die Nachricht für Benutzer, die sie aktiv versteckt haben, erneut angezeigt werden?
+SystemMessageCreated: Erstellt
+SystemMessageLastChanged: Zuletzt geändert
+SystemMessageLastUnhide: Zuletzt un-versteckt
 SystemMessageFrom: Sichtbar ab
 SystemMessageTo: Sichtbar bis
 SystemMessageAuthenticatedOnly: Nur angemeldet
@@ -1296,6 +1303,7 @@ BreadcrumbAllocationUsers: Bewerber
 BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten
 BreadcrumbAllocationCompute: Platzvergabe berechnen
 BreadcrumbAllocationAccept: Platzvergabe akzeptieren
+BreadcrumbMessageHide: Verstecken
 
 ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
 ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}

models/system-messages.model

@@ -1,11 +1,14 @@
 -- 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)
+    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()
+    lastChanged         UTCTime default=now()
+    lastUnhide          UTCTime default=now()
     defaultLanguage     Lang -- Language of @content@ and @summary@
     content             Html -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified
     summary             Html Maybe
@@ -15,3 +18,9 @@ SystemMessageTranslation -- Translation of a @SystemMessage@ into another langua
     content             Html
     summary             Html Maybe
     UniqueSystemMessageTranslation message language
+
+SystemMessageHidden
+    message             SystemMessageId
+    user                UserId
+    time                UTCTime
+    UniqueSystemMessageHidden user message

routes

@@ -222,8 +222,9 @@
 /subs/download CorrectionsDownloadR  GET      !corrector !lecturer
 
 
-/msgs                           MessageListR GET POST
+/msgs                                MessageListR  GET POST
-/msg/#{CryptoUUIDSystemMessage} MessageR      GET POST        !timeANDreadANDauthentication
+/msg/#{CryptoUUIDSystemMessage}      MessageR      GET POST        !timeANDreadANDauthentication
+/msg/#{CryptoUUIDSystemMessage}/hide MessageHideR      POST
 
 !/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
 -- !/*{CI FilePath} CryptoFileNameDispatchR GET                  !free -- Disabled until preliminary check for valid cID exists

src/Application.hs

@@ -19,9 +19,10 @@ module Application
 import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
 import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                              pgPoolSize, runSqlPool, ConnectionPool)
-import Import                        hiding (cancel)
+import Import                        hiding (cancel, respond)
 import Language.Haskell.TH.Syntax           (qLocation)
 import Network.Wai (Middleware)
+import qualified Network.Wai as Wai
 import Network.Wai.Handler.Warp             (Settings, defaultSettings,
                                              defaultShouldDisplayException,
                                              runSettings, runSettingsSocket, setHost,
@@ -40,6 +41,9 @@ import Handler.Utils                        (runAppLoggingT)
 
 import Foreign.Store
 
+import Web.Cookie
+import Network.HTTP.Types.Header (hSetCookie)
+
 import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as UUID
 
@@ -323,7 +327,33 @@ makeApplication foundation = liftIO $ do
     logWare <- makeLogWare foundation
     -- Create the WAI application and apply middlewares
     appPlain <- toWaiAppPlain foundation
-    return . observeHTTPRequestLatency classifyHandler . logWare $ defaultMiddlewaresNoLogging appPlain
+    return . observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies $ defaultMiddlewaresNoLogging appPlain
+  where
+    normalizeCookies :: Wai.Middleware
+    normalizeCookies app req respond = app req $ \res -> do
+        resHdrs' <- go $ Wai.responseHeaders res
+        respond $ Wai.mapResponseHeaders (const resHdrs') res
+      where parseSetCookie' :: ByteString -> IO (Maybe SetCookie)
+            parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie
+              
+            go [] = return []
+            go (hdr@(hdrName, hdrValue) : hdrs)
+              | hdrName == hSetCookie = do
+                  mcookieHdr <- parseSetCookie' hdrValue
+                  case mcookieHdr of
+                    Nothing -> (hdr :) <$> go hdrs
+                    Just cookieHdr -> do
+                      let cookieHdrMatches hdrValue' = maybeT (return False) $ do
+                            cookieHdr' <- MaybeT $ parseSetCookie' hdrValue'
+                            -- See https://tools.ietf.org/html/rfc6265
+                            guard $ setCookiePath     cookieHdr' == setCookiePath     cookieHdr
+                            guard $ setCookieName     cookieHdr' == setCookieName     cookieHdr
+                            guard $ setCookieDomain   cookieHdr' == setCookieDomain   cookieHdr
+                            return True
+                      others <- filterM (\(hdrName', hdrValue') -> and2M (pure $ hdrName' == hSetCookie) (cookieHdrMatches hdrValue')) hdrs
+                      if | null others -> (hdr :) <$> go hdrs
+                         | otherwise   -> go hdrs
+              | otherwise = (hdr :) <$> go hdrs
 
 makeLogWare :: MonadIO m => UniWorX -> m Middleware
 makeLogWare app = do

src/Data/Time/Clock/Instances.hs

@@ -21,6 +21,9 @@ import Data.Time.Format.ISO8601
 instance Hashable DiffTime where
   hashWithSalt s = hashWithSalt s . toRational
 
+instance Hashable NominalDiffTime where
+  hashWithSalt s = hashWithSalt s . toRational
+
 instance PersistField NominalDiffTime where
   toPersistValue   = toPersistValue . toRational
   fromPersistValue = fmap fromRational . fromPersistValue

src/Foundation.hs

@@ -22,7 +22,9 @@ import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
 
-import qualified Network.Wai as W (pathInfo)
+import qualified Network.Wai as W
+import qualified Network.HTTP.Types.Header as W
+import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)
 
 import Yesod.Core.Types (HandlerContents)
 import qualified Yesod.Core.Unsafe as Unsafe
@@ -46,13 +48,12 @@ import qualified Data.Set as Set
 import Data.Map ((!?))
 import qualified Data.Map as Map
 import qualified Data.HashSet as HashSet
+import qualified Data.HashMap.Strict as HashMap
 import qualified Data.List.NonEmpty as NonEmpty
 
 import Data.List ((!!), findIndex, inits)
 import qualified Data.List as List
 
-import Web.Cookie
-
 import Data.Conduit.List (sourceList)
 
 import qualified Database.Esqueleto as E
@@ -100,7 +101,7 @@ import UnliftIO.Pool
 import qualified Web.ServerSession.Core as ServerSession
 import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
 
-import Jose.Jwt (Jwt(..))
+import Web.Cookie
 
 -- | Convenient Type Synonyms:
 type DB = YesodDB UniWorX
@@ -1474,7 +1475,7 @@ instance Yesod UniWorX where
             Nothing -> getApprootText guessApproot app req
             Just root -> root
 
-    makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = sameSite $ case appSessionStore of
+    makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
         SessionStorageMemcachedSql sqlStore
           -> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
         SessionStorageAcid acidStore
@@ -1498,14 +1499,25 @@ instance Yesod UniWorX where
                   => ServerSession.State sto -> IO (Maybe SessionBackend)
         mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
         stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
-        stateSettings = applyServerSessionSettings appServerSessionConfig
+        stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
         sameSite
-          | Just SameSiteStrict <- appSessionSameSite
+          | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
           = strictSameSiteSessions
-          | Just SameSiteLax <- appSessionSameSite
+          | Just sameSiteLax    == cookieSameSite (getCookieSettings app CookieSession)
           = laxSameSiteSessions
           | otherwise
           = id
+        notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
+        notForBearer = fmap $ fmap notForBearer'
+          where notForBearer' :: SessionBackend -> SessionBackend
+                notForBearer' (SessionBackend load)
+                  = let load' req
+                          | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
+                          , any (is _Just) $ map W.extractBearerAuth aHdrs
+                          = return (mempty, const $ return [])
+                          | otherwise
+                          = load req
+                     in SessionBackend load'
 
     maximumContentLength app _ = app ^. _appMaximumContentLength
 
@@ -1516,7 +1528,7 @@ instance Yesod UniWorX where
     --   b) Validates that incoming write requests include that token in either a header or POST parameter.
     -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-    yesodMiddleware = observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware . storeBearerMiddleware
+    yesodMiddleware = observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . csrfMiddleware . updateFavouritesMiddleware . storeBearerMiddleware
       where
         updateFavouritesMiddleware :: Handler a -> Handler a
         updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
@@ -1550,6 +1562,17 @@ instance Yesod UniWorX where
             addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
         observeYesodCacheSizeMiddleware :: Handler a -> Handler a
         observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
+        csrfMiddleware :: Handler a -> Handler a
+        csrfMiddleware handler = do
+          hasBearer <- is _Just <$> lookupBearerAuth
+
+          if | hasBearer -> handler
+             | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
+          where
+            csrfSetCookieMiddleware' handler' = do
+              mcsrf <- reqToken <$> getRequest
+              whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken
+              handler'
         storeBearerMiddleware :: Handler a -> Handler a
         storeBearerMiddleware handler = do
           askBearer >>= \case
@@ -1932,12 +1955,36 @@ siteLayout' headingOverride widget = do
   withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
 
 
+getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX) => SystemMessageId -> m UserSystemMessageState
+getSystemMessageState smId = liftHandler $ do
+  muid <- maybeAuthId
+  reqSt <- $cachedHere getSystemMessageStateRequest
+  dbSt <- $cachedHere $ maybe (return mempty) getDBSystemMessageState muid
+  let MergeHashMap smSt = reqSt <> dbSt
+      smSt' = MergeHashMap $ HashMap.filter (/= mempty) smSt
+  when (smSt' /= reqSt) $
+        setRegisteredCookieJson CookieSystemMessageState
+    =<< ifoldMapM (\smId' v -> MergeHashMap <$> (HashMap.singleton <$> encrypt smId' <*> pure v :: Handler (HashMap CryptoUUIDSystemMessage _))) smSt'
+
+  return . fromMaybe mempty $ HashMap.lookup smId smSt
+  where
+    getSystemMessageStateRequest =
+          (lookupRegisteredCookiesJson id CookieSystemMessageState :: Handler (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState))
+      >>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (HashMap.singleton <$> decrypt cID <*> pure v))
+    getDBSystemMessageState uid = runDB . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt
+      where foldSt (Entity _ SystemMessageHidden{..})
+              = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime }
+
 applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
-applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
+applySystemMessages = liftHandler . maybeT_ $ do
+  cRoute <- lift getCurrentRoute
+  guard $ cRoute /= Just NewsR
+
+  lift . 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
 
@@ -1945,9 +1992,9 @@ applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C
       guard $ NTop systemMessageFrom <= NTop (Just now)
       guard $ NTop (Just now) < NTop systemMessageTo
 
-      let sessionKey = "sm-" <> tshow (ciphertext cID)
+      UserSystemMessageState{..} <- lift $ getSystemMessageState smId
-      _ <- assertM isNothing $ lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())
+      guard $ userSystemMessageShown <= Just systemMessageLastChanged
-      setSessionJson sessionKey ()
+      guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
 
       (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
       let
@@ -1959,6 +2006,9 @@ applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C
           addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
         Nothing -> addMessage systemMessageSeverity content
 
+      tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
+        HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
+
 -- Define breadcrumbs.
 i18nCrumb :: ( RenderMessage (HandlerSite m) msg, MonadHandler m )
           => msg
@@ -2225,6 +2275,7 @@ instance YesodBreadcrumbs UniWorX where
       | mayList   -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR
       | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR
   breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR
+  breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID
 
   breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR
 
@@ -4561,16 +4612,6 @@ associateUserSchoolsByTerms uid = do
         , userSchoolIsOptOut = False
         }
 
-setLangCookie :: MonadHandler m => Lang -> m ()
-setLangCookie lang = do
-  now <- liftIO getCurrentTime
-  setCookie $ def
-    { setCookieName    = "_LANG"
-    , setCookieValue   = encodeUtf8 lang
-    , setCookieExpires = Just $ addUTCTime (400 * avgNominalYear) now
-    , setCookiePath    = Just "/"
-    }
-
 updateUserLanguage :: Maybe Lang -> DB (Maybe Lang)
 updateUserLanguage (Just lang) = do
   unless (lang `elem` appLanguages) $
@@ -4580,7 +4621,7 @@ updateUserLanguage (Just lang) = do
   for_ muid $ \uid -> do
     langs <- languages
     update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
-  setLangCookie lang
+  setRegisteredCookie CookieLang lang
   return $ Just lang
 updateUserLanguage Nothing = runMaybeT $ do
   uid <- MaybeT maybeAuthId
@@ -4599,7 +4640,7 @@ updateUserLanguage Nothing = runMaybeT $ do
       -> return l
     (_, [], _)
       -> mzero
-  setLangCookie lang
+  setRegisteredCookie CookieLang lang
   return lang
 
 

src/Foundation/Type.hs

@@ -62,3 +62,5 @@ instance HasHttpManager UniWorX Manager where
   httpManager = _appHttpManager
 instance HasAppSettings UniWorX where
   appSettings = _appSettings'
+instance HasCookieSettings RegisteredCookie UniWorX where
+  getCookieSettings = appCookieSettings . appSettings'

src/Handler/Admin/Tokens.hs

@@ -9,10 +9,6 @@ import qualified Data.HashSet as HashSet
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Set as Set
 
-import Control.Arrow (left)
-
-import Jose.Jwt (Jwt(..))
-
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Encode.Pretty as Aeson
 

src/Handler/News.hs

@@ -12,6 +12,8 @@ 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.HashMap.Strict as HashMap
+
 
 getNewsR :: Handler Html
 getNewsR = do
@@ -35,14 +37,21 @@ getNewsR = do
 newsSystemMessages :: Widget
 newsSystemMessages = do
   now <- liftIO getCurrentTime
+
+  let tellShown smId = liftHandler $ do
+        cID <- encrypt smId :: Handler CryptoUUIDSystemMessage
+        tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
+          HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
   
   messages' <- liftHandler . runDB . runConduit $
        selectKeys [] []
     .| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
-    .| C.mapMaybeM (\smId -> fmap (view _1 &&& systemMessageToTranslation smId) <$> getSystemMessage appLanguages smId)
+    .| 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.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{..}, _) -> (NTop systemMessageFrom, systemMessageSeverity)) messages'
+  let messages = sortOn (\(SystemMessage{..}, _) -> (Down systemMessageLastChanged, systemMessageSeverity)) messages'
 
   unless (null messages)
     $(widgetFile "news/system-messages")

src/Handler/SystemMessage.hs

@@ -1,10 +1,15 @@
-module Handler.SystemMessage where
+module Handler.SystemMessage
+  ( getMessageR, postMessageR
+  , getMessageListR, postMessageListR
+  , postMessageHideR
+  ) where
 
 import Import
 
 import qualified Data.Map.Lazy as Map
 
 import qualified Data.Set as Set
+import qualified Data.HashMap.Strict as HashMap
 
 import qualified Data.List.NonEmpty as NonEmpty
 
@@ -24,15 +29,19 @@ postMessageR cID = do
         Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
 
   MsgRenderer mr <- getMsgRenderer
+  now <- liftIO getCurrentTime
   let
     mkForm = do
       ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
         $ SystemMessage
-          <$> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just systemMessageNewsOnly)
+          <$> aopt  utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
-          <*> aopt  utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
           <*> aopt  utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
+          <*> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just systemMessageNewsOnly)
           <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
           <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
+          <*> pure systemMessageCreated
+          <*> (bool now systemMessageLastChanged <$> apopt checkBoxField (fslI MsgSystemMessageRecordChanged & setTooltip MsgSystemMessageRecordChangedTip) (Just True))
+          <*> (bool now systemMessageLastUnhide <$> apopt checkBoxField (fslI MsgSystemMessageUnhide & setTooltip MsgSystemMessageUnhideTip) (Just False))
           <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageDefaultLanguage)
           <*> areq  htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent)
           <*> aopt  htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary)
@@ -54,11 +63,14 @@ postMessageR cID = do
           <*> combinedButtonFieldF ""
 
       let modifyTranss = Map.map (view $ _1._1) modifyTranss'
+          nextLang = toList appLanguages
+            & filter (not . langMatches systemMessageDefaultLanguage)
+            & filter (\l -> none (`langMatches` l) $ Map.keys ts')
 
       ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
         $ SystemMessageTranslation
           <$> pure smId
-          <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) Nothing
+          <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
           <*> areq htmlField (fslI MsgSystemMessageContent) Nothing
           <*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
 
@@ -161,6 +173,9 @@ postMessageListR = do
       , 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 (Just "created") (i18nCell MsgSystemMessageCreated) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageCreated
+      , sortable (Just "last-changed") (i18nCell MsgSystemMessageLastChanged) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageLastChanged
+      , sortable (Just "last-unhide") (i18nCell MsgSystemMessageLastUnhide) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageLastUnhide
       , sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let
           (summary, content) = case smT of
               Nothing -> (systemMessageSummary, systemMessageContent)
@@ -195,6 +210,15 @@ postMessageListR = do
       , ( "severity"
         , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
         )
+      , ( "created"
+        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageCreated
+        )
+      , ( "last-changed"
+        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageLastChanged
+        )
+      , ( "last-unhide"
+        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageLastUnhide
+        )
       ]
     , dbtFilter = mempty
     , dbtFilterUI = mempty
@@ -250,12 +274,14 @@ postMessageListR = do
       -> addMessageI Error MsgSystemMessageEmptySelection
 
   MsgRenderer mr <- getMsgRenderer
+  now <- liftIO getCurrentTime
   ((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
-    <$> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just False)
+    <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just Nothing)
-    <*> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just Nothing)
     <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just Nothing)
+    <*> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just False)
     <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just False)
     <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just Info)
+    <*> pure now <*> pure now <*> pure now
     <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just $ NonEmpty.head appLanguages)
     <*> areq htmlField (fslI MsgSystemMessageContent) Nothing
     <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just Nothing)
@@ -276,3 +302,26 @@ postMessageListR = do
 
   defaultLayout
     $(widgetFile "system-message-list")
+
+
+postMessageHideR :: CryptoUUIDSystemMessage -> Handler Void
+postMessageHideR cID = do
+  now <- liftIO getCurrentTime
+  muid <- maybeAuthId
+  smId <- decrypt cID
+
+  runDB $ do
+    existsKey404 smId
+
+    whenIsJust muid $ \uid -> void $
+      upsert SystemMessageHidden
+        { systemMessageHiddenMessage = smId
+        , systemMessageHiddenUser    = uid
+        , systemMessageHiddenTime    = now
+        }
+        [ SystemMessageHiddenTime =. now ]
+
+    tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
+      HashMap.singleton cID mempty{ userSystemMessageHidden = Just now }
+
+  redirect NewsR

src/Handler/Term.hs

@@ -197,14 +197,14 @@ data TermFormTemplate = TermFormTemplate
 
 -- | TermFormTemplates form a pointwise-left biased Semigroup
 instance Semigroup TermFormTemplate where
-  left <> right = TermFormTemplate
+  l <> r = TermFormTemplate
-    { tftName         = tftName         left <|> tftName         right
+    { tftName         = tftName         l <|> tftName         r
-    , tftStart        = tftStart        left <|> tftStart        right
+    , tftStart        = tftStart        l <|> tftStart        r
-    , tftEnd          = tftEnd          left <|> tftEnd          right
+    , tftEnd          = tftEnd          l <|> tftEnd          r
-    , tftHolidays     = tftHolidays     left <|> tftHolidays     right
+    , tftHolidays     = tftHolidays     l <|> tftHolidays     r
-    , tftLectureStart = tftLectureStart left <|> tftLectureStart right
+    , tftLectureStart = tftLectureStart l <|> tftLectureStart r
-    , tftLectureEnd   = tftLectureEnd   left <|> tftLectureEnd   right
+    , tftLectureEnd   = tftLectureEnd   l <|> tftLectureEnd   r
-    , tftActive       = tftActive       left <|> tftActive       right
+    , tftActive       = tftActive       l <|> tftActive       r
     }
 
 instance Monoid TermFormTemplate where

src/Import/NoModel.hs

@@ -100,7 +100,8 @@ import Control.Monad.Catch as Import hiding (Handler(..))
 import Control.Monad.Trans.Control as Import hiding (embed)
 import Control.Monad.Fail as Import
 
-import Jose.Jwt as Import (Jwt)
+import Jose.Jwk as Import (JwkSet, Jwk(..))
+import Jose.Jwt as Import (Jwt(..))
 
 import Data.Time.Calendar as Import
 import Data.Time.Clock as Import
@@ -153,6 +154,7 @@ import Data.Encoding.Instances as Import ()
 import Prometheus.Instances as Import ()
 import Yesod.Form.Fields.Instances as Import ()
 import Data.MonoTraversable.Instances as Import ()
+import Web.Cookie.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256)
 
@@ -165,7 +167,7 @@ import Control.Lens as Import
 import Control.Lens.Extras as Import (is)
 import Data.Set.Lens as Import
 
-import Control.Arrow as Import (Kleisli(..))
+import Control.Arrow as Import (left, right, Kleisli(..))
 
 import Data.Encoding as Import (DynEncoding, decodeLazyByteString, encodeLazyByteString)
 import Data.Encoding.UTF8 as Import (UTF8(UTF8))

src/Settings.hs

@@ -10,12 +10,13 @@ module Settings
   ( module Settings
   , module Settings.Cluster
   , module Settings.Mime
+  , module Settings.Cookies
   ) where
 
 import           Import.NoModel
 import qualified Control.Exception           as Exception
-import           Data.Aeson                  (fromJSON, withObject
+import           Data.Aeson                  (fromJSON, withObject, withScientific
-                                             ,(.!=), (.:?), withScientific
+                                             ,(.!=), (.:?)
                                              )
 import qualified Data.Aeson.Types as Aeson
 import           Data.FileEmbed              (embedFile)
@@ -51,6 +52,7 @@ import qualified Database.Memcached.Binary.Types as Memcached
 import Model
 import Settings.Cluster
 import Settings.Mime
+import Settings.Cookies
 
 import qualified System.FilePath as FilePath
 
@@ -98,7 +100,6 @@ data AppSettings = AppSettings
     , appSessionMemcachedConf   :: Maybe MemcachedConf
     , appSessionTokenExpiration :: Maybe NominalDiffTime
     , appSessionTokenEncoding   :: JwtEncoding
-    , appSessionSameSite        :: Maybe SameSite
     
     , appMailFrom               :: Address
     , appMailObjectDomain       :: Text
@@ -155,13 +156,12 @@ data AppSettings = AppSettings
     , appUserDefaults           :: UserDefaultConf
     , appAuthPWHash             :: PWHashConf
 
+    , appCookieSettings         :: RegisteredCookie -> CookieSettings
+
     , appInitialInstanceID      :: Maybe (Either FilePath UUID)
     , appRibbon                 :: Maybe Text
     } deriving Show
 
-data SameSite = SameSiteStrict | SameSiteLax
-  deriving stock (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-  deriving anyclass (Universe, Finite)
 
 newtype ServerSessionSettings
   = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
@@ -277,9 +277,6 @@ data SmtpAuthConf = SmtpAuthConf
   , smtpAuthPassword :: HaskellNet.Password
   } deriving (Show)
 
-nullaryPathPiece ''SameSite $ camelToPathPiece' 2
-pathPieceJSON ''SameSite
-
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 2
   , fieldLabelModifier = camelToPathPiece' 2
@@ -379,21 +376,15 @@ instance FromJSON JwtEncoding where
 
 instance FromJSON ServerSessionSettings where
   parseJSON = withObject "ServerSession.State" $ \o -> do
-    cookieName <- o .:? "cookie-name"
     idleTimeout <- o .:? "idle-timeout"
     absoluteTimeout <- o .:? "absolute-timeout"
     timeoutResolution <- o .:? "timeout-resolution"
     persistentCookies <- o .:? "persistent-cookies"
-    httpOnlyCookies <- o .:? "http-only-cookies"
-    secureCookies <- o .:? "secure-cookies"
     return $ ServerSessionSettings (appEndo . foldMap Endo $ catMaybes
-      [ ServerSession.setCookieName <$> cookieName
+      [ pure $ ServerSession.setIdleTimeout idleTimeout
-      , pure $ ServerSession.setIdleTimeout idleTimeout
       , pure $ ServerSession.setAbsoluteTimeout absoluteTimeout
       , pure $ ServerSession.setTimeoutResolution timeoutResolution
       , ServerSession.setPersistentCookies <$> persistentCookies
-      , ServerSession.setHttpOnlyCookies <$> httpOnlyCookies
-      , ServerSession.setSecureCookies <$> secureCookies
       ])
 
 
@@ -496,10 +487,16 @@ instance FromJSON AppSettings where
 
         appRibbon                 <- assertM (not . Text.null) . fmap Text.strip <$> o.:? "ribbon"
 
-        appServerSessionConfig    <- o .: "server-sessions"
+        appCookieSettings         <- o .: "cookies"
-        appSessionTokenExpiration <- o .:? "session-token-expiration"
+
-        appSessionTokenEncoding   <- o .: "session-token-encoding"
+        appServerSessionConfig'    <- o .: "server-sessions"
-        appSessionSameSite        <- o .:? "session-samesite"
+        let appServerSessionConfig = ServerSessionSettings $ httpOnlyCookie . secureCookie . applyServerSessionSettings appServerSessionConfig'
+              where httpOnlyCookie :: forall a. ServerSession.State a -> ServerSession.State a
+                    httpOnlyCookie = fromMaybe id $ ServerSession.setHttpOnlyCookies <$> cookieHttpOnly (appCookieSettings CookieSession)
+                    secureCookie :: forall a. ServerSession.State a -> ServerSession.State a
+                    secureCookie = fromMaybe id $ ServerSession.setSecureCookies <$> cookieSecure (appCookieSettings CookieSession)
+        appSessionTokenExpiration  <- o .:? "session-token-expiration"
+        appSessionTokenEncoding    <- o .: "session-token-encoding"
 
         return AppSettings{..}
 

src/Settings/Cookies.hs

@@ -0,0 +1,68 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Settings.Cookies
+  ( CookieSettings(..)
+  , HasCookieSettings(..)
+  , cookieSettingsToSetCookie
+  ) where
+
+import ClassyPrelude
+
+import Web.Cookie
+import Web.Cookie.Instances ()
+
+import Utils.PathPiece
+
+import Data.Time.Clock
+import Data.Time.Clock.Instances ()
+
+import qualified Data.Text as Text
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.CaseInsensitive as CI
+
+import Data.Aeson
+import Data.Aeson.TH
+
+import Control.Lens ((&))
+import Control.Monad.Fail
+
+
+data CookieSettings = CookieSettings
+  { cookieExpires :: Maybe NominalDiffTime
+  , cookieSameSite :: Maybe SameSiteOption
+  , cookieHttpOnly
+  , cookieSecure :: Maybe Bool
+  } deriving (Eq, Show, Generic, Typeable)
+    deriving anyclass (Hashable)
+
+instance FromJSON SameSiteOption where
+  parseJSON = withText "SameSiteOption" $ \(CI.mk -> ciT) -> HashMap.lookup ciT options
+      & maybe (fail . unpack $ "Expected one of: " <> Text.intercalate ", " (map CI.original $ HashMap.keys options)) return
+    where options = mconcat
+            [ singletonMap "Lax"    sameSiteLax
+            , singletonMap "Strict" sameSiteStrict
+            , singletonMap "None"   sameSiteNone
+            ]
+
+deriveFromJSON defaultOptions
+  { omitNothingFields = True
+  , fieldLabelModifier = camelToPathPiece' 1
+  } ''CookieSettings
+
+
+class HasCookieSettings ident app | app -> ident where
+  getCookieSettings :: app -> ident -> CookieSettings
+
+instance HasCookieSettings ident (ident -> CookieSettings) where
+  getCookieSettings = id
+
+
+cookieSettingsToSetCookie :: MonadIO m => CookieSettings -> m SetCookie
+cookieSettingsToSetCookie CookieSettings{..} = do
+  now <- liftIO getCurrentTime
+  return def
+    { setCookieExpires  = addUTCTime <$> cookieExpires <*> pure now
+    , setCookieSameSite = cookieSameSite
+    , setCookieHttpOnly = fromMaybe (setCookieHttpOnly def) cookieHttpOnly
+    , setCookieSecure   = fromMaybe (setCookieSecure   def) cookieSecure
+    }

src/Utils.hs

@@ -15,7 +15,6 @@ import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
@@ -28,6 +27,9 @@ import Utils.Icon as Utils
 import Utils.Message as Utils
 import Utils.Lang as Utils
 import Utils.Parameters as Utils
+import Utils.Cookies as Utils
+import Utils.Cookies.Registered as Utils
+import Utils.Session as Utils
 import Utils.Csv as Utils
 
 import Text.Blaze (Markup, ToMarkup)
@@ -38,6 +40,8 @@ import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.List as List
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Vector as V
 
 import qualified Data.Conduit.List as C
 
@@ -52,6 +56,7 @@ import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
 import Control.Monad.Trans.Writer.Lazy (execWriterT, tell)
 import Control.Monad.Catch
 import Control.Monad.Morph (hoist)
+import Control.Monad.Fail
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Instances ()
@@ -60,7 +65,9 @@ import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
 
 import Text.Shakespeare.Text (st)
 
+import Data.Aeson (FromJSONKey)
 import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
 
 import Data.Universe
 
@@ -89,10 +96,14 @@ import Data.Constraint (Dict(..))
 import Control.Monad.Random.Class (MonadRandom)
 import qualified System.Random.Shuffle as Rand (shuffleM)
 
+import Data.Data (Data)
+
+import Unsafe.Coerce
+
 {-# ANN module ("HLint: ignore Use asum" :: String) #-}
 
 
-$(iconShortcuts) -- declares constants for all known icons
+iconShortcuts -- declares constants for all known icons
 
 -----------
 -- Yesod --
@@ -771,31 +782,13 @@ choice = foldr (<|>) empty
 -- Sessions --
 --------------
 
-data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
+-- Moved to Utils.Session
-                | SessionNewStudyTerms | SessionConflictingStudyTerms
-                | SessionBearer
-                | SessionAllocationResults
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-instance Universe SessionKey
-instance Finite SessionKey
 
-nullaryPathPiece ''SessionKey $ camelToPathPiece' 1
+-------------
-
+-- Cookies --
-setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
+-------------
-setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
+  
-
+-- Moved to Utils.Cookies.Registered
-lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
-lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key
-
-modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m ()
-modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f
-
-tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Semigroup v) => k -> v -> m ()
-tellSessionJson key val = modifySessionJson key (`mappend` Just val)
-
-takeSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
--- ^ `lookupSessionJson` followed by `deleteSession`
-takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
 
 --------------------
 -- GET Parameters --
@@ -1040,3 +1033,58 @@ mpreview = hoistMaybe <=< preview
 
 mpreviews :: (MonadPlus m, MonadReader s m) => Getting (First b) s a -> (a -> b) -> m b
 mpreviews a f = hoistMaybe =<< previews a f
+
+-------------
+-- HashMap --
+-------------
+
+newtype MergeHashMap k v = MergeHashMap { unMergeHashMap :: HashMap k v }
+  deriving (Show, Generic, Typeable, Data)
+  deriving newtype ( Eq, Ord, Hashable
+                   , Functor, Foldable, NFData
+                   , ToJSON
+                   )
+
+makePrisms ''MergeHashMap
+makeWrapped ''MergeHashMap
+
+instance Traversable (MergeHashMap k) where
+  traverse = _MergeHashMap . traverse
+
+instance FunctorWithIndex k (MergeHashMap k)
+instance TraversableWithIndex k (MergeHashMap k) where
+  itraverse = _MergeHashMap .> itraverse
+instance FoldableWithIndex k (MergeHashMap k)
+
+instance (Eq k, Hashable k, Semigroup v) => Semigroup (MergeHashMap k v) where
+  (MergeHashMap a) <> (MergeHashMap b) = MergeHashMap $ HashMap.unionWith (<>) a b
+instance (Eq k, Hashable k, Semigroup v) => Monoid (MergeHashMap k v) where
+  mempty = MergeHashMap HashMap.empty
+instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeHashMap k v) where
+  parseJSON = case Aeson.fromJSONKey of
+      Aeson.FromJSONKeyCoerce _ -> Aeson.withObject "HashMap ~Text" $
+          uc . HashMap.traverseWithKey (\k v -> parseJSON v Aeson.<?> Aeson.Key k)
+      Aeson.FromJSONKeyText f -> Aeson.withObject "HashMap" $
+          fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) (f k) <$> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
+      Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
+          fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
+      Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
+          fmap (MergeHashMap . HashMap.fromListWith (<>)) . sequence .
+              zipWith (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
+    where
+      uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
+      uc = unsafeCoerce
+
+      parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
+      parseIndexedJSONPair keyParser valParser idx value = p value Aeson.<?> Aeson.Index idx
+        where
+          p = Aeson.withArray "(k, v)" $ \ab ->
+              let n = V.length ab
+              in if n == 2
+                   then (,) <$> parseJSONElemAtIndex keyParser 0 ab
+                            <*> parseJSONElemAtIndex valParser 1 ab
+                   else fail $ "cannot unpack array of length " ++
+                               show n ++ " into a pair"
+
+      parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
+      parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx

src/Utils/Cookies.hs

@@ -0,0 +1,27 @@
+module Utils.Cookies
+  ( getCookiePath
+  , siteApproot
+  , cookiePath
+  ) where
+
+import ClassyPrelude.Yesod
+
+import qualified Network.Wai as Wai
+
+
+cookiePath :: Maybe Text -> ByteString
+cookiePath = maybe "/" $ extractPath . encodeUtf8
+
+siteApproot :: Yesod site => site -> Wai.Request -> Maybe Text
+siteApproot master req = case approot of
+  ApprootRelative   -> Nothing
+  ApprootStatic   t -> Just t
+  ApprootMaster   f -> Just $ f master
+  ApprootRequest  f -> Just $ f master req
+
+getCookiePath :: (MonadHandler m, Yesod (HandlerSite m)) => m ByteString
+getCookiePath = do
+  app <- getYesod
+  req <- reqWaiRequest <$> getRequest
+
+  return . cookiePath $ siteApproot app req

src/Utils/Cookies/Registered.hs

@@ -0,0 +1,133 @@
+module Utils.Cookies.Registered
+  ( RegisteredCookie(..)
+  , lookupRegisteredCookie, lookupRegisteredCookies
+  , lookupRegisteredCookieJson, lookupRegisteredCookiesJson
+  , setRegisteredCookie, setRegisteredCookie'
+  , setRegisteredCookieJson, setRegisteredCookieJson'
+  , modifyRegisteredCookieJson, modifyRegisteredCookieJson'
+  , tellRegisteredCookieJson, tellRegisteredCookieJson'
+  , deleteRegisteredCookie, deleteRegisteredCookie'
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Settings.Cookies
+
+import Utils.Cookies
+import Utils.PathPiece
+
+import Data.Universe
+import Control.Lens
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Text as Aeson
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.ByteString.Base64.URL as Base64
+
+import Web.Cookie (SetCookie(..))
+
+import Data.Char (isAscii)
+import Data.Monoid (Last(..))
+
+
+data RegisteredCookie = CookieSession | CookieXSRFToken | CookieLang | CookieSystemMessageState
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite, Hashable)
+
+nullaryPathPiece ''RegisteredCookie $ toUpper . camelToPathPiece' 1
+pathPieceJSON ''RegisteredCookie
+pathPieceJSONKey ''RegisteredCookie
+
+
+_CookieEncoded :: Prism' Text Text
+_CookieEncoded = prism' cEncode cDecode
+  where
+    b64Prefix = "base64url:"
+    
+    cDecode t
+      | Just encoded <- Text.stripPrefix b64Prefix t
+      = either (const Nothing) Just . Text.decodeUtf8' <=< either (const Nothing) Just . Base64.decode $ Text.encodeUtf8 encoded
+      | Text.all isAscii t = Just t
+      | otherwise = Nothing
+
+    cEncode t
+      | Text.all isAscii t
+      , not $ b64Prefix `Text.isPrefixOf` t
+      = t
+      | otherwise
+      = b64Prefix <> Text.decodeUtf8 (Base64.encode $ Text.encodeUtf8 t)
+
+newtype RegisteredCookieCurrentValue = RegisteredCookieCurrentValue { getRegisteredCookieCurrentValue :: Maybe Text }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  
+
+-- Primitive
+setRegisteredCookie' :: (Textual t, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> t -> m ()
+setRegisteredCookie' modSet ident@(toPathPiece -> name) (review _CookieEncoded . repack -> content) = do
+  path <- getCookiePath
+  defSetCookie <- cookieSettingsToSetCookie . ($ ident) =<< getsYesod getCookieSettings
+  
+  setCookie $ modSet defSetCookie
+    { setCookieName     = Text.encodeUtf8 name
+    , setCookieValue    = Text.encodeUtf8 content
+    , setCookiePath     = Just path
+    }
+
+  cacheBySet (Text.encodeUtf8 name) . RegisteredCookieCurrentValue $ Just content
+
+setRegisteredCookie :: (Textual t, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => RegisteredCookie -> t -> m ()
+setRegisteredCookie = setRegisteredCookie' id
+
+setRegisteredCookieJson' :: (ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> v -> m ()
+setRegisteredCookieJson' modSet name = setRegisteredCookie' modSet name . Aeson.encodeToLazyText
+
+setRegisteredCookieJson :: (ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => RegisteredCookie -> v -> m ()
+setRegisteredCookieJson = setRegisteredCookieJson' id
+
+modifyRegisteredCookieJson' :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> ([v] -> Maybe v) -> m ()
+modifyRegisteredCookieJson' modSet name modVal = lookupRegisteredCookiesJson pure name >>= maybe deleteRegisteredCookie'' (setRegisteredCookieJson' modSet name) . modVal
+  where deleteRegisteredCookie'' = do
+          path <- getCookiePath
+          let cookieSettings = modSet def{ setCookiePath = Just path }
+          deleteRegisteredCookie' name . maybe "/" Text.decodeUtf8 $ setCookiePath cookieSettings
+
+modifyRegisteredCookieJson :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => RegisteredCookie -> ([v] -> Maybe v) -> m ()
+modifyRegisteredCookieJson = modifyRegisteredCookieJson' id
+
+tellRegisteredCookieJson' :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m), Monoid v) => (SetCookie -> SetCookie) -> RegisteredCookie -> v -> m ()
+tellRegisteredCookieJson' modSet name x = modifyRegisteredCookieJson' modSet name $ pure . (<> x) . fold
+
+tellRegisteredCookieJson :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m), Monoid v) => RegisteredCookie -> v -> m ()
+tellRegisteredCookieJson = tellRegisteredCookieJson' id
+
+-- Primitive
+deleteRegisteredCookie' :: MonadHandler m
+                        => RegisteredCookie -- ^ key
+                        -> Text -- ^ path
+                        -> m ()
+deleteRegisteredCookie' (toPathPiece -> name) path = do
+  deleteCookie name path
+  cacheBySet (Text.encodeUtf8 name) $ RegisteredCookieCurrentValue Nothing
+
+deleteRegisteredCookie :: (MonadHandler m, Yesod (HandlerSite m)) => RegisteredCookie -> m ()
+deleteRegisteredCookie name = deleteRegisteredCookie' name . Text.decodeUtf8 =<< getCookiePath
+
+-- Primitive
+lookupRegisteredCookies :: (Textual t, Monoid m, MonadHandler f) => (t -> m) -> RegisteredCookie -> f m 
+lookupRegisteredCookies toM (toPathPiece -> name) = do
+  cachedVal <- cacheByGet (Text.encodeUtf8 name)
+  case cachedVal of
+    Nothing
+      -> foldMap (toM . repack) . mapMaybe (preview _CookieEncoded) <$> lookupCookies name
+    Just (RegisteredCookieCurrentValue v)
+      -> return . maybe mempty (toM . repack) $ v ^? _Just . _CookieEncoded
+
+lookupRegisteredCookie :: (Textual t, MonadHandler m) => RegisteredCookie -> m (Maybe t)
+lookupRegisteredCookie = fmap getLast . lookupRegisteredCookies pure
+
+lookupRegisteredCookiesJson :: (FromJSON v, Monoid m, MonadHandler f) => (v -> m) -> RegisteredCookie -> f m
+lookupRegisteredCookiesJson toM = fmap (fromMaybe mempty) . lookupRegisteredCookies (fmap toM . Aeson.decodeStrict' . Text.encodeUtf8)
+
+lookupRegisteredCookieJson :: (FromJSON v, MonadHandler m) => RegisteredCookie -> m (Maybe v)
+lookupRegisteredCookieJson = fmap getLast . lookupRegisteredCookiesJson pure

src/Utils/DB.hs

@@ -68,6 +68,10 @@ 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)
+             => Key record -> ReaderT backend m ()
+existsKey404 = bool (return ()) notFound <=< existsKey
+
 updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
          => Unique record -> [Update record] -> ReaderT backend m ()
 updateBy uniq updates = do

src/Utils/Lang.hs

@@ -2,6 +2,10 @@ module Utils.Lang where
 
 import ClassyPrelude.Yesod
 
+import Utils.Cookies.Registered
+import Utils.Parameters
+import Utils.Session
+
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
 
@@ -55,9 +59,9 @@ matchesFor = mapMaybe (\frags -> Text.intercalate "-" frags <$ guard (not $ null
 
 highPrioRequestedLangs, lowPrioRequestedLangs :: forall m. MonadHandler m => m [Lang]
 highPrioRequestedLangs = fmap (concatMap $ fromMaybe []) . mapM runMaybeT $
-  [ lookupGetParams "_LANG"
+  [ lookupGlobalGetParams GetLang
-  , lookupCookies "_LANG"
+  , lookupRegisteredCookies pure CookieLang
-  , fmap pure . MaybeT $ lookupSession "_LANG"
+  , fmap pure . MaybeT $ lookupSessionKey SessionLang
   ]
 lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader "Accept-Language"
 

src/Utils/Parameters.hs

@@ -21,12 +21,13 @@ import Data.Universe
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
-data GlobalGetParam = GetReferer | GetBearer | GetRecipient | GetCsvExampleData
+data GlobalGetParam = GetLang | GetReferer | GetBearer | GetRecipient | GetCsvExampleData
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving anyclass (Universe, Finite)
 
-instance Universe GlobalGetParam
+nullaryPathPiece' ''GlobalGetParam $ \n -> if
-instance Finite GlobalGetParam
+  | n == 'GetLang -> "_LANG"
-nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
+  | otherwise     -> nameToPathPiece' 1 n
 
 lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result)
 lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident)
@@ -62,9 +63,8 @@ data GlobalPostParam = PostFormIdentifier
                      | PostExamAutoOccurrencePrevious
                      | PostLanguage
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving anyclass (Universe, Finite)
 
-instance Universe GlobalPostParam
-instance Finite GlobalPostParam
 nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
 
 lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)

src/Utils/PathPiece.hs

@@ -1,8 +1,9 @@
 module Utils.PathPiece
-  ( nullaryToPathPiece
+  ( nullaryToPathPiece', nullaryToPathPiece
-  , nullaryPathPiece, finitePathPiece
+  , nullaryPathPiece', nullaryPathPiece, finitePathPiece
   , splitCamel
   , camelToPathPiece, camelToPathPiece'
+  , nameToPathPiece, nameToPathPiece'
   , tuplePathPiece
   , pathPieceJSON, pathPieceJSONKey
   ) where
@@ -43,27 +44,33 @@ mkFiniteFromPathPiece finiteType = do
       ]
   (,) <$> decs <*> [e|flip HashMap.lookup $(varE mapName)|]
 
-nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ
+nullaryToPathPiece' :: Name -> (Name -> Text) -> ExpQ
-nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do
+nullaryToPathPiece' nullaryType mangle = do
   TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType
   helperName <- newName "helper"
   let
-    toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift . mangle $ nameBase cName) []
+    toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift $ mangle cName) []
     toClause con = fail $ "Unsupported constructor: " ++ show con
     helperDec = funD helperName $ map toClause constructors
   letE [helperDec] $ varE helperName
 
-nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ
+nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ
-nullaryPathPiece nullaryType mangle = do
+nullaryToPathPiece nullaryType = nullaryToPathPiece' nullaryType . flip (.) (Text.pack . nameBase)
+
+nullaryPathPiece' :: Name -> (Name -> Text) -> DecsQ
+nullaryPathPiece' nullaryType mangle = do
   (finDecs, finExp) <- mkFiniteFromPathPiece nullaryType
   sequence . (map return finDecs ++) . pure $
     instanceD (cxt []) [t|PathPiece $(conT nullaryType)|]
       [ funD 'toPathPiece
-        [ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ]
+        [ clause [] (normalB $ nullaryToPathPiece' nullaryType mangle) [] ]
       , funD 'fromPathPiece
         [ clause [] (normalB $ return finExp) [] ]
       ]
 
+nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ
+nullaryPathPiece nullaryType = nullaryPathPiece' nullaryType . flip (.) (Text.pack . nameBase)
+
 finitePathPiece :: Name -> [Text] -> DecsQ
 finitePathPiece finiteType verbs = do
   (finDecs, finExp) <- mkFiniteFromPathPiece finiteType
@@ -99,6 +106,12 @@ camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dro
 camelToPathPiece :: Textual t => t -> t
 camelToPathPiece = camelToPathPiece' 0
 
+nameToPathPiece' :: Textual t => Natural -> Name -> t
+nameToPathPiece' dropN = camelToPathPiece' dropN . repack . nameBase
+
+nameToPathPiece :: Textual t => Name -> t
+nameToPathPiece = nameToPathPiece' 0
+
 
 tuplePathPiece :: Int -> DecQ
 tuplePathPiece tupleDim = do

src/Utils/Session.hs

@@ -0,0 +1,53 @@
+module Utils.Session where
+
+import ClassyPrelude.Yesod
+
+import Utils.PathPiece
+
+import Data.Universe
+
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as LBS
+
+
+data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
+                | SessionNewStudyTerms | SessionConflictingStudyTerms
+                | SessionBearer
+                | SessionAllocationResults
+                | SessionLang
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''SessionKey $ camelToPathPiece' 1
+
+setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
+setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
+
+lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
+lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key
+
+modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m ()
+modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f
+
+tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Semigroup v) => k -> v -> m ()
+tellSessionJson key val = modifySessionJson key (`mappend` Just val)
+
+takeSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
+-- ^ `lookupSessionJson` followed by `deleteSession`
+takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
+
+
+lookupSessionKey :: MonadHandler m => SessionKey -> m (Maybe Text)
+lookupSessionKey = lookupSession . toPathPiece
+
+lookupSessionKeyBS :: MonadHandler m => SessionKey -> m (Maybe ByteString)
+lookupSessionKeyBS = lookupSessionBS . toPathPiece
+
+setSessionKey :: MonadHandler m => SessionKey -> Text -> m ()
+setSessionKey = setSession . toPathPiece
+
+setSessionKeyBS :: MonadHandler m => SessionKey -> ByteString -> m ()
+setSessionKeyBS = setSessionBS . toPathPiece
+
+deleteSessionKey :: MonadHandler m => SessionKey -> m ()
+deleteSessionKey = deleteSession . toPathPiece

src/Utils/SystemMessage.hs

@@ -29,3 +29,23 @@ systemMessageToTranslation systemMessageTranslationMessage (SystemMessage{..}, N
       , systemMessageTranslationSummary  = systemMessageSummary
       }
 systemMessageToTranslation _ (_, Just t) = t
+
+
+
+data UserSystemMessageState = UserSystemMessageState
+  { userSystemMessageShown
+  , userSystemMessageHidden :: Maybe UTCTime
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 3
+  , omitNothingFields  = True
+  } ''UserSystemMessageState
+
+instance Semigroup UserSystemMessageState where
+  a <> b = UserSystemMessageState
+    { userSystemMessageShown  = (max `on` userSystemMessageShown ) a b
+    , userSystemMessageHidden = (max `on` userSystemMessageHidden) a b
+    }
+instance Monoid UserSystemMessageState where
+  mempty = UserSystemMessageState Nothing Nothing

src/Utils/Tokens.hs

@@ -14,7 +14,6 @@ import Model
 import Model.Tokens
 
 import Jose.Jwk (JwkSet(..))
-import Jose.Jwt (Jwt(..))
 import qualified Jose.Jwt as Jose
 
 import Data.Aeson.Types (Parser)

src/Web/Cookie/Instances.hs

@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Web.Cookie.Instances
+  () where
+
+import ClassyPrelude
+import Web.Cookie
+
+import qualified Data.ByteString.Builder as BS
+
+
+instance Hashable SameSiteOption where
+  hashWithSalt s opt = hashWithSalt s . BS.toLazyByteString $ renderSetCookie def{ setCookieSameSite = Just opt }

src/Web/ServerSession/Frontend/Yesod/Jwt.hs

@@ -18,8 +18,7 @@ import Model.Types.Common
 
 import Model.Tokens.Session
 
-import Jose.Jwk (JwkSet)
+import Jose.Jwt (JwtEncoding(..))
-import Jose.Jwt (Jwt(..), JwtEncoding(..))
 import qualified Jose.Jwt as Jose
 import qualified Jose.Jwk as Jose
 
@@ -87,13 +86,6 @@ backend jwtCfg getApprootText' state = pure $ Just SessionBackend{..}
           approot' = getApprootText' req
 
       return (sessionData, save)
-
-siteApproot :: Yesod site => site -> Wai.Request -> Maybe Text
-siteApproot master req = case approot of
-  ApprootRelative   -> Nothing
-  ApprootStatic   t -> Just t
-  ApprootMaster   f -> Just $ f master
-  ApprootRequest  f -> Just $ f master req
       
 findSession :: State sto
             -> Wai.Request
@@ -138,9 +130,6 @@ createCookie state approot' session (Jwt payload) = AddCookie def
   , setCookieSecure   = getSecureCookies state
   }
 
-cookiePath :: Maybe Text -> ByteString
-cookiePath = maybe "/" $ extractPath . encodeUtf8
-
   
 decodeSession :: ( MonadThrow m
                  , MonadIO m

start.sh

@@ -12,6 +12,7 @@ export LOGLEVEL=${LOGLEVEL:-info}
 export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
 export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
 export SERVER_SESSION_COOKIES_SECURE=${SERVER_SESSION_COOKIES_SECURE:-false}
+export COOKIES_SECURE=${COOKIES_SECURE:-false}
 export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
 export RIBBON=${RIBBON:-${__HOST:-localhost}}
 unset HOST

test/Database/Fill.hs

@@ -894,12 +894,72 @@ fillDb = do
   void . insert' $ Lecturer gkleen dbs CourseLecturer
   void . insert' $ Lecturer jost   dbs CourseAssistant
 
-  testMsg <- insert $ SystemMessage False (Just now) Nothing False Success "de" "System-Nachrichten werden angezeigt" Nothing
+  testMsg <- insert SystemMessage
+    { systemMessageNewsOnly = False
+    , systemMessageFrom = Just now
+    , systemMessageTo = Nothing
+    , systemMessageAuthenticatedOnly = False
+    , systemMessageSeverity = Success
+    , systemMessageDefaultLanguage = "de"
+    , systemMessageContent = "System-Nachrichten werden angezeigt"
+    , systemMessageSummary = Nothing
+    , systemMessageCreated = now
+    , systemMessageLastChanged = now
+    , systemMessageLastUnhide = now
+    }
   void . insert $ SystemMessageTranslation testMsg "en" "System messages may be translated" 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
-  void . insert $ SystemMessage False (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing
+    { systemMessageNewsOnly = False
-  void . insert $ SystemMessage False Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing
+    , systemMessageFrom = Just now
-  void . insert $ SystemMessage True (Just now) Nothing False Error "de" "System-Nachrichten können nur auf \"Aktuelles\" angezeigt werden" Nothing
+    , systemMessageTo = Nothing
+    , systemMessageAuthenticatedOnly = False
+    , systemMessageSeverity = Info
+    , systemMessageDefaultLanguage = "de"
+    , systemMessageContent = "System-Nachrichten können längeren Inhalt enthalten"
+    , systemMessageSummary = Just "System-Nachricht Zusammenfassung"
+    , systemMessageCreated = now
+    , systemMessageLastChanged = now
+    , systemMessageLastUnhide = now
+    }
+  void $ insert SystemMessage
+    { systemMessageNewsOnly = False
+    , systemMessageFrom = Just now
+    , systemMessageTo = Just now
+    , systemMessageAuthenticatedOnly = False
+    , systemMessageSeverity = Info
+    , systemMessageDefaultLanguage = "de"
+    , systemMessageContent = "System-Nachrichten haben Ablaufdaten"
+    , systemMessageSummary = Nothing
+    , systemMessageCreated = now
+    , systemMessageLastChanged = now
+    , systemMessageLastUnhide = now
+    }
+  void $ insert SystemMessage
+    { systemMessageNewsOnly = False
+    , systemMessageFrom = Nothing
+    , systemMessageTo = Nothing
+    , systemMessageAuthenticatedOnly = False
+    , systemMessageSeverity = Error
+    , systemMessageDefaultLanguage = "de"
+    , systemMessageContent = "System-Nachrichten können Inaktiv sein"
+    , systemMessageSummary = Nothing
+    , systemMessageCreated = now
+    , systemMessageLastChanged = now
+    , systemMessageLastUnhide = now
+    }
+  void $ insert SystemMessage
+    { systemMessageNewsOnly = True
+    , systemMessageFrom = Just now
+    , systemMessageTo = Nothing
+    , systemMessageAuthenticatedOnly = False
+    , systemMessageSeverity = Error
+    , systemMessageDefaultLanguage = "de"
+    , systemMessageContent = "System-Nachrichten können nur auf \"Aktuelles\" angezeigt werden"
+    , systemMessageSummary = Nothing
+    , systemMessageCreated = now
+    , systemMessageLastChanged = now
+    , systemMessageLastUnhide = now
+    }
 
 
   funAlloc <- insert' Allocation