Merge branch 'master' into formatting-apis

2020-04-15 13:43:05 +02:00 · 2020-04-15 13:43:05 +02:00 · 61cf85f3f9
commit 61cf85f3f9
parent 2856edca58 7018196bc7
39 changed files with 972 additions and 157 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -2,6 +2,27 @@

 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.

+## [15.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.6.0...v15.0.0) (2020-04-15)
+
+
+### Bug Fixes
+
+* **allocations:** better handle participants without applications ([05d37fb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/05d37fb))
+* bump changelog & translate ([a75f3eb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a75f3eb))
+
+
+### Features
+
+* **system-messages:** hiding ([c81bc23](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c81bc23))
+* **system-messages:** refactor cookies & improve system messages ([ead6015](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ead6015))
+
+
+### BREAKING CHANGES
+
+* **system-messages:** names of cookies & configuration changed
+
+
+
 ## [14.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.5.0...v14.6.0) (2020-04-09)


--- a/config/settings.yml
+++ b/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: lax
+
+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"

 external-apis-ping-interval: 300
 external-apis-pong-timeout: 600
--- 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
@ -1279,6 +1299,15 @@ code
  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
--- 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

@ -1065,6 +1070,14 @@ 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
+SystemMessageLastChangedAt time@Text: Zuletzt geändert: #{time}
+SystemMessageLastUnhide: Zuletzt un-versteckt
 SystemMessageFrom: Sichtbar ab
 SystemMessageTo: Sichtbar bis
 SystemMessageAuthenticatedOnly: Nur angemeldet
@ -1300,6 +1313,7 @@ BreadcrumbAllocationAccept: Platzvergabe akzeptieren
 BreadcrumbExternalApis: Externe APIs
 BreadcrumbApiDocs: API Dokumentation
 BreadcrumbSwagger: OpenAPI 2.0 (Swagger)
+BreadcrumbMessageHide: Verstecken

 ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
 ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@ -34,6 +34,8 @@ BtnCorrInvDecline: Decline
 BtnSubmissionsAssign: Assign submissions automatically
 BtnAllocationCompute: Compute allocation
 BtnAllocationAccept: Accept allocation
+BtnSystemMessageHide: Hide
+BtnSystemMessageUnhide: Unhide


 Aborted: Aborted
@ -521,6 +523,9 @@ NewsOpenAllocations: Active central allocations
 NewsUpcomingSheets: Upcoming exercise sheets
 NewsUpcomingExams: Upcoming exams

+NewsHideHiddenSystemMessages: Don't show hidden news items
+NewsShowHiddenSystemMessages: Show hidden news items
+
 NumCourses num: #{num} #{pluralEN num "course" "courses"}
 CloseAlert: Close

@ -1064,6 +1069,14 @@ HelpSent: Your support request has been sent.
 InfoLecturerTitle: Information for lecturers

 SystemMessageNewsOnly: Only on "News"
+SystemMessageRecordChanged: Signifcant change
+SystemMessageRecordChangedTip: Should the "last changed"-timestamp be adjusted? News are sorted by "last changed" on "News". After a significant change news items are displayed once again as a popup in the bottom right.
+SystemMessageUnhide: Ignore previously hidden
+SystemMessageUnhideTip: Should the news item be display again for users that have actively hidden it?
+SystemMessageCreated: Created
+SystemMessageLastChanged: Last changed
+SystemMessageLastChangedAt time: Last changed: #{time}
+SystemMessageLastUnhide: Last unhidden
 SystemMessageFrom: Visible from
 SystemMessageTo: Visible to
 SystemMessageAuthenticatedOnly: Only logged in users
@ -1297,6 +1310,7 @@ BreadcrumbAllocationCompute: Compute allocation
 BreadcrumbAllocationAccept: Accept allocation
 BreadcrumbExternalApis: External APIs
 BreadcrumbSwagger: API documentation
+BreadcrumbMessageHide: Hide

 ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn}
 ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn}
