serversession-backend-redis 1.0.1 → 1.0.2

raw patch · 4 files changed

+54/−14 lines, 4 filesdep ~hedisnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: hedis

API changes (from Hackage documentation)

Files

• changelog.md +3/−0
• serversession-backend-redis.cabal +15/−2
• src/Web/ServerSession/Backend/Redis/Internal.hs +35/−11
• tests/Main.hs +1/−1

@@ -0,0 +1,3 @@+1.0.2+* Get building on GHC 8+* Auto-expire expired keys in redis to avoid storage bloat over time.

@@ -1,5 +1,5 @@ name:            serversession-backend-redis-version:         1.0.1+version:         1.0.2 license:         MIT license-file:    LICENSE author:          Felipe Lessa <felipe.lessa@gmail.com>@@ -12,17 +12,22 @@ homepage:        https://github.com/yesodweb/serversession description:     API docs and the README are available at <http://www.stackage.org/package/serversession-backend-redis> 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

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

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