fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
BREAKING CHANGE: names of cookies & configuration changed
This commit is contained in:
Gregor Kleen 2020-04-14 17:16:46 +02:00
parent b2512c2d98
commit ead6015dfe
29 changed files with 735 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
config/settings.yml
View File

@ -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

8
messages/uniworx/de-de-formal.msg
View File

@ -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}

11
models/system-messages.model
View File

@ -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

5
routes
View File

@ -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

34
src/Application.hs
View File

@ -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

3
src/Data/Time/Clock/Instances.hs
View File

@ -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

93
src/Foundation.hs
View File

@ -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

2
src/Foundation/Type.hs
View File

@ -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'

4
src/Handler/Admin/Tokens.hs
View File

@ -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

15
src/Handler/News.hs
View File

@ -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")

61
src/Handler/SystemMessage.hs
View File

@ -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

16
src/Handler/Term.hs
View File

@ -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

6
src/Import/NoModel.hs
View File

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

37
src/Settings.hs
View File

@ -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{..}

68
src/Settings/Cookies.hs Normal file
View File

@ -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
}

100
src/Utils.hs
View File

@ -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

27
src/Utils/Cookies.hs Normal file
View File

@ -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

133
src/Utils/Cookies/Registered.hs Normal file
View File

@ -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

4
src/Utils/DB.hs
View File

@ -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

10
src/Utils/Lang.hs
View File

@ -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"

12
src/Utils/Parameters.hs
View File

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

29
src/Utils/PathPiece.hs
View File

@ -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

53
src/Utils/Session.hs Normal file
View File

@ -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

20
src/Utils/SystemMessage.hs
View File

@ -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

1
src/Utils/Tokens.hs
View File

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

13
src/Web/Cookie/Instances.hs Normal file
View File

@ -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 }

13
src/Web/ServerSession/Frontend/Yesod/Jwt.hs
View File

@ -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

1
start.sh
View File

@ -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

70
test/Database/Fill.hs
View File

@ -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