--- a/models/system-messages.model
+++ b/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
--- a/package-lock.json
+++ b/package-lock.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "14.6.0",
+  "version": "15.0.0",
  "lockfileVersion": 1,
  "requires": true,
  "dependencies": {
--- a/package.json
+++ b/package.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "14.6.0",
+  "version": "15.0.0",
  "description": "",
  "keywords": [],
  "author": "",
--- a/package.yaml
+++ b/package.yaml
@ -1,5 +1,5 @@
 name:    uniworx
-version: 14.6.0
+version: 15.0.0

 dependencies:
  - base
--- a/5
+++ b/5
@ -224,8 +224,9 @@
 /subs/download CorrectionsDownloadR  GET      !corrector !lecturer


-/msgs                           MessageListR GET POST
-/msg/#{CryptoUUIDSystemMessage} MessageR      GET POST        !timeANDreadANDauthentication
+/msgs                                MessageListR  GET POST
+/msg/#{CryptoUUIDSystemMessage}      MessageR      GET POST        !timeANDreadANDauthentication
+/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
--- a/src/Application.hs
+++ b/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

@ -327,7 +331,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
--- a/src/Data/Time/Clock/Instances.hs
+++ b/src/Data/Time/Clock/Instances.hs
@ -27,6 +27,9 @@ import qualified Language.Haskell.TH.Syntax as TH
 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
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@ -24,7 +24,7 @@ import Auth.Dummy

 import qualified Network.Wai as W
 import qualified Network.HTTP.Types.Header as W
-import qualified Network.Wai.Middleware.HttpAuth as W
+import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)

 import Yesod.Core.Types (HandlerContents)
 import qualified Yesod.Core.Unsafe as Unsafe
@ -48,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
@ -102,6 +101,8 @@ import UnliftIO.Pool
 import qualified Web.ServerSession.Core as ServerSession
 import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession

+import Web.Cookie
+
 -- | Convenient Type Synonyms:
 type DB = YesodDB UniWorX
 type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget)
@ -768,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
@ -1265,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)
@ -1481,11 +1496,11 @@ 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
@ -1553,7 +1568,12 @@ instance Yesod UniWorX where
          hasBearer <- is _Just <$> lookupBearerAuth

          if | hasBearer -> handler
-             | otherwise -> defaultCsrfMiddleware 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
@ -1966,12 +1986,57 @@ siteLayout' headingOverride widget = do
  withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")


-applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
-applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
+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 . 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
-      
+
      cID <- encrypt smId
      void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False

@ -1979,9 +2044,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)
-      _ <- assertM isNothing $ lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())
-      setSessionJson sessionKey ()
+      UserSystemMessageState{..} <- lift $ getSystemMessageState smId
+      guard $ userSystemMessageShown <= Just systemMessageLastChanged
+      guard $ userSystemMessageHidden <= Just systemMessageLastUnhide

      (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
      let
@ -1993,6 +2058,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
@ -2259,6 +2327,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

@ -4614,16 +4683,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) $
@ -4633,7 +4692,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
@ -4652,7 +4711,7 @@ updateUserLanguage Nothing = runMaybeT $ do
      -> return l
    (_, [], _)
      -> mzero
-  setLangCookie lang
+  setRegisteredCookie CookieLang lang
  return lang


--- a/src/Foundation/Type.hs
+++ b/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'
--- a/src/Handler/Allocation/Compute.hs
+++ b/src/Handler/Allocation/Compute.hs
@ -42,6 +42,7 @@ missingPrioritiesUsers aId = $cachedHereBinary aId $ do
    -- Ignore users without applications
    E.where_ . E.exists . E.from $ \courseApplication -> do
      E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
+           E.&&. courseApplication E.^. CourseApplicationUser E.==. user E.^. UserId
      E.where_ . E.exists . E.from $ \allocationCourse ->
        E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
             E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
--- a/src/Handler/Allocation/Prios.hs
+++ b/src/Handler/Allocation/Prios.hs
@ -66,7 +66,15 @@ postAPriosR tid ssh ash = do
        [ AllocationUserAllocation ==. aId ]
        [ AllocationUserPriority =. Nothing ]
      matrSunk <- runConduit $ sourcePrios .| sinkAllocationPriorities aId
