From 7d922d1de4253b8f2a68db1d68404e694020e801 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Fri, 11 Mar 2016 16:54:14 -0800 Subject: [PATCH 1/4] 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 From d135958be5d626e3d58c8bf7255a8ce008d9c76d Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Sat, 12 Mar 2016 13:11:43 -0800 Subject: [PATCH 2/4] Update comments, exercise expiration codepath I wanted to at least ensure my change's code was excerised, even though it makes no material difference to the allStorageTests suite. --- .../src/Web/ServerSession/Backend/Redis/Internal.hs | 6 ++++-- serversession-backend-redis/tests/Main.hs | 2 +- 2 files changed, 5 insertions(+), 3 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 afe2e0b..5ac28d3 100644 --- a/serversession-backend-redis/src/Web/ServerSession/Backend/Redis/Internal.hs +++ b/serversession-backend-redis/src/Web/ServerSession/Backend/Redis/Internal.hs @@ -288,7 +288,6 @@ insertSessionImpl sto session = do let sk = rSessionKey sid r <- batched (R.hmset sk) (printSession session) expireSession session sto - -- Set the expiration if applicable insertSessionForAuthId (sessionKey session) (sessionAuthId session) return (() <$ r) @@ -307,7 +306,6 @@ replaceSessionImpl sto 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. @@ -328,6 +326,10 @@ throwRS throwRS = liftIO . E.throwIO +-- | Given a session, finds the next time the session will time out, +-- either by idle or absolute timeout and schedule the key in redis to +-- expire at that time. This is meant to be used on every write to a +-- session so that it is constantly setting the appropriate timeout. expireSession :: Session sess -> RedisStorage sess -> R.RedisTx () expireSession Session {..} RedisStorage {..} = case minimum' (catMaybes [viaIdle, viaAbsolute]) of diff --git a/serversession-backend-redis/tests/Main.hs b/serversession-backend-redis/tests/Main.hs index 761f574..2258c9f 100644 --- a/serversession-backend-redis/tests/Main.hs +++ b/serversession-backend-redis/tests/Main.hs @@ -10,4 +10,4 @@ main :: IO () main = do conn <- connect defaultConnectInfo hspec $ describe "RedisStorage" $ - allStorageTests (RedisStorage conn Nothing Nothing) it runIO parallel shouldBe shouldReturn shouldThrow + allStorageTests (RedisStorage conn (Just 999999) (Just 999999)) it runIO parallel shouldBe shouldReturn shouldThrow From b51d32df4d37a9933451a780e41ef8a11ce8b703 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Mon, 28 Nov 2016 09:30:29 -0800 Subject: [PATCH 3/4] widen deps --- serversession-backend-redis/serversession-backend-redis.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/serversession-backend-redis/serversession-backend-redis.cabal b/serversession-backend-redis/serversession-backend-redis.cabal index 9ef0df9..67e1ec5 100644 --- a/serversession-backend-redis/serversession-backend-redis.cabal +++ b/serversession-backend-redis/serversession-backend-redis.cabal @@ -22,7 +22,7 @@ library build-depends: base == 4.* , bytestring - , hedis == 0.6.* + , hedis >= 0.6 && < 0.10 , path-pieces , tagged >= 0.7 , text From 70d1c43e0969a0897c381064ae84f90510d4ed17 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 25 Jan 2017 18:15:40 -0800 Subject: [PATCH 4/4] I think we have to use system-ghc explicitly now? --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 67f85d4..15fd644 100644 --- a/.travis.yml +++ b/.travis.yml @@ -56,7 +56,7 @@ before_install: - export PATH=$HOME/.local/bin:$PATH - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - export PATH=/opt/ghc/$GHCVER/bin:$PATH - - export RUNSTACK="stack --no-terminal --skip-ghc-check --resolver=$RESOLVER" + - export RUNSTACK="stack --no-terminal --skip-ghc-check --system-ghc --resolver=$RESOLVER" install: - $RUNSTACK --version