Merge branch 'faster-session' of https://github.com/meteficha/yesod

yesod-core/Yesod/Internal/Core.hs

@@ -70,7 +70,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)
@@ -352,9 +351,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.
     --
@@ -438,10 +435,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
@@ -471,7 +467,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
@@ -760,47 +756,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(..)
@@ -8,70 +10,121 @@ 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)
-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
+
+
+----------------------------------------------------------------------
+
 
 putTime :: Putter UTCTime
-putTime t@(UTCTime d _) = do
+putTime (UTCTime d t) =
-    put $ toModifiedJulianDay d
+  let d' = fromInteger  $ toModifiedJulianDay d
-    let ndt = diffUTCTime t $ UTCTime d 0
+      t' = fromIntegral $ fromEnum (t / diffTimeScale)
-    put $ toRational ndt
+  in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')
 
 getTime :: Get UTCTime
 getTime = do
-    d <- get
+  val <- get
-    ndt <- get
+  let (d, t) = val `divMod` posixDayLength_int64
-    return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0
+      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