From 6895fbee4f035715db771a5b7de4f5bfa541c8c2 Mon Sep 17 00:00:00 2001
From: Felipe Lessa <felipe.lessa@gmail.com>
Date: Thu, 28 May 2015 14:34:47 -0300
Subject: [PATCH] Allow Redis to store sessions with more than 512k keys.

---
 .../Web/ServerSession/Backend/Redis/Internal.hs   | 15 +++++++++++++--
 1 file changed, 13 insertions(+), 2 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 6facf61..c71be27 100644
--- a/serversession-backend-redis/src/Web/ServerSession/Backend/Redis/Internal.hs
+++ b/serversession-backend-redis/src/Web/ServerSession/Backend/Redis/Internal.hs
@@ -165,6 +165,17 @@ timeFormat = "%Y-%m-%dT%H:%M:%S%Q"
 ----------------------------------------------------------------------
 
 
+-- | Run the given Redis command in batches of @511*1024@ items.
+-- This is used for @HMSET@ because there's a hard Redis limit of
+-- @1024*1024@ arguments to a command.  The last result is returned.
+batched :: Monad m => ([a] -> m b) -> [a] -> m b
+batched f xs =
+  let (this, rest) = splitAt (511*1024) xs
+      continue | null rest = return
+               | otherwise = const (batched f rest)
+  in f this >>= continue
+
+
 -- | Get the session for the given session ID.
 getSessionImpl :: SessionId -> R.Redis (Maybe Session)
 getSessionImpl sid = parseSession sid <$> unwrap (R.hgetall $ rSessionKey sid)
@@ -219,7 +230,7 @@ insertSessionImpl session = do
     Nothing -> do
       transaction $ do
         let sk = rSessionKey sid
-        r <- R.hmset sk (printSession session)
+        r <- batched (R.hmset sk) (printSession session)
         -- TODO: R.expireat
         insertSessionForAuthId (sessionKey session) (sessionAuthId session)
         return (() <$ r)
@@ -238,7 +249,7 @@ replaceSessionImpl session = do
         -- Delete the old session and set the new one.
         let sk = rSessionKey sid
         _ <- R.del [sk]
-        r <- R.hmset sk (printSession session)
+        r <- batched (R.hmset sk) (printSession session)
 
         -- Remove the old auth ID from the map if it has changed.
         let oldAuthId = sessionAuthId oldSession