New support for timeout resolution optimization.

README.md

@@ -91,6 +91,22 @@ Any authentication mechanism is supported as long as it uses a
 session variable.
 
 
+## Storage optimizations
+
+We provide the following storage optimizations:
+
+  * Empty sessions are not saved.  This is done transparently:
+    just insert a session variable and the session will
+    materialize.  Note that if your framework always creates a
+    CSRF token (e.g., Snap), then this optimization will not
+    apply you.
+
+  * You can set the timeout resolution.  Requests made within the
+    timeout resolution that do not change any session variables
+    will not update the session on the database.  By default the
+    timeout resolution is set to 10 minutes.
+
+
 ## Current limitations
 
 These limitations may be addressed in the future.  Right now,

serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap.hs

@@ -11,6 +11,7 @@ module Web.ServerSession.Frontend.Snap
   , setAuthKey
   , setIdleTimeout
   , setAbsoluteTimeout
+  , setTimeoutResolution
   , setPersistentCookies
   , setHttpOnlyCookies
   , setSecureCookies

serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai.hs

@@ -22,6 +22,7 @@ module Web.ServerSession.Frontend.Wai
   , setAuthKey
   , setIdleTimeout
   , setAbsoluteTimeout
+  , setTimeoutResolution
   , setPersistentCookies
   , setHttpOnlyCookies
   , setSecureCookies

serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs

@@ -11,6 +11,7 @@ module Web.ServerSession.Frontend.Yesod
   , setAuthKey
   , setIdleTimeout
   , setAbsoluteTimeout
+  , setTimeoutResolution
   , setPersistentCookies
   , setHttpOnlyCookies
   , setSecureCookies

serversession/src/Web/ServerSession/Core.hs

@@ -24,6 +24,7 @@ module Web.ServerSession.Core
   , setAuthKey
   , setIdleTimeout
   , setAbsoluteTimeout
+  , setTimeoutResolution
   , setPersistentCookies
   , setHttpOnlyCookies
   , setSecureCookies

serversession/src/Web/ServerSession/Core/Internal.hs

@@ -17,6 +17,7 @@ module Web.ServerSession.Core.Internal
   , setAuthKey
   , setIdleTimeout
   , setAbsoluteTimeout
+  , setTimeoutResolution
   , setPersistentCookies
   , setHttpOnlyCookies
   , setSecureCookies
@@ -45,7 +46,7 @@ import Data.ByteString (ByteString)
 import Data.Maybe (catMaybes, fromMaybe, isJust)
 import Data.Text (Text)
 import Data.Time (UTCTime, getCurrentTime)
-import Data.Time.Clock (NominalDiffTime, addUTCTime)
+import Data.Time.Clock (NominalDiffTime, addUTCTime, diffUTCTime)
 import Data.Typeable (Typeable)
 import Web.PathPieces (PathPiece(..))
 
@@ -249,6 +250,8 @@ instance E.Exception StorageException where
 --
 --   * Idle and absolute timeouts ('setIdleTimeout' and 'setAbsoluteTimeout').
 --
+--   * Timeout resolution ('setTimeoutResolution').
+--
 --   * Whether cookies should be persistent
 --   ('setPersistentCookies'), HTTP-only ('setHTTPOnlyCookies')
 --   and/or secure ('setSecureCookies').
@@ -262,6 +265,7 @@ data State s =
     , authKey           :: !Text
     , idleTimeout       :: !(Maybe NominalDiffTime)
     , absoluteTimeout   :: !(Maybe NominalDiffTime)
+    , timeoutResolution :: !(Maybe NominalDiffTime)
     , persistentCookies :: !Bool
     , httpOnlyCookies   :: !Bool
     , secureCookies     :: !Bool
@@ -280,6 +284,7 @@ createState sto = do
     , authKey           = "_ID"
     , idleTimeout       = Just $ 60*60*24*7  -- 7 days
     , absoluteTimeout   = Just $ 60*60*24*60 -- 60 days
+    , timeoutResolution = Just $ 60*10       -- 10 minutes
     , persistentCookies = True
     , httpOnlyCookies   = True
     , secureCookies     = False
@@ -339,6 +344,35 @@ setAbsoluteTimeout (Just d) _ | d <= 0 = error "serversession/setAbsoluteTimeout
 setAbsoluteTimeout val state = state { absoluteTimeout = val }
 
 
