From 7d922d1de4253b8f2a68db1d68404e694020e801 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Fri, 11 Mar 2016 16:54:14 -0800 Subject: [PATCH] Add first stab at backend auto expiry This is for issue #7 So it would be nice if we had access to `State` because it would provide us with `cookieExpires`, but nothing in the machinery of serversession makes it available to backends for some reason. Also the tests seem to indicate that the State may not be available at the time of setting up storange engines (or may be a chicken-and-egg situation). The best solution seemed to be to take the settings for absolute and idle timeout that you're going to give to the state and share them. Just as a reminder for the motivation on this: currently in serversession's redis backend, you accumulate sessions indefinitely. Even after they expire, they will stay in redis. The other backends seem vulnerable to this too but its probably not nearly a big deal in something like persistent because: 1. Storage is not as much of a premium in peristent's supported backend compared to redis. They are primarily storing to disk. 2. Persistent's backends have good querying primitives so it is simple to write jobs to delete old sessions. Redis must fit all data in memory, so storage is at a premium and in order to find old keys you'd have to issue the frowned-upon KEYS command (or SCAN which isn't even suppored by hedis yet) and parse every session. This change uses redis' built in expiry mechanism and sets the expiration every time a write operation is made to a session. Sessions as they would naturally expire on the client side will now automatically expire and free memory on the backend. --- .../ServerSession/Backend/Redis/Internal.hs | 40 ++++++++++++++----- serversession-backend-redis/tests/Main.hs | 3 +- 2 files changed, 33 insertions(+), 10 deletions(-) diff --git a/serversession-backend-redis/src/Web/ServerSession/Backend/Redis/Internal.hs b/serversession-backend-redis/src/Web/ServerSession/Backend/Redis/Internal.hs index f246358..afe2e0b 100644 --- a/serversession-backend-redis/src/Web/ServerSession/Backend/Redis/Internal.hs +++ b/serversession-backend-redis/src/Web/ServerSession/Backend/Redis/Internal.hs @@ -32,7 +32,7 @@ import Control.Monad (void, when) import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Data.List (partition) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Data.Proxy (Proxy(..)) import Data.Typeable (Typeable) import Web.PathPieces (toPathPiece) @@ -45,6 +45,7 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.HashMap.Strict as HM import qualified Data.Text.Encoding as TE import qualified Data.Time.Clock as TI +import qualified Data.Time.Clock.POSIX as TP import qualified Data.Time.Format as TI #if MIN_VERSION_time(1,5,0) @@ -57,10 +58,14 @@ import System.Locale (defaultTimeLocale) -- | Session storage backend using Redis via the @hedis@ package. -newtype RedisStorage sess = +data RedisStorage sess = RedisStorage { connPool :: R.Connection -- ^ Connection pool to the Redis server. + , idleTimeout :: Maybe TI.NominalDiffTime + -- ^ How long should a session live after last access + , absoluteTimeout :: Maybe TI.NominalDiffTime + -- ^ How long should a session live after creation } deriving (Typeable) @@ -73,8 +78,8 @@ instance RedisSession sess => Storage (RedisStorage sess) where getSession _ = getSessionImpl deleteSession _ = deleteSessionImpl deleteAllSessionsOfAuthId _ = deleteAllSessionsOfAuthIdImpl - insertSession _ = insertSessionImpl - replaceSession _ = replaceSessionImpl + insertSession = insertSessionImpl + replaceSession = replaceSessionImpl -- | An exception thrown by the @serversession-backend-redis@ @@ -271,8 +276,8 @@ deleteAllSessionsOfAuthIdImpl authId = do -- | Insert a new session. -insertSessionImpl :: RedisSession sess => Session sess -> R.Redis () -insertSessionImpl session = do +insertSessionImpl :: RedisSession sess => RedisStorage sess -> Session sess -> R.Redis () +insertSessionImpl sto session = do -- Check that no old session exists. let sid = sessionKey session moldSession <- getSessionImpl sid @@ -282,14 +287,15 @@ insertSessionImpl session = do transaction $ do let sk = rSessionKey sid r <- batched (R.hmset sk) (printSession session) - -- TODO: R.expireat + expireSession session sto + -- Set the expiration if applicable insertSessionForAuthId (sessionKey session) (sessionAuthId session) return (() <$ r) -- | Replace the contents of a session. -replaceSessionImpl :: RedisSession sess => Session sess -> R.Redis () -replaceSessionImpl session = do +replaceSessionImpl :: RedisSession sess => RedisStorage sess -> Session sess -> R.Redis () +replaceSessionImpl sto session = do -- Check that the old session exists. let sid = sessionKey session moldSession <- getSessionImpl sid @@ -301,6 +307,8 @@ replaceSessionImpl session = do let sk = rSessionKey sid _ <- R.del [sk] r <- batched (R.hmset sk) (printSession session) + -- Set the expiration if applicable + expireSession session sto -- Remove the old auth ID from the map if it has changed. let oldAuthId = sessionAuthId oldSession @@ -318,3 +326,17 @@ throwRS => StorageException (RedisStorage sess) -> R.Redis a throwRS = liftIO . E.throwIO + + +expireSession :: Session sess -> RedisStorage sess -> R.RedisTx () +expireSession Session {..} RedisStorage {..} = + case minimum' (catMaybes [viaIdle, viaAbsolute]) of + Nothing -> return () + Just t -> let ts = round (TP.utcTimeToPOSIXSeconds t) + in void (R.expireat sk ts) + where + sk = rSessionKey sessionKey + minimum' [] = Nothing + minimum' xs = Just (minimum xs) + viaIdle = flip TI.addUTCTime sessionAccessedAt <$> idleTimeout + viaAbsolute = flip TI.addUTCTime sessionCreatedAt <$> absoluteTimeout diff --git a/serversession-backend-redis/tests/Main.hs b/serversession-backend-redis/tests/Main.hs index ed53c0a..761f574 100644 --- a/serversession-backend-redis/tests/Main.hs +++ b/serversession-backend-redis/tests/Main.hs @@ -3,10 +3,11 @@ module Main (main) where import Database.Redis (connect, defaultConnectInfo) import Test.Hspec import Web.ServerSession.Backend.Redis +import Web.ServerSession.Core import Web.ServerSession.Core.StorageTests main :: IO () main = do conn <- connect defaultConnectInfo hspec $ describe "RedisStorage" $ - allStorageTests (RedisStorage conn) it runIO parallel shouldBe shouldReturn shouldThrow + allStorageTests (RedisStorage conn Nothing Nothing) it runIO parallel shouldBe shouldReturn shouldThrow