Simplified SessionBackend
This commit is contained in:
parent
cf3fe53cd4
commit
0a54826157
@ -202,17 +202,6 @@ $doctype 5
|
||||
sessionIpAddress _ = False
|
||||
-}
|
||||
|
||||
-- | The path value to set for cookies. By default, uses \"\/\", meaning
|
||||
-- cookies will be sent to every page on the current domain.
|
||||
cookiePath :: a -> S8.ByteString
|
||||
cookiePath _ = "/"
|
||||
|
||||
-- | The domain value to set for cookies. By default, the
|
||||
-- domain is not set, meaning cookies will be sent only to
|
||||
-- the current domain.
|
||||
cookieDomain :: a -> Maybe S8.ByteString
|
||||
cookieDomain _ = Nothing
|
||||
|
||||
-- | Maximum allowed length of the request body, in bytes.
|
||||
--
|
||||
-- Default: 2 megabytes.
|
||||
@ -259,7 +248,7 @@ $doctype 5
|
||||
-- | Create a session backend. Returning `Nothing' disables sessions.
|
||||
--
|
||||
-- Default: Uses clientsession with a 2 hour timeout.
|
||||
makeSessionBackend :: a -> IO (Maybe (SessionBackend a))
|
||||
makeSessionBackend :: a -> IO (Maybe SessionBackend)
|
||||
makeSessionBackend _ = fmap Just defaultClientSessionBackend
|
||||
|
||||
-- | How to store uploaded files.
|
||||
@ -501,7 +490,7 @@ formatLogMessage getdate loc src level msg = do
|
||||
, LB ")\n"
|
||||
]
|
||||
|
||||
defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)
|
||||
defaultClientSessionBackend :: IO SessionBackend
|
||||
defaultClientSessionBackend = do
|
||||
key <- CS.getKey CS.defaultKeyFile
|
||||
let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes
|
||||
@ -522,23 +511,20 @@ right :: Either a b -> Maybe b
|
||||
right (Right x) = Just x
|
||||
right _ = Nothing
|
||||
|
||||
clientSessionBackend :: Yesod master
|
||||
=> CS.Key -- ^ The encryption key
|
||||
clientSessionBackend :: CS.Key -- ^ The encryption key
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> SessionBackend master
|
||||
-> SessionBackend
|
||||
clientSessionBackend key getCachedDate =
|
||||
SessionBackend {
|
||||
sbLoadSession = \master req -> loadClientSession key getCachedDate "_SESSION" master req
|
||||
sbLoadSession = loadClientSession key getCachedDate "_SESSION"
|
||||
}
|
||||
|
||||
loadClientSession :: Yesod master
|
||||
=> CS.Key
|
||||
loadClientSession :: CS.Key
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> S8.ByteString -- ^ session name
|
||||
-> master
|
||||
-> W.Request
|
||||
-> IO (SessionMap, SaveSession)
|
||||
loadClientSession key getCachedDate sessionName master req = load
|
||||
loadClientSession key getCachedDate sessionName req = load
|
||||
where
|
||||
load = do
|
||||
date <- getCachedDate
|
||||
@ -554,9 +540,9 @@ loadClientSession key getCachedDate sessionName master req = load
|
||||
return [AddCookie def
|
||||
{ setCookieName = sessionName
|
||||
, setCookieValue = encodeClientSession key iv date host sess'
|
||||
, setCookiePath = Just (cookiePath master)
|
||||
, setCookiePath = Just "/"
|
||||
, setCookieExpires = Just (csdcExpires date)
|
||||
, setCookieDomain = cookieDomain master
|
||||
, setCookieDomain = Nothing
|
||||
, setCookieHttpOnly = True
|
||||
}]
|
||||
where
|
||||
|
||||
@ -176,7 +176,7 @@ toWaiApp' :: ( Yesod master
|
||||
)
|
||||
=> master
|
||||
-> Logger
|
||||
-> Maybe (SessionBackend master)
|
||||
-> Maybe SessionBackend
|
||||
-> W.Application
|
||||
toWaiApp' y logger sb req =
|
||||
case cleanPath y $ W.pathInfo req of
|
||||
|
||||
@ -219,7 +219,7 @@ yesodRunner handler' YesodRunnerEnv {..} req
|
||||
| otherwise = do
|
||||
let dontSaveSession _ = return []
|
||||
(session, saveSession) <- liftIO $ do
|
||||
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb yreMaster req) yreSessionBackend
|
||||
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend
|
||||
let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) maxLen
|
||||
yreq <-
|
||||
case mkYesodReq of
|
||||
|
||||
@ -60,9 +60,8 @@ type SessionMap = Map Text ByteString
|
||||
type SaveSession = SessionMap -- ^ The session contents after running the handler
|
||||
-> IO [Header]
|
||||
|
||||
newtype SessionBackend master = SessionBackend
|
||||
{ sbLoadSession :: master
|
||||
-> W.Request
|
||||
newtype SessionBackend = SessionBackend
|
||||
{ sbLoadSession :: W.Request
|
||||
-> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session
|
||||
}
|
||||
|
||||
@ -190,7 +189,7 @@ data YesodRunnerEnv sub master = YesodRunnerEnv
|
||||
, yreSub :: !sub
|
||||
, yreRoute :: !(Maybe (Route sub))
|
||||
, yreToMaster :: !(Route sub -> Route master)
|
||||
, yreSessionBackend :: !(Maybe (SessionBackend master))
|
||||
, yreSessionBackend :: !(Maybe SessionBackend)
|
||||
}
|
||||
|
||||
-- | A generic handler monad, which can have a different subsite and master
|
||||
|
||||
Loading…
Reference in New Issue
Block a user