63 lines
2.7 KiB
Haskell
63 lines
2.7 KiB
Haskell
module Foundation.Yesod.Session
|
|
( makeSessionBackend
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (makeSessionBackend)
|
|
|
|
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 Web.Cookie
|
|
|
|
|
|
makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
|
|
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . 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 = Nothing
|
|
, sJwtExpiration = appSessionTokenExpiration
|
|
, sJwtEncoding = appSessionTokenEncoding
|
|
, sJwtIssueBy = appInstanceID
|
|
, sJwtIssueFor = appClusterID
|
|
}
|
|
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
|
|
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 . W.extractBearerAuth) aHdrs
|
|
= return (mempty, const $ return [])
|
|
| otherwise
|
|
= load req
|
|
in SessionBackend load'
|