-      matrMissing <- fromIntegral <$> count [ AllocationUserAllocation ==. aId, AllocationUserPriority ==. Nothing ]
+      matrMissing <- E.selectCountRows . E.from $ \allocationUser -> do
+        E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
+             E.&&. E.isNothing (allocationUser E.^. AllocationUserPriority)
+
+        E.where_ . E.exists . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do
+          E.on $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
+           E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
+          E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
+               E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
      return (matrSunk, matrMissing)

    when (matrSunk > 0) $ 
--- a/src/Handler/Allocation/Users.hs
+++ b/src/Handler/Allocation/Users.hs
@ -34,7 +34,9 @@ queryAllocationUser = to $(E.sqlIJproj 2 2)

 queryAppliedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
 queryAppliedCourses = queryAllocationUser . to queryAppliedCourses'
-  where queryAppliedCourses' allocationUser = E.subSelectCount . E.from $ \courseApplication ->
+  where queryAppliedCourses' allocationUser = E.subSelectCount . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do
+          E.on $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
+           E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
          E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
               E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation)

@ -46,7 +48,9 @@ queryAssignedCourses = queryAllocationUser . to queryAssignedCourses'

 queryVetoedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
 queryVetoedCourses = queryAllocationUser . to queryVetoedCourses'
-  where queryVetoedCourses' allocationUser = E.subSelectCount . E.from $ \courseApplication -> do
+  where queryVetoedCourses' allocationUser = E.subSelectCount . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do
+          E.on $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
+           E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
          E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
               E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation)
          E.where_ $ courseApplication E.^. CourseApplicationRatingVeto
--- 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,9 @@ 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


 getNewsR :: Handler Html
@ -35,16 +41,45 @@ getNewsR = do
 newsSystemMessages :: Widget
 newsSystemMessages = do
  now <- liftIO getCurrentTime
