From bf293e6a1f6e691281520d254f72b9441cc64704 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 26 Dec 2012 19:00:45 +0200 Subject: [PATCH] Make new session code optional, keep old API --- yesod-core/Yesod/Core.hs | 2 + yesod-core/Yesod/Internal/Core.hs | 71 +++++++++++++++++++++++----- yesod-core/Yesod/Internal/Session.hs | 31 ++++++++++++ yesod-core/yesod-core.cabal | 2 +- 4 files changed, 93 insertions(+), 13 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index c2c46961..7268d6cb 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -35,6 +35,8 @@ module Yesod.Core , SessionBackend (..) , defaultClientSessionBackend , clientSessionBackend + , clientSessionBackend2 + , clientSessionDateCacher , loadClientSession , Header(..) , BackendSession diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index fdd47eb8..f3ddeec0 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -25,6 +25,9 @@ module Yesod.Internal.Core , defaultClientSessionBackend , clientSessionBackend , loadClientSession + , clientSessionBackend2 + , loadClientSession2 + , clientSessionDateCacher , BackendSession -- * jsLoader , ScriptLoadPosition (..) @@ -44,6 +47,7 @@ import Yesod.Handler hiding (lift, getExpires) import Control.Monad.Logger (logErrorS) import Yesod.Routes.Class +import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Data.Word (Word64) import Control.Arrow ((***)) @@ -435,9 +439,10 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req [("Content-Type", "text/plain")] "Request body too large to be processed." | otherwise = do - let dontSaveSession _ = return [] - (session, saveSession) <- liftIO $ - maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req) msb + let dontSaveSession _ _ = return [] + now <- liftIO getCurrentTime -- FIXME remove in next major version bump + (session, saveSession) <- liftIO $ do + maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb rr <- liftIO $ parseWaiRequest req session (isJust msb) len let h = {-# SCC "h" #-} do case murl of @@ -467,7 +472,7 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req newSess (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess) (reqToken rr) - sessionHeaders <- liftIO (saveSession nsToken) + sessionHeaders <- liftIO (saveSession nsToken now) return $ ("Content-Type", ct) : map headerToPair sessionHeaders _ -> return [] return $ yarToResponse yar extraHeaders @@ -758,25 +763,67 @@ defaultClientSessionBackend = do key <- CS.getKey CS.defaultKeyFile let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout - return $ clientSessionBackend key getCachedDate + return $ clientSessionBackend2 key getCachedDate + clientSessionBackend :: Yesod master => CS.Key -- ^ The encryption key - -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' + -> Int -- ^ Inactive session valitity in minutes -> SessionBackend master -clientSessionBackend key getCachedDate = - SessionBackend { - sbLoadSession = loadClientSession key getCachedDate "_SESSION" - } +clientSessionBackend key timeout = SessionBackend + { sbLoadSession = loadClientSession key timeout "_SESSION" + } +{-# DEPRECATED clientSessionBackend "Please use clientSessionBackend2, which is more efficient." #-} loadClientSession :: Yesod master + => CS.Key + -> Int -- ^ timeout + -> S8.ByteString -- ^ session name + -> master + -> W.Request + -> UTCTime + -> IO (BackendSession, SaveSession) +loadClientSession key timeout sessionName master req now = return (sess, save) + where + sess = fromMaybe [] $ do + raw <- lookup "Cookie" $ W.requestHeaders req + val <- lookup sessionName $ parseCookies raw + let host = "" -- fixme, properly lock sessions to client address + decodeClientSessionOld key now host val + save sess' now' = do + -- We should never cache the IV! Be careful! + 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 = encodeClientSessionOld key iv expires host sess' +{-# DEPRECATED loadClientSession "Please use loadClientSession2, which is more efficient." #-} + +clientSessionBackend2 :: Yesod master + => CS.Key -- ^ The encryption key + -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' + -> SessionBackend master +clientSessionBackend2 key getCachedDate = + SessionBackend { + sbLoadSession = \master req -> const $ loadClientSession2 key getCachedDate "_SESSION" master req + } + +loadClientSession2 :: Yesod master => CS.Key -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' -> S8.ByteString -- ^ session name -> master -> W.Request -> IO (BackendSession, SaveSession) -loadClientSession key getCachedDate sessionName master req = load +loadClientSession2 key getCachedDate sessionName master req = load where load = do date <- getCachedDate @@ -786,7 +833,7 @@ loadClientSession key getCachedDate sessionName master req = load val <- lookup sessionName $ parseCookies raw let host = "" -- fixme, properly lock sessions to client address decodeClientSession key date host val - save date sess' = do + save date sess' _ = do -- We should never cache the IV! Be careful! iv <- liftIO CS.randomIV return [AddCookie def diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index dac74a41..ab17b698 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -1,10 +1,13 @@ module Yesod.Internal.Session ( encodeClientSession + , encodeClientSessionOld , decodeClientSession + , decodeClientSessionOld , clientSessionDateCacher , ClientSessionDateCache(..) , BackendSession , SaveSession + , SaveSessionOld , SessionBackend(..) ) where @@ -27,11 +30,17 @@ import qualified Network.Wai as W type BackendSession = [(Text, S8.ByteString)] type SaveSession = BackendSession -- ^ The session contents after running the handler + -> UTCTime -- FIXME remove this in the next major version bump + -> IO [Header] + +type SaveSessionOld = BackendSession -- ^ The session contents after running the handler + -> UTCTime -> IO [Header] newtype SessionBackend master = SessionBackend { sbLoadSession :: master -> W.Request + -> UTCTime -- FIXME remove this in the next major version bump -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session } @@ -128,3 +137,25 @@ posixDayLength_int64 = 86400 diffTimeScale :: DiffTime diffTimeScale = 1e12 + +encodeClientSessionOld :: CS.Key + -> CS.IV + -> UTCTime -- ^ expire time + -> ByteString -- ^ remote host + -> [(Text, ByteString)] -- ^ session + -> ByteString -- ^ cookie value +encodeClientSessionOld key iv expire rhost session' = + CS.encrypt key iv $ encode $ SessionCookie (Left expire) rhost session' + +decodeClientSessionOld :: CS.Key + -> UTCTime -- ^ current time + -> ByteString -- ^ remote host field + -> ByteString -- ^ cookie value + -> Maybe [(Text, ByteString)] +decodeClientSessionOld key now rhost encrypted = do + decrypted <- CS.decrypt key encrypted + SessionCookie (Left expire) rhost' session' <- + either (const Nothing) Just $ decode decrypted + guard $ expire > now + guard $ rhost' == rhost + return session' diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index f3124233..1e4537af 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.1.6.1 +version: 1.1.7 license: MIT license-file: LICENSE author: Michael Snoyman