Simplified SessionBackend

This commit is contained in:
Michael Snoyman 2013-03-12 16:29:48 +02:00
parent cf3fe53cd4
commit 0a54826157
4 changed files with 14 additions and 29 deletions

View File

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

View File

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

View File

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

View File

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