-  
-  messages' <- liftHandler . runDB . runConduit $
-       selectKeys [] []
-    .| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
-    .| C.mapMaybeM (\smId -> fmap (view _1 &&& systemMessageToTranslation smId) <$> getSystemMessage appLanguages smId)
-    .| C.filter (\(SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
-    .| C.consume
-  let messages = sortOn (\(SystemMessage{..}, _) -> (NTop systemMessageFrom, systemMessageSeverity)) messages'

-  unless (null messages)
+  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
+  
+        (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
+
+        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")


--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@ -1,14 +1,21 @@
-module Handler.SystemMessage where
+module Handler.SystemMessage
+  ( getMessageR, postMessageR
+  , getMessageListR, postMessageListR
+  , ButtonSystemMessageHide(..)
+  , 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

 import Handler.Utils
+import Handler.Utils.News

 import qualified Database.Esqueleto as E

@ -24,15 +31,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 +65,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 +175,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 +212,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 +276,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 +304,53 @@ postMessageListR = do

  defaultLayout
    $(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
+
+  ((btnRes, _), _) <- runFormPost buttonForm
+
+  formResult btnRes $ \case
+    BtnSystemMessageHide -> runDB $ do
+      existsKey404 smId
+
+      whenIsJust muid $ \uid -> void $
+        upsert SystemMessageHidden
+          { systemMessageHiddenMessage = smId
+          , systemMessageHiddenUser    = uid
+          , systemMessageHiddenTime    = now
+          }
+          [ SystemMessageHiddenTime =. now ]
+
+      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
--- a/src/Handler/Utils/News.hs
+++ 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
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@ -168,6 +168,7 @@ import Control.Monad.Trans.Except.Instances as Import ()
 import Servant.Server.Instances as Import ()
 import Network.URI.Instances as Import ()
 import Data.HashSet.Instances as Import ()
+import Web.Cookie.Instances as Import ()

 import Crypto.Hash as Import (Digest, SHA3_256)

--- a/src/Settings.hs
+++ b/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
-                                             ,(.!=), (.:?), withScientific
+import           Data.Aeson                  (fromJSON, withObject, 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
@ -159,13 +160,12 @@ data AppSettings = AppSettings
    , appExternalApisPongTimeout
    , appExternalApisExpiry :: NominalDiffTime

+    , 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 }
@ -281,9 +281,6 @@ data SmtpAuthConf = SmtpAuthConf
  , smtpAuthPassword :: HaskellNet.Password
  } deriving (Show)

-nullaryPathPiece ''SameSite $ camelToPathPiece' 2
-pathPieceJSON ''SameSite
-
 deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 2
  , fieldLabelModifier = camelToPathPiece' 2
@ -383,21 +380,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
      ])


@ -500,10 +491,16 @@ instance FromJSON AppSettings where

        appRibbon                 <- assertM (not . Text.null) . fmap Text.strip <$> o.:? "ribbon"

-        appServerSessionConfig    <- o .: "server-sessions"
-        appSessionTokenExpiration <- o .:? "session-token-expiration"
-        appSessionTokenEncoding   <- o .: "session-token-encoding"
-        appSessionSameSite        <- o .:? "session-samesite"
+        appCookieSettings         <- o .: "cookies"
+
+        appServerSessionConfig'    <- o .: "server-sessions"
+        let appServerSessionConfig = ServerSessionSettings $ httpOnlyCookie . secureCookie . applyServerSessionSettings appServerSessionConfig'
+              where httpOnlyCookie :: forall a. ServerSession.State a -> ServerSession.State a
+                    httpOnlyCookie = maybe id ServerSession.setHttpOnlyCookies . cookieHttpOnly $ appCookieSettings CookieSession
+                    secureCookie :: forall a. ServerSession.State a -> ServerSession.State a
+                    secureCookie = maybe id ServerSession.setSecureCookies . cookieSecure $ appCookieSettings CookieSession
+        appSessionTokenExpiration  <- o .:? "session-token-expiration"
+        appSessionTokenEncoding    <- o .: "session-token-encoding"

        appExternalApisPingInterval <- o .: "external-apis-ping-interval"
        appExternalApisPongTimeout <- o .: "external-apis-pong-timeout"
--- a/src/Settings/Cookies.hs
+++ b/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
+    }
--- a/src/Utils.hs
+++ b/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 qualified Data.Aeson.Encode.Pretty as Aeson
 import qualified Data.Yaml as Yaml

@ -94,10 +101,12 @@ import qualified System.Random.Shuffle as Rand (shuffleM)
 import Data.Data (Data)
 import qualified Data.Text.Lazy.Builder as Builder

+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 --
@ -808,31 +817,13 @@ choice = foldr (<|>) empty
 -- Sessions --
 --------------

-data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
-                | SessionNewStudyTerms | SessionConflictingStudyTerms
-                | SessionBearer
-                | SessionAllocationResults
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-instance Universe SessionKey
-instance Finite SessionKey
+-- Moved to Utils.Session

-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)
+-------------
+-- Cookies --
+-------------
+  
+-- Moved to Utils.Cookies.Registered

 --------------------
 -- GET Parameters --
@ -1077,3 +1068,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
--- a/src/Utils/Cookies.hs
+++ b/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
--- a/src/Utils/Cookies/Registered.hs
+++ b/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
--- 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,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, PersistQueryRead backend, MonadHandler m)
+             => Key record -> ReaderT backend m ()
+existsKey404 = bool notFound (return ()) <=< existsKey
+
 updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
         => Unique record -> [Update record] -> ReaderT backend m ()
 updateBy uniq updates = do
--- a/src/Utils/Lang.hs
+++ b/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"
-  , lookupCookies "_LANG"
-  , fmap pure . MaybeT $ lookupSession "_LANG"
+  [ lookupGlobalGetParams GetLang
+  , lookupRegisteredCookies pure CookieLang
+  , fmap pure . MaybeT $ lookupSessionKey SessionLang
  ]
 lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader "Accept-Language"

--- a/src/Utils/Parameters.hs
+++ b/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
-instance Finite GlobalGetParam
-nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
+nullaryPathPiece' ''GlobalGetParam $ \n -> if
+  | n == 'GetLang -> "_LANG"
+  | 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)
--- a/src/Utils/PathPiece.hs
+++ b/src/Utils/PathPiece.hs
@ -1,8 +1,9 @@
 module Utils.PathPiece
