diff --git a/config/settings.yml b/config/settings.yml index 449757de4..80eae5bb0 100644 --- 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: 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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 26d14e41a..799fc17d7 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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} diff --git a/models/system-messages.model b/models/system-messages.model index 7722e9b85..32703fd40 100644 --- 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 \ No newline at end of file diff --git a/routes b/routes index fcd3c05b0..12f4c788b 100644 --- a/routes +++ b/routes @@ -222,8 +222,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 !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists diff --git a/src/Application.hs b/src/Application.hs index 918495cc6..3be9cf038 100644 --- 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 @@ -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 diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index 2e410080e..fa152557f 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index d5a01d22d..9aa6498e7 100644 --- a/src/Foundation.hs +++ b/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) - _ <- 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 @@ -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 diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index fc8c802ae..ade7a5faa 100644 --- 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' diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs index 0e3d595e4..90b6003d4 100644 --- a/src/Handler/Admin/Tokens.hs +++ b/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 diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 19f579046..6929a6249 100644 --- a/src/Handler/News.hs +++ b/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.filter (\(SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo) + .| C.mapMaybeM (\smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId) + .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo) + .| C.iterM (\(smId, _, _) -> tellShown smId) + .| C.map ((,) <$> view _2 <*> view _3) .| C.consume - let messages = sortOn (\(SystemMessage{..}, _) -> (NTop systemMessageFrom, systemMessageSeverity)) messages' + let messages = sortOn (\(SystemMessage{..}, _) -> (Down systemMessageLastChanged, systemMessageSeverity)) messages' unless (null messages) $(widgetFile "news/system-messages") diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index c82faa5b0..c335f2331 100644 --- a/src/Handler/SystemMessage.hs +++ b/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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index f43384eac..3be594c33 100644 --- a/src/Handler/Term.hs +++ b/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 - { tftName = tftName left <|> tftName right - , tftStart = tftStart left <|> tftStart right - , tftEnd = tftEnd left <|> tftEnd right - , tftHolidays = tftHolidays left <|> tftHolidays right - , tftLectureStart = tftLectureStart left <|> tftLectureStart right - , tftLectureEnd = tftLectureEnd left <|> tftLectureEnd right - , tftActive = tftActive left <|> tftActive right + l <> r = TermFormTemplate + { tftName = tftName l <|> tftName r + , tftStart = tftStart l <|> tftStart r + , tftEnd = tftEnd l <|> tftEnd r + , tftHolidays = tftHolidays l <|> tftHolidays r + , tftLectureStart = tftLectureStart l <|> tftLectureStart r + , tftLectureEnd = tftLectureEnd l <|> tftLectureEnd r + , tftActive = tftActive l <|> tftActive r } instance Monoid TermFormTemplate where diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 723c699db..044838cd3 100644 --- a/src/Import/NoModel.hs +++ b/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)) diff --git a/src/Settings.hs b/src/Settings.hs index 88c7c8e8d..87b638b92 100644 --- 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 @@ -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" - 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 = 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{..} diff --git a/src/Settings/Cookies.hs b/src/Settings/Cookies.hs new file mode 100644 index 000000000..c0cce32de --- /dev/null +++ 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 + } diff --git a/src/Utils.hs b/src/Utils.hs index f8879cf98..c69b4cde9 100644 --- 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 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 - | 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 -- @@ -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 diff --git a/src/Utils/Cookies.hs b/src/Utils/Cookies.hs new file mode 100644 index 000000000..1d96e43e4 --- /dev/null +++ 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 diff --git a/src/Utils/Cookies/Registered.hs b/src/Utils/Cookies/Registered.hs new file mode 100644 index 000000000..e94afb763 --- /dev/null +++ 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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index fffdc8c51..150a5c1f6 100644 --- a/src/Utils/DB.hs +++ b/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 diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs index d99c909b3..7b1f069b5 100644 --- 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" diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index b92d2431f..5d2018391 100644 --- 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) diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 1f75de545..7485d2e4b 100644 --- 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 diff --git a/src/Utils/Session.hs b/src/Utils/Session.hs new file mode 100644 index 000000000..c4418d0ae --- /dev/null +++ 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 diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs index 713e2dd93..619dc765f 100644 --- a/src/Utils/SystemMessage.hs +++ b/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 diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index f290261fc..2a23db3b9 100644 --- a/src/Utils/Tokens.hs +++ b/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) diff --git a/src/Web/Cookie/Instances.hs b/src/Web/Cookie/Instances.hs new file mode 100644 index 000000000..c4f8505dd --- /dev/null +++ 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 } diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs index 29c5e081b..e4297a510 100644 --- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs +++ b/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 (Jwt(..), JwtEncoding(..)) +import Jose.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 diff --git a/start.sh b/start.sh index 2c3bafbff..51ffc6340 100755 --- 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 diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 1e848143d..c5bb8786c 100644 --- 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