diff --git a/CHANGELOG.md b/CHANGELOG.md index 085f42778..75d154464 100644 --- 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) diff --git a/config/settings.yml b/config/settings.yml index a54d04dab..cba3d0b2a 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: 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 diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 2d4edc109..9db733540 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -236,10 +236,10 @@ h4 margin-top: 20px // GENERAL BUTTON STYLES -input[type="submit"], -input[type="button"], -button, -.btn +input[type="submit"]:not(.btn-link), +input[type="button"]:not(.btn-link), +button:not(.btn-link), +.btn:not(.btn-link) font-family: var(--font-base) outline: 0 border: 0 @@ -272,39 +272,59 @@ button, display: grid grid: min-content / auto-flow 1fr -input[type="submit"][disabled], -input[type="button"][disabled], -button[disabled], -.btn[disabled] +input[type="submit"][disabled]:not(.btn-link), +input[type="button"][disabled]:not(.btn-link), +button[disabled]:not(.btn-link), +.btn[disabled]:not(.btn-link) opacity: 0.3 background-color: var(--color-grey) cursor: default -input[type="submit"]:not([disabled]):hover, -input[type="button"]:not([disabled]):hover, -button:not([disabled]):hover, -.btn:not([disabled]):hover +input[type="submit"]:not([disabled]):not(.btn-link):hover, +input[type="button"]:not([disabled]):not(.btn-link):hover, +button:not([disabled]):not(.btn-link):hover, +.btn:not([disabled]):not(.btn-link):hover background-color: var(--color-light) color: white &.btn-danger background-color: var(--color-error) -.btn-primary +.btn-primary:not(.btn-link) background-color: var(--color-primary) -.btn-info +.btn-info:not(.btn-link) background-color: var(--color-info) -.btn--small +.btn--small:not(.btn-link) padding: 4px 7px background-color: var(--color-darker) -input[type="submit"].btn-info:hover, -input[type="button"].btn-info:hover, -.btn-info:hover +input[type="submit"].btn-info:not(.btn-link):hover, +input[type="button"].btn-info:not(.btn-link):hover, +.btn-info:not(.btn-link):hover background-color: var(--color-grey) +.btn-link + font-family: var(--font-base) + outline: 0 + border: 0 + box-shadow: 0 + background: none + color: inherit + padding: 0 + min-width: unset + font-size: inherit + cursor: pointer + display: inline + text-decoration: underline + font-weight: 600 + font-style: inherit + transition: color .2s ease, background-color .2s ease + + &:not([disabled]):hover + color: var(--color-link-hover) + // GENERAL TABLE STYLES .table margin: 21px 0 @@ -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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 016f9240e..07b51fcbb 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -34,6 +34,8 @@ BtnCorrInvDecline: Ablehnen BtnSubmissionsAssign: Abgaben automatisch zuteilen BtnAllocationCompute: Vergabe berechnen BtnAllocationAccept: Vergabe akzeptieren +BtnSystemMessageHide: Verstecken +BtnSystemMessageUnhide: Nicht mehr verstecken Aborted: Abgebrochen @@ -523,6 +525,9 @@ NewsOpenAllocations: Offene Zentralanmeldungen NewsUpcomingSheets: Anstehende Übungsblätter NewsUpcomingExams: Bevorstehende Prüfungen +NewsHideHiddenSystemMessages: Versteckte Nachrichten nicht mehr anzeigen +NewsShowHiddenSystemMessages: Versteckte Nachrichten anzeigen + NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"} CloseAlert: Schliessen @@ -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} diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index acf440c53..b2c1518ea 100644 --- 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} diff --git a/models/system-messages.model b/models/system-messages.model index 7722e9b85..1ba853a41 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/package-lock.json b/package-lock.json index 7d9519f0a..81044247e 100644 --- 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": { diff --git a/package.json b/package.json index 2c13cfc2f..aa856a959 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "14.6.0", + "version": "15.0.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index b8331321c..2d6bcd419 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 14.6.0 +version: 15.0.0 dependencies: - base diff --git a/routes b/routes index df763fa73..1fce6bd12 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/Application.hs b/src/Application.hs index 77b2301e9..873115c89 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 @@ -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 diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index ad3e2cbf3..37749b2b0 100644 --- 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 diff --git a/src/Foundation.hs b/src/Foundation.hs index e992168e9..a29419aef 100644 --- 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 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/Allocation/Compute.hs b/src/Handler/Allocation/Compute.hs index b4b7041f2..b579c056e 100644 --- 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 diff --git a/src/Handler/Allocation/Prios.hs b/src/Handler/Allocation/Prios.hs index 9edc03250..ca4b4c499 100644 --- 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) $ diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index c44c10ad1..0cd22584e 100644 --- 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 diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 19f579046..f6d91519e 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -3,6 +3,9 @@ module Handler.News where import Import import Handler.Utils +import Handler.Utils.News + +import Handler.SystemMessage import qualified Data.Map as Map import Database.Esqueleto.Utils.TH @@ -11,6 +14,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") diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index c82faa5b0..555cda2df 100644 --- 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 diff --git a/src/Handler/Utils/News.hs b/src/Handler/Utils/News.hs new file mode 100644 index 000000000..f514aca75 --- /dev/null +++ b/src/Handler/Utils/News.hs @@ -0,0 +1,11 @@ +module Handler.Utils.News + ( NewsGetParam(..) + ) where + +import Import + + +data NewsGetParam = GetHidden + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) +nullaryPathPiece ''NewsGetParam $ camelToPathPiece' 1 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 2876eaf75..b4a4e5916 100644 --- 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) diff --git a/src/Settings.hs b/src/Settings.hs index 86702fc39..140d8c59d 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 @@ -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" 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 f04771074..4d4edd75b 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 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 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..5b514261b 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -56,9 +56,9 @@ existsBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity => Unique record -> ReaderT backend m () existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy -existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m) +existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m) => Key record -> ReaderT backend m Bool -existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record +existsKey = exists . pure . (persistIdField ==.) exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m Bool @@ -68,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 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..75d016c7e 100644 --- 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 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 22a90725f..e4297a510 100644 --- 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 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/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet index 5f1d9de9a..b403c1cf1 100644 --- a/templates/i18n/changelog/de-de-formal.hamlet +++ b/templates/i18n/changelog/de-de-formal.hamlet @@ -1,5 +1,19 @@ $newline never
+
+ ^{formatGregorianW 2020 04 15} +
+