-  ( nullaryToPathPiece
-  , nullaryPathPiece, finitePathPiece
+  ( nullaryToPathPiece', nullaryToPathPiece
+  , 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 nullaryType ((. Text.pack) -> mangle) = do
+nullaryToPathPiece' :: Name -> (Name -> Text) -> ExpQ
+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
-nullaryPathPiece nullaryType mangle = do
+nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ
+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
--- a/src/Utils/Session.hs
+++ b/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
--- a/src/Utils/SystemMessage.hs
+++ b/src/Utils/SystemMessage.hs
@ -29,3 +29,25 @@ systemMessageToTranslation systemMessageTranslationMessage (SystemMessage{..}, N
      , systemMessageTranslationSummary  = systemMessageSummary
      }
 systemMessageToTranslation _ (_, Just t) = t
+
+
+
+data UserSystemMessageState = UserSystemMessageState
+  { userSystemMessageShown
+  , userSystemMessageHidden
+  , userSystemMessageUnhidden :: 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
+    , userSystemMessageUnhidden = (max `on` userSystemMessageUnhidden) a b
+    }
+instance Monoid UserSystemMessageState where
+  mempty = UserSystemMessageState Nothing Nothing Nothing
--- a/src/Web/Cookie/Instances.hs
+++ b/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 }
--- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs
+++ b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs
@ -86,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
@ -137,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
--- a/start.sh
+++ b/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
--- a/templates/i18n/changelog/de-de-formal.hamlet
+++ b/templates/i18n/changelog/de-de-formal.hamlet
@ -1,5 +1,19 @@
 $newline never
 <dl .deflist>
+  <dt .deflist__dt>
+    ^{formatGregorianW 2020 04 15}
+  <dd .deflist__dd>
+    <ul>
+      <li>
+        Verstecken von Systemnachrichten auf "Aktuelles"
+  
+  <dt .deflist__dt>
+    ^{formatGregorianW 2020 03 31}
+  <dd .deflist__dd>
+    <ul>
+      <li>
+        Spalte für Notizen bei Kursterminen
+
  <dt .deflist__dt>
    ^{formatGregorianW 2020 03 16}
  <dd .deflist__dd>
--- a/templates/i18n/changelog/en-eu.hamlet
+++ b/templates/i18n/changelog/en-eu.hamlet
@ -1,5 +1,19 @@
 $newline never
 <dl .deflist>
+  <dt .deflist__dt>
+    ^{formatGregorianW 2020 04 15}
+  <dd .deflist__dd>
+    <ul>
+      <li>
+        Hiding of system messages on "News"
+  
+  <dt .deflist__dt>
+    ^{formatGregorianW 2020 03 31}
+  <dd .deflist__dd>
+    <ul>
+      <li>
+        Column for adding notes to course events
+
  <dt .deflist__dt>
    ^{formatGregorianW 2020 03 16}
  <dd .deflist__dd>
--- a/templates/news/system-messages.hamlet
+++ b/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}
-        #{systemMessageTranslationContent}
+        <h2>
+          $if hidden
+            #{iconInvisible} #
+          #{summary}
+        <div .news__system-message-content>
+          #{systemMessageTranslationContent}
      $nothing
-        <h2>#{systemMessageTranslationContent}
+        <h2>
+          $if hidden
+            #{iconInvisible} #
+          #{systemMessageTranslationContent}
+      <div .news__system-message-detail>
+        _{MsgSystemMessageLastChangedAt time}, #
+        ^{hideForm}
+  $if anyHidden
+    <p .news__system-message-detail>
+      $if showHidden
+        <a href=@{NewsR}>
+          _{MsgNewsHideHiddenSystemMessages}
+      $else
+        <a href=#{hiddenUrl}>
+          _{MsgNewsShowHiddenSystemMessages}
+        
--- a/test/Database/Fill.hs
+++ b/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 False (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing
-  void . insert $ SystemMessage False Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing
-  void . insert $ SystemMessage True (Just now) Nothing False Error "de" "System-Nachrichten können nur auf \"Aktuelles\" angezeigt werden" Nothing
+  void $ insert SystemMessage
+    { systemMessageNewsOnly = False
+    , systemMessageFrom = Just now
+    , 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