diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +1.0.2 +* Get building on GHC 8 +* Auto-expire expired keys in redis to avoid storage bloat over time. diff --git a/serversession-backend-redis.cabal b/serversession-backend-redis.cabal --- a/serversession-backend-redis.cabal +++ b/serversession-backend-redis.cabal @@ -1,5 +1,5 @@ name: serversession-backend-redis -version: 1.0.1 +version: 1.0.2 license: MIT license-file: LICENSE author: Felipe Lessa @@ -12,17 +12,22 @@ homepage: https://github.com/yesodweb/serversession description: API docs and the README are available at extra-source-files: README.md + changelog.md flag old-locale description: Use time-1.4 and old-locale (GHC 7.8). default: False +flag lib-Werror + default: False + manual: True + library hs-source-dirs: src build-depends: base == 4.* , bytestring - , hedis == 0.6.* + , hedis < 0.10 , path-pieces , tagged >= 0.7 , text @@ -47,8 +52,13 @@ ScopedTypeVariables TypeFamilies ghc-options: -Wall + if flag(lib-Werror) + ghc-options: -Werror + if impl(ghc >= 8.0.0) + ghc-options: -Wno-redundant-constraints + test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests @@ -62,6 +72,9 @@ , serversession-backend-redis main-is: Main.hs ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts + if flag(lib-Werror) + ghc-options: -Werror + source-repository head diff --git a/src/Web/ServerSession/Backend/Redis/Internal.hs b/src/Web/ServerSession/Backend/Redis/Internal.hs --- a/src/Web/ServerSession/Backend/Redis/Internal.hs +++ b/src/Web/ServerSession/Backend/Redis/Internal.hs @@ -26,13 +26,13 @@ , throwRS ) where -import Control.Applicative ((<$), (<$>)) +import Control.Applicative as A import Control.Arrow (first) 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.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 @@ -- | 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 @@ getSession _ = getSessionImpl deleteSession _ = deleteSessionImpl deleteAllSessionsOfAuthId _ = deleteAllSessionsOfAuthIdImpl - insertSession _ = insertSessionImpl - replaceSession _ = replaceSessionImpl + insertSession = insertSessionImpl + replaceSession = replaceSessionImpl -- | An exception thrown by the @serversession-backend-redis@ @@ -225,7 +230,7 @@ -- | Get the session for the given session ID. getSessionImpl :: RedisSession sess => SessionId sess -> R.Redis (Maybe (Session sess)) -getSessionImpl sid = parseSession sid <$> unwrap (R.hgetall $ rSessionKey sid) +getSessionImpl sid = parseSession sid A.<$> unwrap (R.hgetall $ rSessionKey sid) -- | Delete the session with given session ID. @@ -271,8 +276,8 @@ -- | 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,14 @@ transaction $ do let sk = rSessionKey sid r <- batched (R.hmset sk) (printSession session) - -- TODO: R.expireat + expireSession session sto 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 +306,7 @@ let sk = rSessionKey sid _ <- R.del [sk] r <- batched (R.hmset sk) (printSession session) + expireSession session sto -- Remove the old auth ID from the map if it has changed. let oldAuthId = sessionAuthId oldSession @@ -318,3 +324,21 @@ => StorageException (RedisStorage sess) -> R.Redis a 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 + 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/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -9,4 +9,4 @@ main = do conn <- connect defaultConnectInfo hspec $ describe "RedisStorage" $ - allStorageTests (RedisStorage conn) it runIO parallel shouldBe shouldReturn shouldThrow + allStorageTests (RedisStorage conn (Just 999999) (Just 999999)) it runIO parallel shouldBe shouldReturn shouldThrow