Use a cache for session cookie's expiration time.
The following HelloWorld app was used as benchmark:
data HelloWorld = HelloWorld
mkYesod "HelloWorld" [parseRoutes|
/ HomeR GET
|]
instance Yesod HelloWorld where
-- makeSessionBackend = const $ return Nothing
getHomeR = return . RepPlain . toContent $ "Hello World!"
main :: IO ()
main = warp 8080 HelloWorld
The benchmark was tested with httperf under the following
environments:
[vanilla-nosession] Released yesod-core 1.1.1.1, but without sessions.
[vanilla-session] Released yesod-core 1.1.1.1 (with sessions).
[faster-session-1] With patch 065e33a, "Faster, leaner
implementation of putTime/getTime".
[faster-session-2] With this commit.
Performance results:
A) Testing with:
httperf --hog --client=0/1 --server=localhost \
--port=8080 --uri=/ --rate=1000 \
--send-buffer=4096 --recv-buffer=16384 \
--num-conns=100 --wsess=1000,60,1 \
--burst-length=20 --session-cookie
Results:
vanilla-nosession: 19187.7 req/s (0.1 ms/req)
vanilla-session: 2523.3 req/s (0.4 ms/req)
faster-session-1: 2933.5 req/s (0.3 ms/req)
faster-session-2: 2957.5 req/s (0.3 ms/req)
This test benchmarks both saving and loading the session.
Interestingly, this commit provides only a small performance
increase.
B) Testing with:
httperf --hog --client=0/1 --server=localhost \
--port=8080 --uri=/ --rate=1000 \
--send-buffer=4096 --recv-buffer=16384 \
--num-conns=100 --num-calls=1000 \
--burst-length=20
Results:
vanilla-nosession: 43548.7 req/s (0.0 ms/req)
vanilla-session: 3609.4 req/s (0.3 ms/req)
faster-session-1: 3454.9 req/s (0.3 ms/req)
faster-session-2: 3786.9 req/s (0.3 ms/req)
This test benchmarks only saving the session. Strangely,
faster-session-1 was worse than vanilla-session (while
isolated tests show that the new putTime should be +70x
faster). However, there is a non-negligible performance
increase on faster-session-2.
This commit is contained in:
Felipe Lessa
parent
065e33a3d1
commit
b2a9beba3c
@ -69,7 +69,6 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import Web.Cookie (parseCookies)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Time
|
||||
import Network.HTTP.Types (encodePath)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text (Text)
|
||||
@ -331,9 +330,7 @@ $doctype 5
|
||||
--
|
||||
-- Default: Uses clientsession with a 2 hour timeout.
|
||||
makeSessionBackend :: a -> IO (Maybe (SessionBackend a))
|
||||
makeSessionBackend _ = do
|
||||
key <- CS.getKey CS.defaultKeyFile
|
||||
return $ Just $ clientSessionBackend key 120
|
||||
makeSessionBackend _ = fmap Just defaultClientSessionBackend
|
||||
|
||||
-- | How to store uploaded files.
|
||||
--
|
||||
@ -393,10 +390,9 @@ defaultYesodRunner logger handler master sub murl toMasterRoute msb req
|
||||
[("Content-Type", "text/plain")]
|
||||
"Request body too large to be processed."
|
||||
| otherwise = do
|
||||
now <- liftIO getCurrentTime
|
||||
let dontSaveSession _ _ = return []
|
||||
let dontSaveSession _ = return []
|
||||
(session, saveSession) <- liftIO $
|
||||
maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb
|
||||
maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req) msb
|
||||
rr <- liftIO $ parseWaiRequest req session (isJust msb) len
|
||||
let h = {-# SCC "h" #-} do
|
||||
case murl of
|
||||
@ -426,7 +422,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 now)
|
||||
sessionHeaders <- liftIO (saveSession nsToken)
|
||||
return $ ("Content-Type", ct) : map headerToPair sessionHeaders
|
||||
_ -> return []
|
||||
return $ yarToResponse yar extraHeaders
|
||||
@ -713,47 +709,49 @@ resolveApproot master req =
|
||||
defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)
|
||||
defaultClientSessionBackend = do
|
||||
key <- CS.getKey CS.defaultKeyFile
|
||||
let timeout = 120 -- 120 minutes
|
||||
return $ clientSessionBackend key timeout
|
||||
let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes
|
||||
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
|
||||
return $ clientSessionBackend key getCachedDate
|
||||
|
||||
clientSessionBackend :: Yesod master
|
||||
=> CS.Key -- ^ The encryption key
|
||||
-> Int -- ^ Inactive session valitity in minutes
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> SessionBackend master
|
||||
clientSessionBackend key timeout = SessionBackend
|
||||
{ sbLoadSession = loadClientSession key timeout "_SESSION"
|
||||
}
|
||||
clientSessionBackend key getCachedDate =
|
||||
SessionBackend {
|
||||
sbLoadSession = loadClientSession key getCachedDate "_SESSION"
|
||||
}
|
||||
|
||||
loadClientSession :: Yesod master
|
||||
=> CS.Key
|
||||
-> Int -- ^ timeout
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> S8.ByteString -- ^ session name
|
||||
-> master
|
||||
-> W.Request
|
||||
-> UTCTime
|
||||
-> IO (BackendSession, SaveSession)
|
||||
loadClientSession key timeout sessionName master req now = return (sess, save)
|
||||
loadClientSession key getCachedDate sessionName master req = load
|
||||
where
|
||||
sess = fromMaybe [] $ do
|
||||
load = do
|
||||
date <- getCachedDate
|
||||
return (sess date, save date)
|
||||
sess date = 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
|
||||
decodeClientSession key date host val
|
||||
save date sess' = do
|
||||
-- We should never cache the IV! Be careful!
|
||||
iv <- liftIO CS.randomIV
|
||||
return [AddCookie def
|
||||
{ setCookieName = sessionName
|
||||
, setCookieValue = sessionVal iv
|
||||
, setCookieValue = encodeClientSession key iv date host sess'
|
||||
, setCookiePath = Just (cookiePath master)
|
||||
, setCookieExpires = Just expires
|
||||
, setCookieExpires = Just (csdcExpires date)
|
||||
, 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'
|
||||
|
||||
|
||||
-- | Run a 'GHandler' completely outside of Yesod. This
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
module Yesod.Internal.Session
|
||||
( encodeClientSession
|
||||
, decodeClientSession
|
||||
, clientSessionDateCacher
|
||||
, ClientSessionDateCache(..)
|
||||
, BackendSession
|
||||
, SaveSession
|
||||
, SessionBackend(..)
|
||||
@ -12,58 +14,96 @@ import Data.Int (Int64)
|
||||
import Data.Serialize
|
||||
import Data.Time
|
||||
import Data.ByteString (ByteString)
|
||||
import Control.Monad (guard)
|
||||
import Control.Concurrent (forkIO, killThread, threadDelay)
|
||||
import Control.Monad (forever, guard)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import Control.Arrow (first)
|
||||
import Control.Applicative ((<$>))
|
||||
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.IORef as I
|
||||
import qualified Network.Wai as W
|
||||
|
||||
type BackendSession = [(Text, S8.ByteString)]
|
||||
|
||||
type SaveSession = BackendSession -- ^ The session contents after running the handler
|
||||
-> UTCTime -- ^ current time
|
||||
-> IO [Header]
|
||||
|
||||
newtype SessionBackend master = SessionBackend
|
||||
{ sbLoadSession :: master
|
||||
-> W.Request
|
||||
-> UTCTime
|
||||
-> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session
|
||||
}
|
||||
|
||||
encodeClientSession :: CS.Key
|
||||
-> CS.IV
|
||||
-> UTCTime -- ^ expire time
|
||||
-> ClientSessionDateCache -- ^ expire time
|
||||
-> ByteString -- ^ remote host
|
||||
-> [(Text, ByteString)] -- ^ session
|
||||
-> ByteString -- ^ cookie value
|
||||
encodeClientSession key iv expire rhost session' =
|
||||
CS.encrypt key iv $ encode $ SessionCookie expire rhost session'
|
||||
encodeClientSession key iv date rhost session' =
|
||||
CS.encrypt key iv $ encode $ SessionCookie expires rhost session'
|
||||
where expires = Right (csdcExpiresSerialized date)
|
||||
|
||||
decodeClientSession :: CS.Key
|
||||
-> UTCTime -- ^ current time
|
||||
-> ClientSessionDateCache -- ^ current time
|
||||
-> ByteString -- ^ remote host field
|
||||
-> ByteString -- ^ cookie value
|
||||
-> Maybe [(Text, ByteString)]
|
||||
decodeClientSession key now rhost encrypted = do
|
||||
decodeClientSession key date rhost encrypted = do
|
||||
decrypted <- CS.decrypt key encrypted
|
||||
SessionCookie expire rhost' session' <-
|
||||
SessionCookie (Left expire) rhost' session' <-
|
||||
either (const Nothing) Just $ decode decrypted
|
||||
guard $ expire > now
|
||||
guard $ expire > csdcNow date
|
||||
guard $ rhost' == rhost
|
||||
return session'
|
||||
|
||||
data SessionCookie = SessionCookie UTCTime ByteString [(Text, ByteString)]
|
||||
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)]
|
||||
deriving (Show, Read)
|
||||
instance Serialize SessionCookie where
|
||||
put (SessionCookie a b c) = putTime a >> put b >> put (map (first unpack) c)
|
||||
put (SessionCookie a b c) = do
|
||||
either putTime putByteString a
|
||||
put b
|
||||
put (map (first unpack) c)
|
||||
get = do
|
||||
a <- getTime
|
||||
b <- get
|
||||
c <- map (first pack) <$> get
|
||||
return $ SessionCookie a b c
|
||||
return $ SessionCookie (Left a) b c
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
|
||||
-- Mostly copied from Kazu's date-cache, but with modifications
|
||||
-- that better suit our needs.
|
||||
--
|
||||
-- The cached date is updated every 10s, we don't need second
|
||||
-- resolution for session expiration times.
|
||||
|
||||
data ClientSessionDateCache =
|
||||
ClientSessionDateCache {
|
||||
csdcNow :: !UTCTime
|
||||
, csdcExpires :: !UTCTime
|
||||
, csdcExpiresSerialized :: !ByteString
|
||||
} deriving (Eq, Show)
|
||||
|
||||
clientSessionDateCacher ::
|
||||
NominalDiffTime -- ^ Inactive session valitity.
|
||||
-> IO (IO ClientSessionDateCache, IO ())
|
||||
clientSessionDateCacher validity = do
|
||||
ref <- getUpdated >>= I.newIORef
|
||||
tid <- forkIO $ forever (doUpdate ref)
|
||||
return $! (I.readIORef ref, killThread tid)
|
||||
where
|
||||
getUpdated = do
|
||||
now <- getCurrentTime
|
||||
let expires = validity `addUTCTime` now
|
||||
expiresS = runPut (putTime expires)
|
||||
return $! ClientSessionDateCache now expires expiresS
|
||||
doUpdate ref = do
|
||||
threadDelay 10000000 -- 10s
|
||||
I.writeIORef ref =<< getUpdated
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user