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/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

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