Added scan commands

Author: qrilka

codegen/GenCmds.hs

@@ -86,10 +86,10 @@ blacklist = [ manual "AUTH" ["auth"]
                 ["Condition", "SetOpts(..)"]
             , manualWithType "ZADD"
                 ["zadd", "zaddOpts"]
-                ["ZaddOpts(..)"]
+                ["ZaddOpts(..)", "defaultZaddOpts"]
             , manualWithType "MIGRATE"
                 ["migrate", "migrateMultiple"]
-                ["MigrateOpts(..)"]
+                ["MigrateOpts(..)", "defaultMigrateOpts"]
             , manual "RESTORE"
                 ["restore", "restoreReplace"]
             , manualWithType "CLIENT REPLY"
@@ -102,14 +102,16 @@ blacklist = [ manual "AUTH" ["auth"]
             , manual "SPOP" ["spop"]
             , manual "INFO" ["info", "infoSection"]
             , manual "EXISTS" ["exists"]
+            , manualWithType "SCAN"
+                ["scan", "scanOpts"]
+                ["Cursor", "cursor0", "ScanOpts(..)", "defaultScanOpts"]
+            , manual "SSCAN" ["sscan", "sscanOpts"]
+            , manual "HSCAN" ["hscan", "hscanOpts"]
+            , manual "ZSCAN" ["zscan", "zscanOpts"]
             , unimplemented "COMMAND"
             , unimplemented "COMMAND GETKEYS"
             , unimplemented "ROLE"
             , unimplemented "CLIENT KILL"
-            , unimplemented "SCAN"
-            , unimplemented "SSCAN"
-            , unimplemented "HSCAN"
-            , unimplemented "ZSCAN"
             , unimplemented "ZRANGEBYLEX"
             , unimplemented "ZREVRANGEBYLEX"
             , unimplemented "ZRANGEBYSCORE"

src/Database/Redis/ManualCommands.hs

@@ -318,7 +318,7 @@ zstoreInternal
     -> ByteString -- ^ destination
     -> [ByteString] -- ^ keys
     -> [Double] -- ^ weights
-    -> Aggregate    
+    -> Aggregate
     -> m (f Integer)
 zstoreInternal cmd dest keys weights aggregate = sendRequest $
     concat [ [cmd, dest, encode . toInteger $ length keys], keys
@@ -638,3 +638,117 @@ exists
     => ByteString -- ^ key
     -> m (f Bool)
 exists key = sendRequest ["EXISTS", key]
+
+newtype Cursor = Cursor ByteString deriving (Show, Eq)
+
+
+instance RedisArg Cursor where
+  encode (Cursor c) = encode c
+
+
+instance RedisResult Cursor where
+  decode (Bulk (Just s)) = Right $ Cursor s
+  decode r               = Left r
+
+
+cursor0 :: Cursor
+cursor0 = Cursor "0"
+
+
+scan
+    :: (RedisCtx m f)
+    => Cursor
+    -> m (f (Cursor, [ByteString])) -- ^ next cursor and values
+scan cursor = scanOpts cursor defaultScanOpts
+
+
+data ScanOpts = ScanOpts
+  { scanMatch :: Maybe ByteString
+  , scanCount :: Maybe Integer
+  } deriving (Show, Eq)
+
+
+-- |Redis default 'ScanOpts'. Equivalent to omitting all optional parameters.
+--
+-- @
+-- ScanOpts
+--     { scanMatch = Nothing -- don't match any pattern
+--     , scanCount = Nothing -- don't set any requirements on number elements returned (works like value @COUNT 10@)
+--     }
+-- @
+--
+defaultScanOpts :: ScanOpts
+defaultScanOpts = ScanOpts
+  { scanMatch = Nothing
+  , scanCount = Nothing
+  }
+
+
+scanOpts
+    :: (RedisCtx m f)
+    => Cursor
+    -> ScanOpts
+    -> m (f (Cursor, [ByteString])) -- ^ next cursor and values
+scanOpts cursor opts = sendRequest $ addScanOpts ["SCAN", encode cursor] opts
+
+
+addScanOpts
+    :: [ByteString] -- ^ main part of scan command
+    -> ScanOpts
+    -> [ByteString]
+addScanOpts cmd ScanOpts{..} =
+    concat [cmd, match, count]
+  where
+    match = maybeToList scanMatch
+    count = map encode $ maybeToList scanCount
+
+
+sscan
+    :: (RedisCtx m f)
+    => ByteString -- ^ key
+    -> Cursor
+    -> m (f (Cursor, [ByteString])) -- ^ next cursor and values
+sscan key cursor = sscanOpts key cursor defaultScanOpts
+
+
+sscanOpts
+    :: (RedisCtx m f)
+    => ByteString -- ^ key
+    -> Cursor
+    -> ScanOpts
+    -> m (f (Cursor, [ByteString])) -- ^ next cursor and values
+sscanOpts key cursor opts = sendRequest $ addScanOpts ["SSCAN", key, encode cursor] opts
+
+
+hscan
+    :: (RedisCtx m f)
+    => ByteString -- ^ key
+    -> Cursor
+    -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values
+hscan key cursor = hscanOpts key cursor defaultScanOpts
+
+
+hscanOpts
+    :: (RedisCtx m f)
+    => ByteString -- ^ key
+    -> Cursor
+    -> ScanOpts
+    -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values
+hscanOpts key cursor opts = sendRequest $ addScanOpts ["HSCAN", key, encode cursor] opts
+
+
+zscan
+    :: (RedisCtx m f)
+    => ByteString -- ^ key
+    -> Cursor
+    -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values
+zscan key cursor = zscanOpts key cursor defaultScanOpts
+
+
+zscanOpts
+    :: (RedisCtx m f)
+    => ByteString -- ^ key
+    -> Cursor
+    -> ScanOpts
+    -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values
+zscanOpts key cursor opts = sendRequest $ addScanOpts ["ZSCAN", key, encode cursor] opts

test/Test.hs

@@ -56,7 +56,9 @@ tests :: Connection -> [Test.Test]
 tests conn = map ($conn) $ concat
     [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog]
     , testsZSets, [testPubSub], [testTransaction], [testScripting]
-    , testsConnection, testsServer, [testQuit]
+    , testsConnection, testsServer, [testScans]
+      -- should always be run last as connection gets closed after it
+    , [testQuit]
     ]
 
 ------------------------------------------------------------------------------
@@ -521,3 +523,14 @@ testDebugObject = testCase "debugObject/debugSegfault" $ do
     set "key" "value" >>=? Ok
     Right _ <- debugObject "key"
     return ()
+
+testScans :: Test
+testScans = testCase "cursors" $ do
+    set "key" "value"       >>=? Ok
+    scan cursor0            >>=? (cursor0, ["key"])
+    sadd "set" ["1"]        >>=? 1
+    sscan "set" cursor0     >>=? (cursor0, ["1"])
+    hset "hash" "k" "v"     >>=? True
+    hscan "hash" cursor0    >>=? (cursor0, [("k", "v")])
+    zadd "zset" [(42, "2")] >>=? 1
+    zscan "zset" cursor0    >>=? (cursor0, [("2", 42)])