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

@@ -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
+    makeSessionBackend _ = fmap Just defaultClientSessionBackend
-        key <- CS.getKey CS.defaultKeyFile
-        return $ Just $ clientSessionBackend key 120
 
     -- | 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
+  let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes
-  return $ clientSessionBackend key timeout
+  (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
+clientSessionBackend key getCachedDate =
-    { sbLoadSession = loadClientSession key timeout "_SESSION"
+  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
+      decodeClientSession key date host val
-    save sess' now' = do
+    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

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' =
+encodeClientSession key iv date rhost session' =
-    CS.encrypt key iv $ encode $ SessionCookie expire 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
 
 
 ----------------------------------------------------------------------