+-- | Set the timeout resolution.
+--
+-- We need to save both the creation and last access times on
+-- sessions in order to implement idle and absolute timeouts.
+-- This means that we have to save the updated session on the
+-- storage backend even if the request didn't change any session
+-- variable, if only to update the last access time.
+--
+-- This setting provides an optimization where the session is not
+-- updated on the storage backend provided that:
+--
+--   * No session variables were changed.
+--
+--   * The difference between the /current/ time and the last
+--   /saved/ access time is less than the timeout resolution.
+--
+-- For example, with a timeout resolution of 1 minute, every
+-- request that does not change the session variables within 1
+-- minute of the last update will not generate any updates on the
+-- storage backend.
+--
+-- If the timeout resolution is @Nothing@, then this optimization
+-- becomes disabled and the session will always be updated.
+--
+-- Defaults to 10 minutes.
+setTimeoutResolution :: Maybe NominalDiffTime -> State s -> State s
+setTimeoutResolution (Just d) _ | d <= 0 = error "serversession/setTimeoutResolution: Resolution should be positive."
+setTimeoutResolution val state = state { timeoutResolution = val }
+
 -- | Set whether by default cookies should be persistent (@True@) or
 -- non-persistent (@False@).  Persistent cookies are saved across
 -- browser sessions.  Non-persistent cookies are discarded when
@@ -521,7 +555,9 @@ decomposeSession state sm1 =
 -- | Save a session on the database.  If an old session is
 -- supplied, it is replaced, otherwise a new session is
 -- generated.  If the session is empty, it is not saved and
--- @Nothing@ is returned.
+-- @Nothing@ is returned.  If the timeout resolution optimization
+-- is applied (cf. 'setTimeoutResolution'), the old session is
+-- returned and no update is made.
 saveSessionOnDb
   :: Storage s
   => State s
@@ -533,6 +569,14 @@ saveSessionOnDb _ _ Nothing (DecomposedSession Nothing _ m)
   -- Return Nothing without doing anything whenever the session
   -- is empty (including auth ID) and there was no prior session.
   | M.null m = return Nothing
+saveSessionOnDb State { timeoutResolution = Just res } now (Just old) (DecomposedSession authId _ sessionMap)
+  -- If the data is the same and the old access time is within
+  -- the timeout resolution, just return the old session without
+  -- doing anything else.
+  | sessionData   old == sessionMap &&
+    sessionAuthId old == authId &&
+    abs (diffUTCTime now (sessionAccessedAt old)) < res =
+      return (Just old)
 saveSessionOnDb state now maybeInput DecomposedSession {..} = do
   -- Generate properties if needed or take them from previous
   -- saved session.

serversession/tests/Main.hs

@@ -74,6 +74,7 @@ main = hspec $ parallel $ do
       authKey stnull           `shouldBe` "_ID"
       idleTimeout stnull       `shouldBe` Just (60*60*24*7)
       absoluteTimeout stnull   `shouldBe` Just (60*60*24*60)
+      timeoutResolution stnull `shouldBe` Just (60*10)
       persistentCookies stnull `shouldBe` True
       httpOnlyCookies stnull   `shouldBe` True
       secureCookies stnull     `shouldBe` False
@@ -266,8 +267,19 @@ main = hspec $ parallel $ do
       saveSessionOnDb st fakenow (Just oldSession) emptyDecomp `shouldReturn` Just newSession
       getMockOperations sto `shouldReturn` [ReplaceSession newSession]
 
-    it "does not save session if only difference was accessedAt, and it was less than threshold" $
+    it "respects the timeout resolution" $ do
-      pendingWith "wishlist"
+      (session1, sto, st) <- prepareSaveSessionOnDb
+      let d = DecomposedSession (sessionAuthId session1) DoNotForceInvalidate (sessionData session1)
+      saveSessionOnDb st fakenow (Just session1) d `shouldReturn` Just session1
+      getMockOperations sto `shouldReturn` []
+      let t i = TI.addUTCTime (res + i) (sessionAccessedAt session1)
+          Just res = timeoutResolution st
+      saveSessionOnDb st (t (-1)) (Just session1) d `shouldReturn` Just session1
+      getMockOperations sto `shouldReturn` []
+      -- We don't care about t 0, timeoutResolution is Maybe anyway.
+      let session2 = session1 { sessionAccessedAt = t 1 }
+      saveSessionOnDb st (t 1) (Just session1) d `shouldReturn` Just session2
+      getMockOperations sto `shouldReturn` [ReplaceSession session2]
 
   describe "decomposeSession" $ do
     prop "it is sane when not finding auth key or force invalidate key" $