From 065e33a3d13e4bfacd47d073f94206430d88f9ed Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Wed, 5 Sep 2012 00:41:54 -0300 Subject: [PATCH 1/2] Faster, leaner implementation of putTime/getTime. Benchmark on my computer (per call, includes runPut/runGet): old putTime: 5658 ns +/- 224ns new putTime: 821 ns +/- 24ns (7x faster) old getTime: 7228 ns +/- 126ns new getTime: 99 ns +/- 4ns (73x faster!!) Besides, the old format used 25 raw bytes (33.3 bytes on the base64 output), while the new one uses 8 bytes (10.6 bytes on the base64 output). --- yesod-core/Yesod/Internal/Session.hs | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index 810f44e6..00d0a84e 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -8,6 +8,7 @@ module Yesod.Internal.Session import Yesod.Internal (Header(..)) import qualified Web.ClientSession as CS +import Data.Int (Int64) import Data.Serialize import Data.Time import Data.ByteString (ByteString) @@ -64,14 +65,26 @@ instance Serialize SessionCookie where c <- map (first pack) <$> get return $ SessionCookie a b c + +---------------------------------------------------------------------- + + putTime :: Putter UTCTime -putTime t@(UTCTime d _) = do - put $ toModifiedJulianDay d - let ndt = diffUTCTime t $ UTCTime d 0 - put $ toRational ndt +putTime (UTCTime d t) = + let d' = fromInteger $ toModifiedJulianDay d + t' = fromIntegral $ fromEnum (t / diffTimeScale) + in put (d' * posixDayLength_int64 + min posixDayLength_int64 t') getTime :: Get UTCTime getTime = do - d <- get - ndt <- get - return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 + val <- get + let (d, t) = val `divMod` posixDayLength_int64 + d' = ModifiedJulianDay $! fromIntegral d + t' = fromIntegral t + d' `seq` t' `seq` return (UTCTime d' t') + +posixDayLength_int64 :: Int64 +posixDayLength_int64 = 86400 + +diffTimeScale :: DiffTime +diffTimeScale = 1e12 From b2a9beba3cdd9e4df4f772af89fa991369e86013 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Wed, 5 Sep 2012 01:35:10 -0300 Subject: [PATCH 2/2] 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. --- yesod-core/Yesod/Internal/Core.hs | 46 ++++++++++--------- yesod-core/Yesod/Internal/Session.hs | 66 ++++++++++++++++++++++------ 2 files changed, 75 insertions(+), 37 deletions(-) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 6562e6b8..756c3baf 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -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 diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index 00d0a84e..dac74a41 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -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 ----------------------------------------------------------------------