109 lines
4.3 KiB
Haskell
109 lines
4.3 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Foundation.Yesod.Session
|
|
( makeSessionBackend
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (makeSessionBackend)
|
|
|
|
import Foundation.Routes
|
|
import Foundation.Type
|
|
|
|
import qualified Web.ServerSession.Core as ServerSession
|
|
import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
|
|
|
|
import qualified Network.Wai as W
|
|
import qualified Network.HTTP.Types.Header as W
|
|
import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)
|
|
import qualified Network.HTTP.Types as HTTP
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import Web.Cookie
|
|
|
|
|
|
makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
|
|
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = noCreateFor (return . forRoute isError) . notFor isUserGenerated . notFor isBearer . sameSite $ case appSessionStore of
|
|
SessionStorageMemcachedSql sqlStore
|
|
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore
|
|
SessionStorageAcid acidStore
|
|
| appServerSessionAcidFallback
|
|
-> mkBackend . stateSettings =<< ServerSession.createState acidStore
|
|
_other
|
|
-> return Nothing
|
|
where
|
|
cfg = JwtSession.ServerSessionJwtConfig
|
|
{ sJwtJwkSet = appJSONWebKeySet
|
|
, sJwtStart = appSessionTokenStart
|
|
, sJwtExpiration = appSessionTokenExpiration
|
|
, sJwtEncoding = appSessionTokenEncoding
|
|
, sJwtIssueBy = appInstanceID
|
|
, sJwtIssueFor = appClusterID
|
|
, sJwtClockLeniencyStart = appSessionTokenClockLeniencyStart
|
|
, sJwtClockLeniencyEnd = appSessionTokenClockLeniencyEnd
|
|
}
|
|
mkBackend :: forall sto.
|
|
( ServerSession.SessionData sto ~ Map Text ByteString
|
|
, ServerSession.Storage sto
|
|
)
|
|
=> ServerSession.State sto -> IO (Maybe SessionBackend)
|
|
mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
|
|
stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
|
|
stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
|
|
sameSite
|
|
| Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
|
|
= strictSameSiteSessions
|
|
| Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession)
|
|
= laxSameSiteSessions
|
|
| otherwise
|
|
= id
|
|
|
|
notFor :: (W.Request -> IO Bool) -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
|
|
notFor f = fmap $ fmap notFor'
|
|
where notFor' :: SessionBackend -> SessionBackend
|
|
notFor' (SessionBackend load) = SessionBackend $ \req -> do
|
|
pMatches <- f req
|
|
if | not pMatches -> load req
|
|
| otherwise -> return (mempty, const $ return [])
|
|
|
|
noCreateFor :: (W.Request -> IO Bool) -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
|
|
noCreateFor f = fmap $ fmap notFor'
|
|
where notFor' :: SessionBackend -> SessionBackend
|
|
notFor' (SessionBackend load) = SessionBackend $ \req -> do
|
|
pMatches <- f req
|
|
if | not pMatches -> load req
|
|
| otherwise -> noCreate <$> load req
|
|
noCreate resp@(session, _)
|
|
| Map.null session = (session, const $ return [])
|
|
| otherwise = resp
|
|
|
|
forRoute :: (Route UniWorX -> Bool) -> (W.Request -> Bool)
|
|
forRoute f req = maybe False f mRoute
|
|
where mRoute = parseRoute
|
|
( W.pathInfo req
|
|
, over (mapped . _2) (fromMaybe "") . HTTP.queryToQueryText $ W.queryString req
|
|
)
|
|
|
|
|
|
isBearer req = return $ if
|
|
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
|
|
, any (is _Just . W.extractBearerAuth) aHdrs
|
|
-> True
|
|
| otherwise
|
|
-> False
|
|
|
|
isUserGenerated req = return $ if
|
|
| Just approotHost <- approotScopeHost ApprootUserGenerated app
|
|
, Just reqHost <- W.requestHeaderHost req
|
|
, views _appRoot ($ ApprootUserGenerated) app /= views _appRoot ($ ApprootDefault) app
|
|
, reqHost == approotHost
|
|
-> True
|
|
| otherwise
|
|
-> False
|
|
|
|
isError = \case
|
|
ErrorR -> True
|
|
_other -> False
|