diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 27f9c8be..cc7a7719 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -31,7 +31,6 @@ module Yesod.Core , SessionBackend (..) , defaultClientSessionBackend , clientSessionBackend - , saveClientSession , loadClientSession , Header(..) , BackendSession diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 6482e137..a182b9e0 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -29,7 +29,6 @@ module Yesod.Internal.Core , SessionBackend (..) , defaultClientSessionBackend , clientSessionBackend - , saveClientSession , loadClientSession , BackendSession -- * jsLoader @@ -389,8 +388,9 @@ defaultYesodRunner _ master _ murl toMaster _ req (x, _):_ -> Just x defaultYesodRunner handler master sub murl toMasterRoute msb req = do now <- liftIO getCurrentTime - session <- liftIO $ - maybe (return []) (\sb -> sbLoadSession sb master req now) msb + let dontSaveSession _ _ = return [] + (session, saveSession) <- liftIO $ + maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb rr <- liftIO $ parseWaiRequest req session (isJust msb) let h = {-# SCC "h" #-} do case murl of @@ -419,10 +419,7 @@ defaultYesodRunner handler master sub murl toMasterRoute msb req = do newSess (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess) (reqToken rr) - sessionHeaders <- liftIO $ maybe - (return []) - (\sb -> sbSaveSession sb master req now session nsToken) - msb + sessionHeaders <- liftIO (saveSession nsToken now) return $ ("Content-Type", ct) : map headerToPair sessionHeaders _ -> return [] return $ yarToResponse yar extraHeaders @@ -702,44 +699,36 @@ clientSessionBackend :: Yesod master -> Int -- ^ Inactive session valitity in minutes -> SessionBackend master clientSessionBackend key timeout = SessionBackend - { sbSaveSession = saveClientSession key timeout - , sbLoadSession = loadClientSession key + { sbLoadSession = loadClientSession key timeout } loadClientSession :: Yesod master - => CS.Key - -> master - -> W.Request - -> UTCTime - -> IO BackendSession -loadClientSession key _ req now = return . fromMaybe [] $ do - raw <- lookup "Cookie" $ W.requestHeaders req - val <- lookup sessionName $ parseCookies raw - let host = "" -- fixme, properly lock sessions to client address - decodeClientSession key now host val - -saveClientSession :: Yesod master => CS.Key -> Int -> master -> W.Request -> UTCTime - -> BackendSession - -> BackendSession - -> IO [Header] -saveClientSession key timeout master _ now _ sess = do - -- fixme should we be caching this? - iv <- liftIO CS.randomIV - return [AddCookie def - { setCookieName = sessionName - , setCookieValue = sessionVal iv - , setCookiePath = Just (cookiePath master) - , setCookieExpires = Just expires - , setCookieDomain = cookieDomain master - , setCookieHttpOnly = True - }] + -> IO (BackendSession, SaveSession) +loadClientSession key timeout master req now = return (sess, save) where - host = "" -- fixme, properly lock sessions to client address - expires = fromIntegral (timeout * 60) `addUTCTime` now - sessionVal iv = encodeClientSession key iv expires host sess + sess = fromMaybe [] $ do + raw <- lookup "Cookie" $ W.requestHeaders req + val <- lookup sessionName $ parseCookies raw + let host = "" -- fixme, properly lock sessions to client address + decodeClientSession key now host val + save sess' now' = do + -- fixme should we be caching this? + iv <- liftIO CS.randomIV + return [AddCookie def + { setCookieName = sessionName + , setCookieValue = sessionVal iv + , setCookiePath = Just (cookiePath master) + , setCookieExpires = Just expires + , setCookieDomain = cookieDomain master + , setCookieHttpOnly = True + }] + where + host = "" -- fixme, properly lock sessions to client address + expires = fromIntegral (timeout * 60) `addUTCTime` now' + sessionVal iv = encodeClientSession key iv expires host sess' diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index ac84a862..09f66f38 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -2,6 +2,7 @@ module Yesod.Internal.Session ( encodeClientSession , decodeClientSession , BackendSession + , SaveSession , SessionBackend(..) ) where @@ -20,17 +21,15 @@ import qualified Network.Wai as W type BackendSession = [(Text, S8.ByteString)] -data SessionBackend master = SessionBackend - { sbSaveSession :: master +type SaveSession = BackendSession -> -- ^ The session contents after running the handler + UTCTime -> -- ^ current time + IO [Header] + +newtype SessionBackend master = SessionBackend + { sbLoadSession :: master -> W.Request - -> UTCTime -- ^ The current time - -> BackendSession -- ^ The old session (before running handler) - -> BackendSession -- ^ The final session - -> IO [Header] - , sbLoadSession :: master - -> W.Request - -> UTCTime -- ^ The current time - -> IO BackendSession + -> UTCTime + -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session } encodeClientSession :: CS.Key