diff --git a/README.md b/README.md index d822701..7ce3a3e 100644 --- a/README.md +++ b/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, diff --git a/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap.hs b/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap.hs index 392da5e..06acc91 100644 --- a/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap.hs +++ b/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 diff --git a/serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai.hs b/serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai.hs index 58f87f2..d177814 100644 --- a/serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai.hs +++ b/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 diff --git a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs index d0903be..887afdb 100644 --- a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs +++ b/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 diff --git a/serversession/src/Web/ServerSession/Core.hs b/serversession/src/Web/ServerSession/Core.hs index adeda1a..34b2253 100644 --- a/serversession/src/Web/ServerSession/Core.hs +++ b/serversession/src/Web/ServerSession/Core.hs @@ -24,6 +24,7 @@ module Web.ServerSession.Core , setAuthKey , setIdleTimeout , setAbsoluteTimeout + , setTimeoutResolution , setPersistentCookies , setHttpOnlyCookies , setSecureCookies diff --git a/serversession/src/Web/ServerSession/Core/Internal.hs b/serversession/src/Web/ServerSession/Core/Internal.hs index 5461eab..a3ec03c 100644 --- a/serversession/src/Web/ServerSession/Core/Internal.hs +++ b/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. diff --git a/serversession/tests/Main.hs b/serversession/tests/Main.hs index ab07b98..e8165a6 100644 --- a/serversession/tests/Main.hs +++ b/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" $ - pendingWith "wishlist" + it "respects the timeout resolution" $ do + (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" $