hedis 0.5 → 0.5.1

raw patch · 11 files changed

+869/−865 lines, 11 filesdep +test-frameworkdep +test-framework-hunitdep +vectordep −stmPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: test-framework, test-framework-hunit, vector

Dependencies removed: stm

API changes (from Hackage documentation)

Files

• benchmark/Benchmark.hs +17/−0
• hedis.cabal +37/−30
• src/Database/Redis.hs +10/−4
• src/Database/Redis/Commands.hs +393/−363
• src/Database/Redis/Core.hs +20/−103
• src/Database/Redis/ManualCommands.hs +50/−0
• src/Database/Redis/ProtocolPipelining.hs +131/−0
• src/Database/Redis/PubSub.hs +0/−1
• src/Database/Redis/Transactions.hs +12/−14
• src/Database/Redis/Types.hs +3/−3
• test/Test.hs +196/−347

@@ -73,3 +73,20 @@         let expected = replicate 100 (Right Pong)         True <- return $ pongs == expected         return ()++    timeAction "multiExec get 1" 1 $ do+        TxSuccess _ <- multiExec $ get "foo"+        return ()+    +    timeAction "multiExec get 50" 50 $ do+        TxSuccess 50 <- multiExec $ do+                            rs <- replicateM 50 (get "foo")+                            return $ fmap length (sequence rs)+        return ()++    timeAction "multiExec get 1000" 1000 $ do+        TxSuccess 1000 <- multiExec $ do+                            rs <- replicateM 1000 (get "foo")+                            return $ fmap length (sequence rs)+        return ()+    

@@ -1,5 +1,5 @@ name:               hedis-version:            0.5+version:            0.5.1 synopsis:     Client library for the Redis datastore: supports full command set,       pipelining.@@ -13,7 +13,7 @@     [Complete Redis 2.6 command set:] All Redis commands         (<http://redis.io/commands>) are available as haskell functions, except         for the MONITOR and SYNC commands. Additionally, a low-level API is-        exposed that  makes it easy for the library user to implement additional+        exposed that  makes it easy for the library user to implement further         commands, such as new commands from an experimental Redis version.     .     [Automatic Optimal Pipelining:] Commands are pipelined@@ -34,12 +34,23 @@     .     For detailed documentation, see the "Database.Redis" module.     .+    [Changes since version 0.5]+    .+    * New commands: DUMP, RESTORE, BITOP, BITCOUNT.+    .+    * Removed the dependency on stm.+    .+    * Improved performance of Queued in long transactions.+    .+    * Minor documentation updates.+    .     [Changes since version 0.4.1]     .     * Added new Redis 2.6 commands, including Lua scripting support.     .     * A transaction context is now created by using the 'multiExec' function.-      The functions 'multi' and 'exec' are no longer available individually.+      The functions 'multi', 'exec' and 'discard' are no longer available+      individually.     .     * Inside of a transaction, commands return their results wrapped in a       composable /future/, called 'Queued'.@@ -74,10 +85,7 @@  library   hs-source-dirs:   src-  if flag(test)-      ghc-options:  -Wall-  else-      ghc-options:  -Wall+  ghc-options:      -Wall   ghc-prof-options: -auto-all   exposed-modules:  Database.Redis   build-depends:    attoparsec == 0.10.*,@@ -88,10 +96,11 @@                     mtl == 2.*,                     network == 2.*,                     resource-pool == 0.2.1.*,-                    stm >= 2.2 && < 2.4,-                    time+                    time,+                    vector == 0.9.*    other-modules:    Database.Redis.Core,+                    Database.Redis.ProtocolPipelining,                     Database.Redis.Protocol,                     Database.Redis.PubSub,                     Database.Redis.Transactions,@@ -99,31 +108,29 @@                     Database.Redis.Commands,                     Database.Redis.ManualCommands -executable hedis-benchmark+benchmark hedis-benchmark+    type: exitcode-stdio-1.0     main-is: benchmark/Benchmark.hs-    if flag(benchmark)-        build-depends:-            base == 4.*,-            mtl == 2.*,-            hedis,-            time >= 1.2-    else-        buildable: False-    ghc-options: -Wall -rtsopts+    build-depends:+        base == 4.*,+        mtl == 2.*,+        hedis,+        time >= 1.2+    ghc-options: -O2 -Wall -rtsopts     ghc-prof-options: -auto-all -executable hedis-test+test-suite hedis-test+    type: exitcode-stdio-1.0     main-is: test/Test.hs-    if flag(test)-        build-depends:-            base == 4.*,-            bytestring == 0.9.*,-            hedis,-            HUnit == 1.2.*,-            mtl == 2.*,-            time-    else-        buildable: False+    build-depends:+        base == 4.*,+        bytestring == 0.9.*,+        hedis,+        HUnit == 1.2.*,+        mtl == 2.*,+        test-framework,+        test-framework-hunit,+        time     -- We use -O0 here, since GHC takes *very* long to compile so many constants     ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind     ghc-prof-options: -auto-all

@@ -116,10 +116,14 @@     --    message to gain  information on what kind of error occured.     --     --  [Connection to the server lost:] In case of a lost connection, command-    --    functions throw a -    --    'ConnectionLostException'. It can only be caught outside of-    --    'runRedis', to make sure the connection pool can properly destroy the-    --    connection.+    --    functions throw a 'ConnectionLostException'. It can only be caught+    --    outside of 'runRedis'.+    --+    --  [Exceptions:] Any exceptions can only be caught /outside/ of 'runRedis'.+    --    This way the connection pool can properly close the connection, making+    --    sure it is not left in an unusable state, e.g. closed or inside a+    --    transaction.+    --          -- * The Redis Monad     Redis(), runRedis,@@ -158,6 +162,8 @@ import Database.Redis.Core import Database.Redis.PubSub import Database.Redis.Protocol+import Database.Redis.ProtocolPipelining+    (HostName, PortID(..), ConnectionLostException(..)) import Database.Redis.Transactions import Database.Redis.Types 

@@ -13,10 +13,12 @@  -- ** Keys del, -- |Delete a key (<http://redis.io/commands/del>).+dump, -- |Return a serialized version of the value stored at the specified key. (<http://redis.io/commands/dump>). exists, -- |Determine if a key exists (<http://redis.io/commands/exists>). expire, -- |Set a key's time to live in seconds (<http://redis.io/commands/expire>). expireat, -- |Set the expiration for a key as a UNIX timestamp (<http://redis.io/commands/expireat>). keys, -- |Find all keys matching the given pattern (<http://redis.io/commands/keys>).+migrate, -- |Atomically transfer a key from a Redis instance to another one. (<http://redis.io/commands/migrate>). move, -- |Move a key to another database (<http://redis.io/commands/move>). objectRefcount, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. objectEncoding, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'.@@ -28,6 +30,7 @@ randomkey, -- |Return a random key from the keyspace (<http://redis.io/commands/randomkey>). rename, -- |Rename a key (<http://redis.io/commands/rename>). renamenx, -- |Rename a key, only if the new key does not exist (<http://redis.io/commands/renamenx>).+restore, -- |Create a key using the provided serialized value, previously obtained using DUMP. (<http://redis.io/commands/restore>). SortOpts(..), defaultSortOpts, SortOrder(..),@@ -73,8 +76,8 @@ rpushx, -- |Append a value to a list, only if the list exists (<http://redis.io/commands/rpushx>).  -- ** Scripting-eval, -- |Execute a Lua script server side (<http://redis.io/commands/eval>). The Redis command @EVAL@ is split up into 'eval', 'evalsha'.-evalsha, -- |Execute a Lua script server side (<http://redis.io/commands/eval>). The Redis command @EVAL@ is split up into 'eval', 'evalsha'.+eval, -- |Execute a Lua script server side (<http://redis.io/commands/eval>).+evalsha, -- |Execute a Lua script server side (<http://redis.io/commands/evalsha>). scriptExists, -- |Check existence of scripts in the script cache. (<http://redis.io/commands/script-exists>). scriptFlush, -- |Remove all the scripts from the script cache. (<http://redis.io/commands/script-flush>). scriptKill, -- |Kill the script currently in execution. (<http://redis.io/commands/script-kill>).@@ -88,7 +91,6 @@ configSet, -- |Set a configuration parameter to the given value (<http://redis.io/commands/config-set>). dbsize, -- |Return the number of keys in the selected database (<http://redis.io/commands/dbsize>). debugObject, -- |Get debugging information about a key (<http://redis.io/commands/debug-object>).-debugSegfault, -- |Make the server crash (<http://redis.io/commands/debug-segfault>). flushall, -- |Remove all keys from all databases (<http://redis.io/commands/flushall>). flushdb, -- |Remove all keys from the current database (<http://redis.io/commands/flushdb>). info, -- |Get information and statistics about the server (<http://redis.io/commands/info>).@@ -148,6 +150,12 @@  -- ** Strings append, -- |Append a value to a key (<http://redis.io/commands/append>).+bitcount, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'.+bitcountRange, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'.+bitopAnd, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'.+bitopOr, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'.+bitopXor, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'.+bitopNot, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. decr, -- |Decrement the integer value of a key by one (<http://redis.io/commands/decr>). decrby, -- |Decrement the integer value of a key by the given number (<http://redis.io/commands/decrby>). get, -- |Get the value of a key (<http://redis.io/commands/get>).@@ -182,6 +190,9 @@ -- -- * SHUTDOWN (<http://redis.io/commands/shutdown>) --+--+-- * DEBUG SEGFAULT (<http://redis.io/commands/debug-segfault>)+-- ) where  import Prelude hiding (min,max)@@ -195,6 +206,11 @@     => m (f Status) flushall  = sendRequest (["FLUSHALL"] ) +time+    :: (RedisCtx m f)+    => m (f (Integer,Integer))+time  = sendRequest (["TIME"] )+ hdel     :: (RedisCtx m f)     => ByteString -- ^ key@@ -210,11 +226,6 @@     -> m (f Integer) hincrby key field increment = sendRequest (["HINCRBY"] ++ [encode key] ++ [encode field] ++ [encode increment] ) -time-    :: (RedisCtx m f)-    => m (f (Integer,Integer))-time  = sendRequest (["TIME"] )- hincrbyfloat     :: (RedisCtx m f)     => ByteString -- ^ key@@ -223,73 +234,124 @@     -> m (f Double) hincrbyfloat key field increment = sendRequest (["HINCRBYFLOAT"] ++ [encode key] ++ [encode field] ++ [encode increment] ) -configResetstat+getset     :: (RedisCtx m f)-    => m (f Status)-configResetstat  = sendRequest (["CONFIG","RESETSTAT"] )+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> m (f (Maybe ByteString))+getset key value = sendRequest (["GETSET"] ++ [encode key] ++ [encode value] ) -scriptKill+rpushx     :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> m (f Integer)+rpushx key value = sendRequest (["RPUSHX"] ++ [encode key] ++ [encode value] )++setnx+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> m (f Bool)+setnx key value = sendRequest (["SETNX"] ++ [encode key] ++ [encode value] )++keys+    :: (RedisCtx m f)+    => ByteString -- ^ pattern+    -> m (f [ByteString])+keys pattern = sendRequest (["KEYS"] ++ [encode pattern] )++bgsave+    :: (RedisCtx m f)     => m (f Status)-scriptKill  = sendRequest (["SCRIPT","KILL"] )+bgsave  = sendRequest (["BGSAVE"] ) -del+slaveof     :: (RedisCtx m f)-    => [ByteString] -- ^ key-    -> m (f Integer)-del key = sendRequest (["DEL"] ++ map encode key )+    => ByteString -- ^ host+    -> ByteString -- ^ port+    -> m (f Status)+slaveof host port = sendRequest (["SLAVEOF"] ++ [encode host] ++ [encode port] ) -zrevrank+debugObject     :: (RedisCtx m f)     => ByteString -- ^ key-    -> ByteString -- ^ member-    -> m (f (Maybe Integer))-zrevrank key member = sendRequest (["ZREVRANK"] ++ [encode key] ++ [encode member] )+    -> m (f ByteString)+debugObject key = sendRequest (["DEBUG","OBJECT"] ++ [encode key] ) -brpoplpush+bgrewriteaof     :: (RedisCtx m f)-    => ByteString -- ^ source-    -> ByteString -- ^ destination-    -> Integer -- ^ timeout-    -> m (f (Maybe ByteString))-brpoplpush source destination timeout = sendRequest (["BRPOPLPUSH"] ++ [encode source] ++ [encode destination] ++ [encode timeout] )+    => m (f Status)+bgrewriteaof  = sendRequest (["BGREWRITEAOF"] ) -incrby+zincrby     :: (RedisCtx m f)     => ByteString -- ^ key     -> Integer -- ^ increment+    -> ByteString -- ^ member+    -> m (f Double)+zincrby key increment member = sendRequest (["ZINCRBY"] ++ [encode key] ++ [encode increment] ++ [encode member] )++sinter+    :: (RedisCtx m f)+    => [ByteString] -- ^ key+    -> m (f [ByteString])+sinter key = sendRequest (["SINTER"] ++ map encode key )++hmset+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> [(ByteString,ByteString)] -- ^ fieldValue+    -> m (f Status)+hmset key fieldValue = sendRequest (["HMSET"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])fieldValue )++scard+    :: (RedisCtx m f)+    => ByteString -- ^ key     -> m (f Integer)-incrby key increment = sendRequest (["INCRBY"] ++ [encode key] ++ [encode increment] )+scard key = sendRequest (["SCARD"] ++ [encode key] ) -rpop+get     :: (RedisCtx m f)     => ByteString -- ^ key     -> m (f (Maybe ByteString))-rpop key = sendRequest (["RPOP"] ++ [encode key] )+get key = sendRequest (["GET"] ++ [encode key] ) -setrange+lrem     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Integer -- ^ offset+    -> Integer -- ^ count     -> ByteString -- ^ value     -> m (f Integer)-setrange key offset value = sendRequest (["SETRANGE"] ++ [encode key] ++ [encode offset] ++ [encode value] )+lrem key count value = sendRequest (["LREM"] ++ [encode key] ++ [encode count] ++ [encode value] ) -setbit+expireat     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Integer -- ^ offset-    -> ByteString -- ^ value+    -> Integer -- ^ timestamp+    -> m (f Bool)+expireat key timestamp = sendRequest (["EXPIREAT"] ++ [encode key] ++ [encode timestamp] )++incr+    :: (RedisCtx m f)+    => ByteString -- ^ key     -> m (f Integer)-setbit key offset value = sendRequest (["SETBIT"] ++ [encode key] ++ [encode offset] ++ [encode value] )+incr key = sendRequest (["INCR"] ++ [encode key] ) -incrbyfloat+renamenx     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Double -- ^ increment-    -> m (f Double)-incrbyfloat key increment = sendRequest (["INCRBYFLOAT"] ++ [encode key] ++ [encode increment] )+    -> ByteString -- ^ newkey+    -> m (f Bool)+renamenx key newkey = sendRequest (["RENAMENX"] ++ [encode key] ++ [encode newkey] ) +pexpireat+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ millisecondsTimestamp+    -> m (f Bool)+pexpireat key millisecondsTimestamp = sendRequest (["PEXPIREAT"] ++ [encode key] ++ [encode millisecondsTimestamp] )+ save     :: (RedisCtx m f)     => m (f Status)@@ -315,6 +377,16 @@     -> m (f Integer) sdiffstore destination key = sendRequest (["SDIFFSTORE"] ++ [encode destination] ++ map encode key ) +migrate+    :: (RedisCtx m f)+    => ByteString -- ^ host+    -> ByteString -- ^ port+    -> ByteString -- ^ key+    -> Integer -- ^ destinationDb+    -> Integer -- ^ timeout+    -> m (f Status)+migrate host port key destinationDb timeout = sendRequest (["MIGRATE"] ++ [encode host] ++ [encode port] ++ [encode key] ++ [encode destinationDb] ++ [encode timeout] )+ move     :: (RedisCtx m f)     => ByteString -- ^ key@@ -322,152 +394,61 @@     -> m (f Bool) move key db = sendRequest (["MOVE"] ++ [encode key] ++ [encode db] ) -scriptLoad-    :: (RedisCtx m f)-    => ByteString -- ^ script-    -> m (f ByteString)-scriptLoad script = sendRequest (["SCRIPT","LOAD"] ++ [encode script] )--getrange-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> Integer -- ^ start-    -> Integer -- ^ end-    -> m (f ByteString)-getrange key start end = sendRequest (["GETRANGE"] ++ [encode key] ++ [encode start] ++ [encode end] )--srem-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> [ByteString] -- ^ member-    -> m (f Integer)-srem key member = sendRequest (["SREM"] ++ [encode key] ++ map encode member )--getbit+hvals     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Integer -- ^ offset-    -> m (f Integer)-getbit key offset = sendRequest (["GETBIT"] ++ [encode key] ++ [encode offset] )+    -> m (f [ByteString])+hvals key = sendRequest (["HVALS"] ++ [encode key] ) -zcount+exists     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Double -- ^ min-    -> Double -- ^ max-    -> m (f Integer)-zcount key min max = sendRequest (["ZCOUNT"] ++ [encode key] ++ [encode min] ++ [encode max] )--quit-    :: (RedisCtx m f)-    => m (f Status)-quit  = sendRequest (["QUIT"] )--msetnx-    :: (RedisCtx m f)-    => [(ByteString,ByteString)] -- ^ keyValue     -> m (f Bool)-msetnx keyValue = sendRequest (["MSETNX"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue )--sismember-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> ByteString -- ^ member-    -> m (f Bool)-sismember key member = sendRequest (["SISMEMBER"] ++ [encode key] ++ [encode member] )--bgrewriteaof-    :: (RedisCtx m f)-    => m (f Status)-bgrewriteaof  = sendRequest (["BGREWRITEAOF"] )+exists key = sendRequest (["EXISTS"] ++ [encode key] ) -hmset+smembers     :: (RedisCtx m f)     => ByteString -- ^ key-    -> [(ByteString,ByteString)] -- ^ fieldValue-    -> m (f Status)-hmset key fieldValue = sendRequest (["HMSET"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])fieldValue )+    -> m (f [ByteString])+smembers key = sendRequest (["SMEMBERS"] ++ [encode key] ) -scard+decr     :: (RedisCtx m f)     => ByteString -- ^ key     -> m (f Integer)-scard key = sendRequest (["SCARD"] ++ [encode key] )+decr key = sendRequest (["DECR"] ++ [encode key] ) -zincrby+rename     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Integer -- ^ increment-    -> ByteString -- ^ member-    -> m (f Double)-zincrby key increment member = sendRequest (["ZINCRBY"] ++ [encode key] ++ [encode increment] ++ [encode member] )+    -> ByteString -- ^ newkey+    -> m (f Status)+rename key newkey = sendRequest (["RENAME"] ++ [encode key] ++ [encode newkey] ) -sinter+sunion     :: (RedisCtx m f)     => [ByteString] -- ^ key     -> m (f [ByteString])-sinter key = sendRequest (["SINTER"] ++ map encode key )--scriptExists-    :: (RedisCtx m f)-    => [ByteString] -- ^ script-    -> m (f [Bool])-scriptExists script = sendRequest (["SCRIPT","EXISTS"] ++ map encode script )--mset-    :: (RedisCtx m f)-    => [(ByteString,ByteString)] -- ^ keyValue-    -> m (f Status)-mset keyValue = sendRequest (["MSET"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue )--psetex-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> Integer -- ^ milliseconds-    -> ByteString -- ^ value-    -> m (f Status)-psetex key milliseconds value = sendRequest (["PSETEX"] ++ [encode key] ++ [encode milliseconds] ++ [encode value] )--rpoplpush-    :: (RedisCtx m f)-    => ByteString -- ^ source-    -> ByteString -- ^ destination-    -> m (f (Maybe ByteString))-rpoplpush source destination = sendRequest (["RPOPLPUSH"] ++ [encode source] ++ [encode destination] )+sunion key = sendRequest (["SUNION"] ++ map encode key ) -hlen+ping     :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f Integer)-hlen key = sendRequest (["HLEN"] ++ [encode key] )+    => m (f Status)+ping  = sendRequest (["PING"] ) -setex+zrem     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Integer -- ^ seconds-    -> ByteString -- ^ value-    -> m (f Status)-setex key seconds value = sendRequest (["SETEX"] ++ [encode key] ++ [encode seconds] ++ [encode value] )--sunionstore-    :: (RedisCtx m f)-    => ByteString -- ^ destination-    -> [ByteString] -- ^ key+    -> [ByteString] -- ^ member     -> m (f Integer)-sunionstore destination key = sendRequest (["SUNIONSTORE"] ++ [encode destination] ++ map encode key )--brpop-    :: (RedisCtx m f)-    => [ByteString] -- ^ key-    -> Integer -- ^ timeout-    -> m (f (Maybe (ByteString,ByteString)))-brpop key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout] )+zrem key member = sendRequest (["ZREM"] ++ [encode key] ++ map encode member ) -hgetall+hmget     :: (RedisCtx m f)     => ByteString -- ^ key-    -> m (f [(ByteString,ByteString)])-hgetall key = sendRequest (["HGETALL"] ++ [encode key] )+    -> [ByteString] -- ^ field+    -> m (f [Maybe ByteString])+hmget key field = sendRequest (["HMGET"] ++ [encode key] ++ map encode field )  pexpire     :: (RedisCtx m f)@@ -481,19 +462,6 @@     => m (f Integer) dbsize  = sendRequest (["DBSIZE"] ) -lpop-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f (Maybe ByteString))-lpop key = sendRequest (["LPOP"] ++ [encode key] )--hmget-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> [ByteString] -- ^ field-    -> m (f [Maybe ByteString])-hmget key field = sendRequest (["HMGET"] ++ [encode key] ++ map encode field )- lrange     :: (RedisCtx m f)     => ByteString -- ^ key@@ -502,6 +470,12 @@     -> m (f [ByteString]) lrange key start stop = sendRequest (["LRANGE"] ++ [encode key] ++ [encode start] ++ [encode stop] ) +lpop+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f (Maybe ByteString))+lpop key = sendRequest (["LPOP"] ++ [encode key] )+ expire     :: (RedisCtx m f)     => ByteString -- ^ key@@ -509,93 +483,140 @@     -> m (f Bool) expire key seconds = sendRequest (["EXPIRE"] ++ [encode key] ++ [encode seconds] ) -scriptFlush+flushdb     :: (RedisCtx m f)     => m (f Status)-scriptFlush  = sendRequest (["SCRIPT","FLUSH"] )+flushdb  = sendRequest (["FLUSHDB"] ) -lastsave+smove     :: (RedisCtx m f)-    => m (f Integer)-lastsave  = sendRequest (["LASTSAVE"] )+    => ByteString -- ^ source+    -> ByteString -- ^ destination+    -> ByteString -- ^ member+    -> m (f Bool)+smove source destination member = sendRequest (["SMOVE"] ++ [encode source] ++ [encode destination] ++ [encode member] ) -llen+zremrangebyrank     :: (RedisCtx m f)     => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop     -> m (f Integer)-llen key = sendRequest (["LLEN"] ++ [encode key] )+zremrangebyrank key start stop = sendRequest (["ZREMRANGEBYRANK"] ++ [encode key] ++ [encode start] ++ [encode stop] ) -decrby+sadd     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Integer -- ^ decrement+    -> [ByteString] -- ^ member     -> m (f Integer)-decrby key decrement = sendRequest (["DECRBY"] ++ [encode key] ++ [encode decrement] )+sadd key member = sendRequest (["SADD"] ++ [encode key] ++ map encode member ) -mget+lpush     :: (RedisCtx m f)-    => [ByteString] -- ^ key-    -> m (f [Maybe ByteString])-mget key = sendRequest (["MGET"] ++ map encode key )+    => ByteString -- ^ key+    -> [ByteString] -- ^ value+    -> m (f Integer)+lpush key value = sendRequest (["LPUSH"] ++ [encode key] ++ map encode value ) -zadd+strlen     :: (RedisCtx m f)     => ByteString -- ^ key-    -> [(Double,ByteString)] -- ^ scoreMember     -> m (f Integer)-zadd key scoreMember = sendRequest (["ZADD"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])scoreMember )+strlen key = sendRequest (["STRLEN"] ++ [encode key] ) -keys+set     :: (RedisCtx m f)-    => ByteString -- ^ pattern-    -> m (f [ByteString])-keys pattern = sendRequest (["KEYS"] ++ [encode pattern] )+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> m (f Status)+set key value = sendRequest (["SET"] ++ [encode key] ++ [encode value] ) -bgsave+lindex     :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ index+    -> m (f (Maybe ByteString))+lindex key index = sendRequest (["LINDEX"] ++ [encode key] ++ [encode index] )++zscore+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ member+    -> m (f (Maybe Double))+zscore key member = sendRequest (["ZSCORE"] ++ [encode key] ++ [encode member] )++configResetstat+    :: (RedisCtx m f)     => m (f Status)-bgsave  = sendRequest (["BGSAVE"] )+configResetstat  = sendRequest (["CONFIG","RESETSTAT"] ) -slaveof+del     :: (RedisCtx m f)-    => ByteString -- ^ host-    -> ByteString -- ^ port-    -> m (f Status)-slaveof host port = sendRequest (["SLAVEOF"] ++ [encode host] ++ [encode port] )+    => [ByteString] -- ^ key+    -> m (f Integer)+del key = sendRequest (["DEL"] ++ map encode key ) -debugObject+zrevrank     :: (RedisCtx m f)     => ByteString -- ^ key-    -> m (f ByteString)-debugObject key = sendRequest (["DEBUG","OBJECT"] ++ [encode key] )+    -> ByteString -- ^ member+    -> m (f (Maybe Integer))+zrevrank key member = sendRequest (["ZREVRANK"] ++ [encode key] ++ [encode member] ) -getset+scriptKill     :: (RedisCtx m f)+    => m (f Status)+scriptKill  = sendRequest (["SCRIPT","KILL"] )++incrby+    :: (RedisCtx m f)     => ByteString -- ^ key-    -> ByteString -- ^ value-    -> m (f (Maybe ByteString))-getset key value = sendRequest (["GETSET"] ++ [encode key] ++ [encode value] )+    -> Integer -- ^ increment+    -> m (f Integer)+incrby key increment = sendRequest (["INCRBY"] ++ [encode key] ++ [encode increment] ) -rpushx+setbit     :: (RedisCtx m f)     => ByteString -- ^ key+    -> Integer -- ^ offset     -> ByteString -- ^ value     -> m (f Integer)-rpushx key value = sendRequest (["RPUSHX"] ++ [encode key] ++ [encode value] )+setbit key offset value = sendRequest (["SETBIT"] ++ [encode key] ++ [encode offset] ++ [encode value] ) -setnx+incrbyfloat     :: (RedisCtx m f)     => ByteString -- ^ key+    -> Double -- ^ increment+    -> m (f Double)+incrbyfloat key increment = sendRequest (["INCRBYFLOAT"] ++ [encode key] ++ [encode increment] )++brpoplpush+    :: (RedisCtx m f)+    => ByteString -- ^ source+    -> ByteString -- ^ destination+    -> Integer -- ^ timeout+    -> m (f (Maybe ByteString))+brpoplpush source destination timeout = sendRequest (["BRPOPLPUSH"] ++ [encode source] ++ [encode destination] ++ [encode timeout] )++rpop+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f (Maybe ByteString))+rpop key = sendRequest (["RPOP"] ++ [encode key] )++setrange+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ offset     -> ByteString -- ^ value-    -> m (f Bool)-setnx key value = sendRequest (["SETNX"] ++ [encode key] ++ [encode value] )+    -> m (f Integer)+setrange key offset value = sendRequest (["SETRANGE"] ++ [encode key] ++ [encode offset] ++ [encode value] ) -zrank+ttl     :: (RedisCtx m f)     => ByteString -- ^ key-    -> ByteString -- ^ member-    -> m (f (Maybe Integer))-zrank key member = sendRequest (["ZRANK"] ++ [encode key] ++ [encode member] )+    -> m (f Integer)+ttl key = sendRequest (["TTL"] ++ [encode key] )  zremrangebyscore     :: (RedisCtx m f)@@ -605,11 +626,12 @@     -> m (f Integer) zremrangebyscore key min max = sendRequest (["ZREMRANGEBYSCORE"] ++ [encode key] ++ [encode min] ++ [encode max] ) -ttl+zrank     :: (RedisCtx m f)     => ByteString -- ^ key-    -> m (f Integer)-ttl key = sendRequest (["TTL"] ++ [encode key] )+    -> ByteString -- ^ member+    -> m (f (Maybe Integer))+zrank key member = sendRequest (["ZRANK"] ++ [encode key] ++ [encode member] )  hkeys     :: (RedisCtx m f)@@ -617,6 +639,12 @@     -> m (f [ByteString]) hkeys key = sendRequest (["HKEYS"] ++ [encode key] ) +dump+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f ByteString)+dump key = sendRequest (["DUMP"] ++ [encode key] )+ rpush     :: (RedisCtx m f)     => ByteString -- ^ key@@ -624,11 +652,6 @@     -> m (f Integer) rpush key value = sendRequest (["RPUSH"] ++ [encode key] ++ map encode value ) -randomkey-    :: (RedisCtx m f)-    => m (f (Maybe ByteString))-randomkey  = sendRequest (["RANDOMKEY"] )- pttl     :: (RedisCtx m f)     => ByteString -- ^ key@@ -641,6 +664,11 @@     -> m (f (Maybe ByteString)) spop key = sendRequest (["SPOP"] ++ [encode key] ) +randomkey+    :: (RedisCtx m f)+    => m (f (Maybe ByteString))+randomkey  = sendRequest (["RANDOMKEY"] )+ hsetnx     :: (RedisCtx m f)     => ByteString -- ^ key@@ -655,122 +683,66 @@     -> m (f [(ByteString,ByteString)]) configGet parameter = sendRequest (["CONFIG","GET"] ++ [encode parameter] ) -hvals-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f [ByteString])-hvals key = sendRequest (["HVALS"] ++ [encode key] )--exists-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f Bool)-exists key = sendRequest (["EXISTS"] ++ [encode key] )--sunion-    :: (RedisCtx m f)-    => [ByteString] -- ^ key-    -> m (f [ByteString])-sunion key = sendRequest (["SUNION"] ++ map encode key )--zrem-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> [ByteString] -- ^ member-    -> m (f Integer)-zrem key member = sendRequest (["ZREM"] ++ [encode key] ++ map encode member )--smembers-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f [ByteString])-smembers key = sendRequest (["SMEMBERS"] ++ [encode key] )--ping-    :: (RedisCtx m f)-    => m (f Status)-ping  = sendRequest (["PING"] )--rename+mset     :: (RedisCtx m f)-    => ByteString -- ^ key-    -> ByteString -- ^ newkey+    => [(ByteString,ByteString)] -- ^ keyValue     -> m (f Status)-rename key newkey = sendRequest (["RENAME"] ++ [encode key] ++ [encode newkey] )+mset keyValue = sendRequest (["MSET"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue ) -decr+setex     :: (RedisCtx m f)     => ByteString -- ^ key-    -> m (f Integer)-decr key = sendRequest (["DECR"] ++ [encode key] )--select-    :: (RedisCtx m f)-    => Integer -- ^ index+    -> Integer -- ^ seconds+    -> ByteString -- ^ value     -> m (f Status)-select index = sendRequest (["SELECT"] ++ [encode index] )--hexists-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> ByteString -- ^ field-    -> m (f Bool)-hexists key field = sendRequest (["HEXISTS"] ++ [encode key] ++ [encode field] )+setex key seconds value = sendRequest (["SETEX"] ++ [encode key] ++ [encode seconds] ++ [encode value] ) -sinterstore+sunionstore     :: (RedisCtx m f)     => ByteString -- ^ destination     -> [ByteString] -- ^ key     -> m (f Integer)-sinterstore destination key = sendRequest (["SINTERSTORE"] ++ [encode destination] ++ map encode key )+sunionstore destination key = sendRequest (["SUNIONSTORE"] ++ [encode destination] ++ map encode key ) -configSet+scriptExists     :: (RedisCtx m f)-    => ByteString -- ^ parameter-    -> ByteString -- ^ value-    -> m (f Status)-configSet parameter value = sendRequest (["CONFIG","SET"] ++ [encode parameter] ++ [encode value] )+    => [ByteString] -- ^ script+    -> m (f [Bool])+scriptExists script = sendRequest (["SCRIPT","EXISTS"] ++ map encode script ) -renamenx+brpop     :: (RedisCtx m f)-    => ByteString -- ^ key-    -> ByteString -- ^ newkey-    -> m (f Bool)-renamenx key newkey = sendRequest (["RENAMENX"] ++ [encode key] ++ [encode newkey] )+    => [ByteString] -- ^ key+    -> Integer -- ^ timeout+    -> m (f (Maybe (ByteString,ByteString)))+brpop key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout] ) -expireat+psetex     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Integer -- ^ timestamp-    -> m (f Bool)-expireat key timestamp = sendRequest (["EXPIREAT"] ++ [encode key] ++ [encode timestamp] )+    -> Integer -- ^ milliseconds+    -> ByteString -- ^ value+    -> m (f Status)+psetex key milliseconds value = sendRequest (["PSETEX"] ++ [encode key] ++ [encode milliseconds] ++ [encode value] ) -get+rpoplpush     :: (RedisCtx m f)-    => ByteString -- ^ key+    => ByteString -- ^ source+    -> ByteString -- ^ destination     -> m (f (Maybe ByteString))-get key = sendRequest (["GET"] ++ [encode key] )--lrem-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> Integer -- ^ count-    -> ByteString -- ^ value-    -> m (f Integer)-lrem key count value = sendRequest (["LREM"] ++ [encode key] ++ [encode count] ++ [encode value] )+rpoplpush source destination = sendRequest (["RPOPLPUSH"] ++ [encode source] ++ [encode destination] ) -incr+hlen     :: (RedisCtx m f)     => ByteString -- ^ key     -> m (f Integer)-incr key = sendRequest (["INCR"] ++ [encode key] )+hlen key = sendRequest (["HLEN"] ++ [encode key] ) -pexpireat+hgetall     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Integer -- ^ millisecondsTimestamp-    -> m (f Bool)-pexpireat key millisecondsTimestamp = sendRequest (["PEXPIREAT"] ++ [encode key] ++ [encode millisecondsTimestamp] )+    -> m (f [(ByteString,ByteString)])+hgetall key = sendRequest (["HGETALL"] ++ [encode key] )  zcard     :: (RedisCtx m f)@@ -786,13 +758,6 @@     -> m (f Status) ltrim key start stop = sendRequest (["LTRIM"] ++ [encode key] ++ [encode start] ++ [encode stop] ) -append-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> ByteString -- ^ value-    -> m (f Integer)-append key value = sendRequest (["APPEND"] ++ [encode key] ++ [encode value] )- lset     :: (RedisCtx m f)     => ByteString -- ^ key@@ -801,6 +766,13 @@     -> m (f Status) lset key index value = sendRequest (["LSET"] ++ [encode key] ++ [encode index] ++ [encode value] ) +append+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> m (f Integer)+append key value = sendRequest (["APPEND"] ++ [encode key] ++ [encode value] )+ info     :: (RedisCtx m f)     => m (f ByteString)@@ -819,67 +791,130 @@     -> m (f [ByteString]) sdiff key = sendRequest (["SDIFF"] ++ map encode key ) -smove+getrange     :: (RedisCtx m f)-    => ByteString -- ^ source-    -> ByteString -- ^ destination+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ end+    -> m (f ByteString)+getrange key start end = sendRequest (["GETRANGE"] ++ [encode key] ++ [encode start] ++ [encode end] )++zcount+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> m (f Integer)+zcount key min max = sendRequest (["ZCOUNT"] ++ [encode key] ++ [encode min] ++ [encode max] )++srem+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> [ByteString] -- ^ member+    -> m (f Integer)+srem key member = sendRequest (["SREM"] ++ [encode key] ++ map encode member )++quit+    :: (RedisCtx m f)+    => m (f Status)+quit  = sendRequest (["QUIT"] )++scriptLoad+    :: (RedisCtx m f)+    => ByteString -- ^ script+    -> m (f ByteString)+scriptLoad script = sendRequest (["SCRIPT","LOAD"] ++ [encode script] )++getbit+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ offset+    -> m (f Integer)+getbit key offset = sendRequest (["GETBIT"] ++ [encode key] ++ [encode offset] )++msetnx+    :: (RedisCtx m f)+    => [(ByteString,ByteString)] -- ^ keyValue+    -> m (f Bool)+msetnx keyValue = sendRequest (["MSETNX"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue )++sismember+    :: (RedisCtx m f)+    => ByteString -- ^ key     -> ByteString -- ^ member     -> m (f Bool)-smove source destination member = sendRequest (["SMOVE"] ++ [encode source] ++ [encode destination] ++ [encode member] )+sismember key member = sendRequest (["SISMEMBER"] ++ [encode key] ++ [encode member] ) -flushdb+select     :: (RedisCtx m f)-    => m (f Status)-flushdb  = sendRequest (["FLUSHDB"] )+    => Integer -- ^ index+    -> m (f Status)+select index = sendRequest (["SELECT"] ++ [encode index] ) -set+sinterstore     :: (RedisCtx m f)+    => ByteString -- ^ destination+    -> [ByteString] -- ^ key+    -> m (f Integer)+sinterstore destination key = sendRequest (["SINTERSTORE"] ++ [encode destination] ++ map encode key )++restore+    :: (RedisCtx m f)     => ByteString -- ^ key+    -> Integer -- ^ timeToLive+    -> ByteString -- ^ serializedValue+    -> m (f Status)+restore key timeToLive serializedValue = sendRequest (["RESTORE"] ++ [encode key] ++ [encode timeToLive] ++ [encode serializedValue] )++configSet+    :: (RedisCtx m f)+    => ByteString -- ^ parameter     -> ByteString -- ^ value     -> m (f Status)-set key value = sendRequest (["SET"] ++ [encode key] ++ [encode value] )+configSet parameter value = sendRequest (["CONFIG","SET"] ++ [encode parameter] ++ [encode value] ) -zremrangebyrank+hexists     :: (RedisCtx m f)     => ByteString -- ^ key-    -> Integer -- ^ start-    -> Integer -- ^ stop-    -> m (f Integer)-zremrangebyrank key start stop = sendRequest (["ZREMRANGEBYRANK"] ++ [encode key] ++ [encode start] ++ [encode stop] )+    -> ByteString -- ^ field+    -> m (f Bool)+hexists key field = sendRequest (["HEXISTS"] ++ [encode key] ++ [encode field] ) -sadd+scriptFlush     :: (RedisCtx m f)-    => ByteString -- ^ key-    -> [ByteString] -- ^ member-    -> m (f Integer)-sadd key member = sendRequest (["SADD"] ++ [encode key] ++ map encode member )+    => m (f Status)+scriptFlush  = sendRequest (["SCRIPT","FLUSH"] ) -lpush+llen     :: (RedisCtx m f)     => ByteString -- ^ key-    -> [ByteString] -- ^ value     -> m (f Integer)-lpush key value = sendRequest (["LPUSH"] ++ [encode key] ++ map encode value )+llen key = sendRequest (["LLEN"] ++ [encode key] ) -lindex+lastsave     :: (RedisCtx m f)-    => ByteString -- ^ key-    -> Integer -- ^ index-    -> m (f (Maybe ByteString))-lindex key index = sendRequest (["LINDEX"] ++ [encode key] ++ [encode index] )+    => m (f Integer)+lastsave  = sendRequest (["LASTSAVE"] ) -zscore+mget     :: (RedisCtx m f)+    => [ByteString] -- ^ key+    -> m (f [Maybe ByteString])+mget key = sendRequest (["MGET"] ++ map encode key )++zadd+    :: (RedisCtx m f)     => ByteString -- ^ key-    -> ByteString -- ^ member-    -> m (f (Maybe Double))-zscore key member = sendRequest (["ZSCORE"] ++ [encode key] ++ [encode member] )+    -> [(Double,ByteString)] -- ^ scoreMember+    -> m (f Integer)+zadd key scoreMember = sendRequest (["ZADD"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])scoreMember ) -strlen+decrby     :: (RedisCtx m f)     => ByteString -- ^ key+    -> Integer -- ^ decrement     -> m (f Integer)-strlen key = sendRequest (["STRLEN"] ++ [encode key] )+decrby key decrement = sendRequest (["DECRBY"] ++ [encode key] ++ [encode decrement] )  hset     :: (RedisCtx m f)@@ -889,23 +924,18 @@     -> m (f Bool) hset key field value = sendRequest (["HSET"] ++ [encode key] ++ [encode field] ++ [encode value] ) +srandmember+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f (Maybe ByteString))+srandmember key = sendRequest (["SRANDMEMBER"] ++ [encode key] )+ lpushx     :: (RedisCtx m f)     => ByteString -- ^ key     -> ByteString -- ^ value     -> m (f Integer) lpushx key value = sendRequest (["LPUSHX"] ++ [encode key] ++ [encode value] )--debugSegfault-    :: (RedisCtx m f)-    => m (f Status)-debugSegfault  = sendRequest (["DEBUG","SEGFAULT"] )--srandmember-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f (Maybe ByteString))-srandmember key = sendRequest (["SRANDMEMBER"] ++ [encode key] )  persist     :: (RedisCtx m f)

@@ -1,36 +1,25 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, RecordWildCards,-    DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies,-    FlexibleInstances #-}+    MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}  module Database.Redis.Core (-    Connection(..), connect,+    Connection, connect,     ConnectInfo(..), defaultConnectInfo,     Redis(),runRedis,     RedisCtx(..), MonadRedis(..),     send, recv, sendRequest,-    HostName, PortID(..),-    ConnectionLostException(..),     auth ) where  import Prelude hiding (catch) import Control.Applicative-import Control.Arrow import Control.Monad.Reader-import Control.Concurrent (ThreadId, forkIO, killThread)-import Control.Concurrent.BoundedChan-import Control.Exception-import qualified Data.Attoparsec as P import qualified Data.ByteString as B-import Data.IORef import Data.Pool import Data.Time-import Data.Typeable import Network-import System.IO-import System.IO.Unsafe  import Database.Redis.Protocol+import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Types  @@ -43,7 +32,7 @@ -- --  In this context, each result is wrapped in an 'Either' to account for the --  possibility of Redis returning an 'Error' reply.-newtype Redis a = Redis (ReaderT RedisEnv IO a)+newtype Redis a = Redis (ReaderT (PP.Connection Reply) IO a)     deriving (Monad, MonadIO, Functor, Applicative)  -- |This class captures the following behaviour: In a context @m@, a command@@ -74,53 +63,17 @@  -- |Internal version of 'runRedis' that does not depend on the 'Connection' --  abstraction. Used to run the AUTH command when connecting. -runRedisInternal :: RedisEnv -> Redis a -> IO a+runRedisInternal :: PP.Connection Reply -> Redis a -> IO a runRedisInternal env (Redis redis) = runReaderT redis env  ------------------------------------------------------------------------------------ Redis Environment.------- |The per-connection environment the 'Redis' monad can read from.------  Create with 'newEnv'. Modified by 'recv' and 'send'.-data RedisEnv = Env-    { envHandle   :: Handle            -- ^ Connection socket-handle.-    , envReplies  :: IORef [Reply]     -- ^ Reply thunks.-    , envThunks   :: BoundedChan Reply -- ^ Syncs user and eval threads.-    , envEvalTId  :: ThreadId          -- ^ 'ThreadID' of the evaluator thread.-    }---- |Create a new 'RedisEnv'-newEnv :: Handle -> IO RedisEnv-newEnv envHandle = do-    replies     <- hGetReplies envHandle-    envReplies  <- newIORef replies-    envThunks   <- newBoundedChan 1000-    envEvalTId  <- forkIO $ forceThunks envThunks-    return Env{..}-  where-    forceThunks thunks = do-        -- We must wait for a reply to become available. Otherwise we will-        -- flush the output buffer (in hGetReplies) before a command is written-        -- by the user thread, creating a deadlock.-        t <- readChan thunks-        t `seq` forceThunks thunks- recv :: (MonadRedis m) => m Reply-recv = liftRedis $ Redis $ do-    Env{..} <- ask-    liftIO $ do        -        r <- atomicModifyIORef envReplies (tail &&& head)-        writeChan envThunks r-        return r+recv = liftRedis $ Redis $ ask >>= liftIO . PP.recv  send :: (MonadRedis m) => [B.ByteString] -> m () send req = liftRedis $ Redis $ do-    h <- asks envHandle-    -- hFlushing the handle is done while reading replies.-    liftIO $ {-# SCC "send.hPut" #-} B.hPut h (renderRequest req)+    conn <- ask+    liftIO $ PP.send conn (renderRequest req)  -- |'sendRequest' can be used to implement commands from experimental --  versions of Redis. An example of how to implement a command is given@@ -134,7 +87,11 @@ -- sendRequest :: (RedisCtx m f, RedisResult a)     => [B.ByteString] -> m (f a)-sendRequest req = send req >> recv >>= returnDecode+sendRequest req = do+    r <- liftRedis $ Redis $ do+        conn <- ask+        liftIO $ PP.request conn (renderRequest req)+    returnDecode r   --------------------------------------------------------------------------------@@ -143,12 +100,7 @@  -- |A threadsafe pool of network connections to a Redis server. Use the --  'connect' function to create one.-newtype Connection = Conn (Pool RedisEnv)--data ConnectionLostException = ConnectionLost-    deriving (Show, Typeable)--instance Exception ConnectionLostException+newtype Connection = Conn (Pool (PP.Connection Reply))  -- |Information for connnecting to a Redis server. --@@ -174,7 +126,9 @@     --   value is 1.     , connectMaxIdleTime    :: NominalDiffTime     -- ^ Amount of time for which an unused connection is kept open. The-    --   smallest acceptable value is 0.5 seconds.+    --   smallest acceptable value is 0.5 seconds. If the @timeout@ value in+    --   your redis.conf file is non-zero, it should be larger than+    --   'connectMaxIdleTime'.     }  -- |Default information for connecting:@@ -203,50 +157,13 @@     createPool create destroy 1 connectMaxIdleTime connectMaxConnections   where     create = do-        h <- connectTo connectHost connectPort-        hSetBinaryMode h True-        conn <- newEnv h+        conn <- PP.connect connectHost connectPort reply         maybe (return ())-            (\pass -> runRedisInternal conn (auth pass) >> return ())+            (void . runRedisInternal conn . auth)             connectAuth         return conn -    destroy Env{..} = do-        open <- hIsOpen envHandle-        when open (hClose envHandle)-        killThread envEvalTId---- |Read all the 'Reply's from the Handle and return them as a lazy list.------  The actual reading and parsing of each 'Reply' is deferred until the spine---  of the list is evaluated up to that 'Reply'. Each 'Reply' is cons'd in front---  of the (unevaluated) list of all remaining replies.------  'unsafeInterleaveIO' only evaluates it's result once, making this function ---  thread-safe. 'Handle' as implemented by GHC is also threadsafe, it is safe---  to call 'hFlush' here. The list constructor '(:)' must be called from---  /within/ unsafeInterleaveIO, to keep the replies in correct order.-hGetReplies :: Handle -> IO [Reply]-hGetReplies h = go B.empty-  where-    go rest = unsafeInterleaveIO $ do        -        parseResult <- P.parseWith readMore reply rest-        case parseResult of-            P.Fail _ _ _   -> errConnClosed-            P.Partial _    -> error "Hedis: parseWith returned Partial"-            P.Done rest' r -> do-                rs <- go rest'-                return (r:rs)--    readMore = do-        hFlush h -- send any pending requests-        B.hGetSome h maxRead `catchIOError` const errConnClosed--    maxRead       = 4*1024-    errConnClosed = throwIO ConnectionLost--    catchIOError :: IO a -> (IOError -> IO a) -> IO a-    catchIOError = catch+    destroy = PP.disconnect  -- The AUTH command. It has to be here because it is used in 'connect'. auth

@@ -351,3 +351,53 @@     sendRequest $ ["EVALSHA", script, encode numkeys] ++ keys ++ args   where     numkeys = toInteger (length keys)++bitcount+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+bitcount key = sendRequest ["BITCOUNT", key]++bitcountRange+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ end+    -> m (f Integer)+bitcountRange key start end =+    sendRequest ["BITCOUNT", key, encode start, encode end]++bitopAnd+    :: (RedisCtx m f)+    => ByteString -- ^ destkey+    -> [ByteString] -- ^ srckeys+    -> m (f Integer)+bitopAnd dst srcs = bitop "AND" (dst:srcs)++bitopOr+    :: (RedisCtx m f)+    => ByteString -- ^ destkey+    -> [ByteString] -- ^ srckeys+    -> m (f Integer)+bitopOr dst srcs = bitop "OR" (dst:srcs)++bitopXor+    :: (RedisCtx m f)+    => ByteString -- ^ destkey+    -> [ByteString] -- ^ srckeys+    -> m (f Integer)+bitopXor dst srcs = bitop "XOR" (dst:srcs)++bitopNot+    :: (RedisCtx m f)+    => ByteString -- ^ destkey+    -> ByteString -- ^ srckey+    -> m (f Integer)+bitopNot dst src = bitop "NOT" [dst, src]++bitop+    :: (RedisCtx m f)+    => ByteString -- ^ operation+    -> [ByteString] -- ^ keys+    -> m (f Integer)+bitop op ks = sendRequest $ "BITOP" : op : ks

@@ -0,0 +1,131 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}++-- |A module for automatic, optimal protocol pipelining.+--+--  Protocol pipelining is a technique in which multiple requests are written+--  out to a single socket without waiting for the corresponding responses.+--  The pipelining of requests results in a dramatic improvement in protocol+--  performance.+--+--  [Optimal Pipelining] uses the least number of network packets possible+--+--  [Automatic Pipelining] means that requests are implicitly pipelined as much+--      as possible, i.e. as long as a request's response is not used before any+--      subsequent requests.+--+--  We use a BoundedChan to make sure the evaluator thread can only start to+--  evaluate a reply after the request is written to the output buffer.+--  Otherwise we will flush the output buffer (in hGetReplies) before a command+--  is written by the user thread, creating a deadlock.+--+--+--  # Notes+--+--  [Eval thread synchronization]+--      * BoundedChan performs better than Control.Concurrent.STM.TBQueue+--+module Database.Redis.ProtocolPipelining (+    Connection,+    connect, disconnect, request, send, recv,+    ConnectionLostException(..),+    HostName, PortID(..)+) where++import           Prelude hiding (catch)+import           Control.Concurrent (ThreadId, forkIO, killThread)+import           Control.Concurrent.BoundedChan+import           Control.Exception+import           Control.Monad+import           Data.Attoparsec+import qualified Data.ByteString as S+import           Data.IORef+import           Data.Typeable+import           Network+import           System.IO+import           System.IO.Unsafe+++data Connection a = Conn+    { connHandle   :: Handle        -- ^ Connection socket-handle.+    , connReplies  :: IORef [a]     -- ^ Reply thunks.+    , connThunks   :: BoundedChan a -- ^ See note [Eval thread synchronization].+    , connEvalTId  :: ThreadId      -- ^ 'ThreadID' of the eval thread.+    }++data ConnectionLostException = ConnectionLost+    deriving (Show, Typeable)++instance Exception ConnectionLostException++connect+    :: HostName+    -> PortID+    -> Parser a+    -> IO (Connection a)+connect host port parser = do+    connHandle  <- connectTo host port+    hSetBinaryMode connHandle True+    rs          <- hGetReplies connHandle parser+    connReplies <- newIORef rs+    connThunks  <- newBoundedChan 1000+    connEvalTId <- forkIO $ forever $ readChan connThunks >>= evaluate+    return Conn{..}++disconnect :: Connection a -> IO ()+disconnect Conn{..} = do+    open <- hIsOpen connHandle+    when open (hClose connHandle)+    killThread connEvalTId++-- |Write the request to the socket output buffer.+--+--  The 'Handle' is 'hFlush'ed when reading replies.+send :: Connection a -> S.ByteString -> IO ()+send Conn{..} = S.hPut connHandle++-- |Take a reply from the list of future replies.+--+--  'head' and 'tail' are used to get a thunk of the reply. Pattern matching (:)+--   would block until a reply could be read.+recv :: Connection a -> IO a+recv Conn{..} = do+    rs <- readIORef connReplies+    writeIORef connReplies (tail rs)+    let r = head rs+    writeChan connThunks r+    return r++request :: Connection a -> S.ByteString -> IO a+request conn req = send conn req >> recv conn++-- |Read all the replies from the Handle and return them as a lazy list.+--+--  The actual reading and parsing of each 'Reply' is deferred until the spine+--  of the list is evaluated up to that 'Reply'. Each 'Reply' is cons'd in front+--  of the (unevaluated) list of all remaining replies.+--+--  'unsafeInterleaveIO' only evaluates it's result once, making this function +--  thread-safe. 'Handle' as implemented by GHC is also threadsafe, it is safe+--  to call 'hFlush' here. The list constructor '(:)' must be called from+--  /within/ unsafeInterleaveIO, to keep the replies in correct order.+hGetReplies :: Handle -> Parser a -> IO [a]+hGetReplies h parser = go S.empty+  where+    go rest = unsafeInterleaveIO $ do        +        parseResult <- parseWith readMore parser rest+        case parseResult of+            Fail{}       -> errConnClosed+            Partial{}    -> error "Hedis: parseWith returned Partial"+            Done rest' r -> do+                rs <- go rest'+                return (r:rs)++    readMore = do+        hFlush h -- send any pending requests+        S.hGetSome h maxRead `catchIOError` const errConnClosed++    maxRead       = 4*1024+    errConnClosed = throwIO ConnectionLost++    catchIOError :: IO a -> (IOError -> IO a) -> IO a+    catchIOError = catch

@@ -13,7 +13,6 @@ import Control.Monad import Control.Monad.State import Data.ByteString.Char8 (ByteString)-import Data.Maybe import Data.Monoid import qualified Database.Redis.Core as Core import Database.Redis.Protocol (Reply(..))

@@ -7,9 +7,9 @@ ) where  import Control.Applicative-import Control.Monad.State+import Control.Monad.State.Strict import Data.ByteString (ByteString)-import Data.Monoid+import Data.Vector (Vector, fromList, (!))  import Database.Redis.Core import Database.Redis.Protocol@@ -22,20 +22,21 @@ --  In the 'RedisTx' context, all commands return a 'Queued' value. It is a --  proxy object for the /actual/ result, which will only be available after --  finishing the transaction.-newtype RedisTx a = RedisTx (StateT ([Reply] -> Reply) Redis a)+newtype RedisTx a = RedisTx (StateT Int Redis a)     deriving (Monad, MonadIO, Functor, Applicative)  runRedisTx :: RedisTx a -> Redis a-runRedisTx (RedisTx r) = evalStateT r head+runRedisTx (RedisTx r) = evalStateT r 0  instance MonadRedis RedisTx where     liftRedis = RedisTx . lift  instance RedisCtx RedisTx Queued where     returnDecode _queued = RedisTx $ do-        f <- get-        put (f . tail)-        return $ Queued (decode . f)+        -- future index in EXEC result list+        i <- get+        put (i+1)+        return $ Queued (decode . (!i))  -- |A 'Queued' value represents the result of a command inside a transaction. It --  is a proxy object for the /actual/ result, which will only be available@@ -43,7 +44,7 @@ -- --  'Queued' values are composable by utilizing the 'Functor', 'Applicative' or --  'Monad' interfaces.-data Queued a = Queued ([Reply] -> Either Reply a)+data Queued a = Queued (Vector Reply -> Either Reply a)  instance Functor Queued where     fmap f (Queued g) = Queued (fmap f . g)@@ -62,11 +63,6 @@                                 let Queued f' = f x'                                 f' rs -instance (Monoid a) => Monoid (Queued a) where-    mempty        = return mempty-    mappend q1 q2 = mappend <$> q1 <*> q2-- -- | Result of a 'multiExec' transaction. data TxResult a     = TxSuccess a@@ -113,6 +109,8 @@ --  @ multiExec :: RedisTx (Queued a) -> Redis (TxResult a) multiExec rtx = do+    -- We don't need to catch exceptions and call DISCARD. The pool will close+    -- the connection anyway.     _        <- multi     Queued f <- runRedisTx rtx     r        <- exec@@ -120,7 +118,7 @@         MultiBulk rs ->             return $ maybe                 TxAborted-                (either (TxError . show) TxSuccess . f)+                (either (TxError . show) TxSuccess . f . fromList)                 rs         _ -> error $ "hedis: EXEC returned " ++ show r 

@@ -4,10 +4,9 @@ module Database.Redis.Types where  import Control.Applicative-import Control.Monad import Data.ByteString.Char8 (ByteString, pack) import Data.ByteString.Lex.Double (readDouble)-import Data.Maybe+import Data.ByteString.Lex.Integral (readSigned, readDecimal)  import Database.Redis.Protocol @@ -52,7 +51,8 @@  instance RedisResult Integer where     decode (Integer n) = Right n-    decode r           = Left r+    decode r           =+        maybe (Left r) (Right . fst) . readSigned readDecimal =<< decode r  instance RedisResult Int where     decode = fmap fromInteger . decode

@@ -9,8 +9,9 @@ import Data.Monoid (mappend) import Data.Time import Data.Time.Clock.POSIX-import qualified Test.HUnit as Test-import Test.HUnit (runTestTT, (~:))+import qualified Test.Framework as Test (Test, defaultMain)+import qualified Test.Framework.Providers.HUnit as Test (testCase)+import qualified Test.HUnit as HUnit  import Database.Redis @@ -20,41 +21,50 @@ -- main :: IO () main = do-    c <- connect defaultConnectInfo-    runTestTT $ Test.TestList $ map ($c) tests-    return ()+    conn <- connect defaultConnectInfo+    Test.defaultMain (tests conn)  type Test = Connection -> Test.Test  testCase :: String -> Redis () -> Test-testCase name r conn = name ~:-    Test.TestCase $ runRedis conn $ flushdb >>=? Ok >> r+testCase name r conn = Test.testCase name $ do+    withTimeLimit 0.5 $ runRedis conn $ flushdb >>=? Ok >> r+  where+    withTimeLimit limit act = do+        start <- getCurrentTime+        act+        deltaT <-fmap (`diffUTCTime` start) getCurrentTime+        when (deltaT > limit) $+            putStrLn $ name ++ ": " ++ show deltaT      (>>=?) :: (Eq a, Show a) => Redis (Either Reply a) -> a -> Redis () redis >>=? expected = do     a <- redis     liftIO $ case a of-        Left reply   -> Test.assertFailure $ "Redis error: " ++ show reply-        Right actual -> expected Test.@=? actual+        Left reply   -> HUnit.assertFailure $ "Redis error: " ++ show reply+        Right actual -> expected HUnit.@=? actual  assert :: Bool -> Redis ()-assert = liftIO . Test.assert+assert = liftIO . HUnit.assert  ------------------------------------------------------------------------------ -- Tests ---tests :: [Test]-tests = concat-    [ testsMisc, testsKeys, testsStrings, testsHashes, testsLists, testsZSets-    , [testPubSub], [testTransaction], [testScripting], testsConnection-    , testsServer, [testQuit]+tests :: Connection -> [Test.Test]+tests conn = map ($conn) $ concat+    [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets+    , testsZSets, [testPubSub], [testTransaction], [testScripting]+    , testsConnection, testsServer, [testQuit]     ]  ------------------------------------------------------------------------------ -- Miscellaneous -- testsMisc :: [Test]-testsMisc = [testConstantSpacePipelining, testForceErrorReply, testPipelining]+testsMisc =+    [ testConstantSpacePipelining, testForceErrorReply, testPipelining+    , testEvalReplies+    ]  testConstantSpacePipelining :: Test testConstantSpacePipelining = testCase "constant-space pipelining" $ do@@ -89,91 +99,54 @@         redis         liftIO $ fmap (`diffUTCTime` start) getCurrentTime +testEvalReplies :: Test+testEvalReplies conn = testCase "eval unused replies" go conn+  where+    go = do+        _ignored <- set "key" "value"+        (liftIO $ do+            threadDelay $ 10^(5::Int)+            mvar <- newEmptyMVar+            forkIO $ runRedis conn (get "key") >>= putMVar mvar+            takeMVar mvar)+          >>=? Just "value"+ ------------------------------------------------------------------------------ -- Keys -- testsKeys :: [Test]-testsKeys =-    [ testDel, testExists, testExpire, testExpireAt, testKeys, testMove-    , testPersist, testRandomkey, testRename, testRenamenx, testSort-    , testTtl, testGetType, testObject-    ]--testDel :: Test-testDel = testCase "del" $ do-    set "key" "value" >>=? Ok-    get "key"         >>=? Just "value"-    del ["key"]       >>=? 1-    get "key"         >>=? Nothing--testExists :: Test-testExists = testCase "exists" $ do-    exists "key"      >>=? False-    set "key" "value" >>=? Ok-    exists "key"      >>=? True+testsKeys = [ testKeys, testExpireAt, testSort, testGetType, testObject ] -testExpire :: Test-testExpire = testCase "expire" $ do-    set "key" "value"  >>=? Ok-    expire "key" 1     >>=? True-    expire "notAKey" 1 >>=? False-    ttl "key"          >>=? 1+testKeys :: Test+testKeys = testCase "keys" $ do+    set "key" "value"     >>=? Ok+    get "key"             >>=? Just "value"+    exists "key"          >>=? True+    keys "*"              >>=? ["key"]+    randomkey             >>=? Just "key"+    move "key" 13         >>=? True+    select 13             >>=? Ok+    expire "key" 1        >>=? True+    pexpire "key" 1000    >>=? True+    Right t <- ttl "key"+    assert $ t `elem` [0..1]+    Right pt <- pttl "key"+    assert $ pt `elem` [990..1000]+    persist "key"         >>=? True+    Right s <- dump "key"+    restore "key'" 0 s    >>=? Ok+    rename "key" "key'"   >>=? Ok+    renamenx "key'" "key" >>=? True+    del ["key"]           >>=? 1+    select 0              >>=? Ok      testExpireAt :: Test testExpireAt = testCase "expireat" $ do-    set "key" "value"         >>=? Ok-    seconds <- floor . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime-    let expiry = seconds + 1-    expireat "key" expiry     >>=? True-    expireat "notAKey" expiry >>=? False-    ttl "key"                 >>=? 1--testKeys :: Test-testKeys = testCase "keys" $ do-    keys "key*"      >>=? []-    set "key1" "value" >>=? Ok-    set "key2" "value" >>=? Ok-    Right ks <- keys "key*"-    assert $ length ks == 2-    assert $ elem "key1" ks-    assert $ elem "key2" ks--testMove :: Test-testMove = testCase "move" $ do-    set "key" "value" >>=? Ok-    move "key" 13     >>=? True-    get "key"         >>=? Nothing-    select 13         >>=? Ok-    get "key"         >>=? Just "value"--testPersist :: Test-testPersist = testCase "persist" $ do-    set "key" "value" >>=? Ok-    expire "key" 1    >>=? True-    ttl "key"         >>=? 1-    persist "key"     >>=? True-    ttl "key"         >>=? (-1)--testRandomkey :: Test-testRandomkey = testCase "randomkey" $ do-    set "k1" "value" >>=? Ok-    set "k2" "value" >>=? Ok-    Right (Just k) <- randomkey-    assert $ k `elem` ["k1", "k2"]--testRename :: Test-testRename = testCase "rename" $ do-    set "k1" "value" >>=? Ok-    rename "k1" "k2" >>=? Ok-    get "k1"         >>=? Nothing-    get "k2"         >>=? Just ("value" )--testRenamenx :: Test-testRenamenx = testCase "renamenx" $ do-    set "k1" "value"   >>=? Ok-    set "k2" "value"   >>=? Ok-    renamenx "k1" "k2" >>=? False-    renamenx "k1" "k3" >>=? True+    set "key" "value"             >>=? Ok+    t <- ceiling . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime+    let expiry = t+1+    expireat "key" expiry         >>=? True+    pexpireat "key" (expiry*1000) >>=? True  testSort :: Test testSort = testCase "sort" $ do@@ -193,14 +166,6 @@                                , sortGet   = ["#", "object_*"] }     sort "ids" opts >>=? ["2", "bar", "1", "foo"]     -    -testTtl :: Test-testTtl = testCase "ttl" $ do-    set "key" "value" >>=? Ok-    ttl "notAKey"     >>=? (-1)-    ttl "key"         >>=? (-1)-    expire "key" 42   >>=? True-    ttl "key"         >>=? 42  testGetType :: Test testGetType = testCase "getType" $ do@@ -228,274 +193,142 @@ -- Strings -- testsStrings :: [Test]-testsStrings =-    [ testAppend, testDecr, testDecrby, testGetbit, testGetrange, testGetset-    , testIncr, testIncrby, testMget, testMset, testMsetnx, testSetbit-    , testSetex, testSetnx, testSetrange, testStrlen, testSetAndGet-    ]--testAppend :: Test-testAppend = testCase "append" $ do-    set "key" "hello"    >>=? Ok-    append "key" "world" >>=? 10-    get "key"            >>=? Just "helloworld"--testDecr :: Test-testDecr = testCase "decr" $ do-    set "key" "42" >>=? Ok-    decr "key"     >>=? 41--testDecrby :: Test-testDecrby = testCase "decrby" $ do-    set "key" "42"  >>=? Ok-    decrby "key" 2  >>=? 40--testGetbit :: Test-testGetbit = testCase "getbit" $ getbit "key" 42 >>=? 0--testGetrange :: Test-testGetrange = testCase "getrange" $ do-    set "key" "value"     >>=? Ok-    getrange "key" 1 (-2) >>=? "alu"--testGetset :: Test-testGetset = testCase "getset" $ do-    getset "key" "v1" >>=? Nothing-    getset "key" "v2" >>=? Just "v1"--testIncr :: Test-testIncr = testCase "incr" $ do-    set "key" "42" >>=? Ok-    incr "key"     >>=? 43--testIncrby :: Test-testIncrby = testCase "incrby" $ do-    set "key" "40" >>=? Ok-    incrby "key" 2 >>=? 42--testMget :: Test-testMget = testCase "mget" $ do-    set "k1" "v1"               >>=? Ok-    set "k2" "v2"               >>=? Ok-    mget ["k1","k2","notAKey" ] >>=? [Just "v1", Just "v2", Nothing]--testMset :: Test-testMset = testCase "mset" $ do-    mset [("k1","v1"), ("k2","v2")] >>=? Ok-    get "k1"                        >>=? Just "v1"-    get "k2"                        >>=? Just "v2"+testsStrings = [testStrings, testBitops] -testMsetnx :: Test-testMsetnx = testCase "msetnx" $ do-    msetnx [("k1","v1"), ("k2","v2")] >>=? True+testStrings :: Test+testStrings = testCase "strings" $ do+    setnx "key" "value"               >>=? True+    getset "key" "hello"              >>=? Just "value"+    append "key" "world"              >>=? 10+    strlen "key"                      >>=? 10+    setrange "key" 0 "hello"          >>=? 10+    getrange "key" 0 4                >>=? "hello"+    mset [("k1","v1"), ("k2","v2")]   >>=? Ok     msetnx [("k1","v1"), ("k2","v2")] >>=? False--testSetbit :: Test-testSetbit = testCase "setbit" $ do-    setbit "key" 42 "1" >>=? 0-    setbit "key" 42 "0" >>=? 1+    mget ["key"]                      >>=? [Just "helloworld"]+    setex "key" 1 "42"                >>=? Ok+    psetex "key" 1000 "42"            >>=? Ok+    decr "key"                        >>=? 41+    decrby "key" 1                    >>=? 40+    incr "key"                        >>=? 41+    incrby "key" 1                    >>=? 42+    incrbyfloat "key" 1               >>=? 43+    del ["key"]                       >>=? 1+    setbit "key" 42 "1"               >>=? 0+    getbit "key" 42                   >>=? 1+    bitcount "key"                    >>=? 1+    bitcountRange "key" 0 (-1)        >>=? 1     -testSetex :: Test-testSetex = testCase "setex" $ do-    setex "key" 1 "value" >>=? Ok-    ttl "key"             >>=? 1--testSetnx :: Test-testSetnx = testCase "setnx" $ do-    setnx "key" "v1" >>=? True-    setnx "key" "v2" >>=? False--testSetrange :: Test-testSetrange = testCase "setrange" $ do-    set "key" "value"      >>=? Ok-    setrange "key" 1 "ers" >>=? 5-    get "key"              >>=? Just "verse"--testStrlen :: Test-testStrlen = testCase "strlen" $ do-    set "key" "value" >>=? Ok-    strlen "key"      >>=? 5--testSetAndGet :: Test-testSetAndGet = testCase "set/get" $ do-    get "key"         >>=? Nothing-    set "key" "value" >>=? Ok-    get "key"         >>=? Just "value"-+testBitops :: Test+testBitops = testCase "bitops" $ do+    set "k1" "a"               >>=? Ok+    set "k2" "b"               >>=? Ok+    bitopAnd "k3" ["k1", "k2"] >>=? 1+    bitopOr "k3" ["k1", "k2"]  >>=? 1+    bitopXor "k3" ["k1", "k2"] >>=? 1+    bitopNot "k3" "k1"         >>=? 1  ------------------------------------------------------------------------------ -- Hashes ---testsHashes :: [Test]-testsHashes =-    [ testHdel, testHexists,testHget, testHgetall, testHincrby, testHkeys-    , testHlen, testHmget, testHmset, testHset, testHsetnx, testHvals-    ]--testHdel :: Test-testHdel = testCase "hdel" $ do-    hdel "key" ["field"]       >>=? False-    hset "key" "field" "value" >>=? True-    hdel "key" ["field"]       >>=? True--testHexists :: Test-testHexists = testCase "hexists" $ do-    hexists "key" "field"      >>=? False-    hset "key" "field" "value" >>=? True-    hexists "key" "field"      >>=? True--testHget :: Test-testHget = testCase "hget" $ do-    hget "key" "field"         >>=? Nothing-    hset "key" "field" "value" >>=? True-    hget "key" "field"         >>=? Just "value"--testHgetall :: Test-testHgetall = testCase "hgetall" $ do-    hgetall "key"                         >>=? []-    hmset "key" [("f1","v1"),("f2","v2")] >>=? Ok-    hgetall "key"                         >>=? [("f1","v1"), ("f2","v2")]-    -testHincrby :: Test-testHincrby = testCase "hincrby" $ do-    hset "key" "field" "40" >>=? True-    hincrby "key" "field" 2 >>=? 42--testHkeys :: Test-testHkeys = testCase "hkeys" $ do-    hset "key" "field" "value" >>=? True-    hkeys "key"                >>=? ["field"]--testHlen :: Test-testHlen = testCase "hlen" $ do-    hlen "key"                 >>=? 0-    hset "key" "field" "value" >>=? True-    hlen "key"                 >>=? 1--testHmget :: Test-testHmget = testCase "hmget" $ do-    hmset "key" [("f1","v1"), ("f2","v2")] >>=? Ok-    hmget "key" ["f1", "f2", "nofield" ]   >>=? [Just "v1", Just "v2", Nothing]--testHmset :: Test-testHmset = testCase "hmset" $ do-    hmset "key" [("f1","v1"), ("f2","v2")] >>=? Ok--testHset :: Test-testHset = testCase "hset" $ do-    hset "key" "field" "value" >>=? True-    hset "key" "field" "value" >>=? False--testHsetnx :: Test-testHsetnx = testCase "hsetnx" $ do-    hsetnx "key" "field" "value" >>=? True+testHashes :: Test+testHashes = testCase "hashes" $ do+    hset "key" "field" "value"   >>=? True     hsetnx "key" "field" "value" >>=? False--testHvals :: Test-testHvals = testCase "hvals" $ do-    hset "key" "field" "value" >>=? True-    hvals "key"                >>=? ["value"]-+    hexists "key" "field"        >>=? True+    hlen "key"                   >>=? 1+    hget "key" "field"           >>=? Just "value"+    hmget "key" ["field", "-"]   >>=? [Just "value", Nothing]+    hgetall "key"                >>=? [("field","value")]+    hkeys "key"                  >>=? ["field"]+    hvals "key"                  >>=? ["value"]+    hdel "key" ["field"]         >>=? True+    hmset "key" [("field","40")] >>=? Ok+    hincrby "key" "field" 2      >>=? 42+    hincrbyfloat "key" "field" 2 >>=? 44  ------------------------------------------------------------------------------ -- Lists -- testsLists :: [Test] testsLists =-    [testBlpop, testBrpoplpush, testLpop, testLinsert, testLpushx, testLset]--testBlpop :: Test-testBlpop = testCase "blpop/brpop" $ do-    lpush "key" ["v3","v2","v1"] >>=? 3-    blpop ["notAKey","key"] 1    >>=? Just ("key","v1")-    brpop ["notAKey","key"] 1    >>=? Just ("key","v3")-    -- run into timeout-    blpop ["notAKey"] 1          >>=? Nothing+    [testLists, testBpop] -testBrpoplpush :: Test-testBrpoplpush = testCase "brpoplpush/rpoplpush" $ do-    rpush "k1" ["v1","v2"]      >>=? 2-    brpoplpush "k1" "k2" 1      >>=? Just "v2"-    rpoplpush "k1" "k2"         >>=? Just "v1"-    rpoplpush "notAKey" "k2"    >>=? Nothing-    llen "k2"                   >>=? 2-    llen "k1"                   >>=? 0-    -- run into timeout-    brpoplpush "notAKey" "k2" 1 >>=? Nothing+testLists :: Test+testLists = testCase "lists" $ do+    lpushx "notAKey" "-"          >>=? 0+    rpushx "notAKey" "-"          >>=? 0+    lpush "key" ["value"]         >>=? 1+    lpop "key"                    >>=? Just "value"+    rpush "key" ["value"]         >>=? 1+    rpop "key"                    >>=? Just "value"+    rpush "key" ["v2"]            >>=? 1+    linsertBefore "key" "v2" "v1" >>=? 2+    linsertAfter "key" "v2" "v3"  >>=? 3    +    lindex "key" 0                >>=? Just "v1"+    lrange "key" 0 (-1)           >>=? ["v1", "v2", "v3"]+    lset "key" 1 "v2"             >>=? Ok+    lrem "key" 0 "v2"             >>=? 1+    llen "key"                    >>=? 2+    ltrim "key" 0 1               >>=? Ok -testLpop :: Test-testLpop = testCase "lpop/rpop" $ do+testBpop :: Test+testBpop = testCase "blocking push/pop" $ do     lpush "key" ["v3","v2","v1"] >>=? 3-    lpop "key"                   >>=? Just "v1"-    llen "key"                   >>=? 2-    rpop "key"                   >>=? Just "v3"--testLinsert :: Test-testLinsert = testCase "linsert" $ do-    rpush "key" ["v2"]                 >>=? 1-    linsertBefore "key" "v2" "v1"      >>=? 2-    linsertBefore "key" "notAVal" "v3" >>=? (-1)-    linsertAfter "key" "v2" "v3"       >>=? 3    -    linsertAfter "key" "notAVal" "v3"  >>=? (-1)-    lindex "key" 0                     >>=? Just "v1"-    lindex "key" 2                     >>=? Just "v3"--testLpushx :: Test-testLpushx = testCase "lpushx/rpushx" $ do-    lpushx "notAKey" "v1" >>=? 0-    lpush "key" ["v2"]    >>=? 1-    lpushx "key" "v1"     >>=? 2-    rpushx "key" "v3"     >>=? 3--testLset :: Test-testLset = testCase "lset/lrem/ltrim" $ do-    lpush "key" ["v3","v2","v2","v1","v1"] >>=? 5-    lset "key" 1 "v2"                      >>=? Ok-    lrem "key" 2 "v2"                      >>=? 2-    llen "key"                             >>=? 3-    ltrim "key" 0 1                        >>=? Ok-    lrange "key" 0 1                       >>=? ["v1", "v2"]-+    blpop ["key"] 1              >>=? Just ("key","v1")+    brpop ["key"] 1              >>=? Just ("key","v3")+    rpush "k1" ["v1","v2"]       >>=? 2+    brpoplpush "k1" "k2" 1       >>=? Just "v2"+    rpoplpush "k1" "k2"          >>=? Just "v1"+     ------------------------------------------------------------------------------ -- Sets --+testsSets :: [Test]+testsSets = [testSets, testSetAlgebra] +testSets :: Test+testSets = testCase "sets" $ do+    sadd "set" ["member"]       >>=? 1+    sismember "set" "member"    >>=? True+    scard "set"                 >>=? 1+    smembers "set"              >>=? ["member"]+    srandmember "set"           >>=? Just "member"+    spop "set"                  >>=? Just "member"+    srem "set" ["member"]       >>=? 0+    smove "set" "set'" "member" >>=? False++testSetAlgebra :: Test+testSetAlgebra = testCase "set algebra" $ do+    sadd "s1" ["member"]          >>=? 1+    sdiff ["s1", "s2"]            >>=? ["member"]+    sunion ["s1", "s2"]           >>=? ["member"]+    sinter ["s1", "s2"]           >>=? []+    sdiffstore "s3" ["s1", "s2"]  >>=? 1+    sunionstore "s3" ["s1", "s2"] >>=? 1+    sinterstore "s3" ["s1", "s2"] >>=? 0+ ------------------------------------------------------------------------------ -- Sorted Sets -- testsZSets :: [Test]-testsZSets = [testZAdd, testZRank, testZRemRange, testZRange, testZStore]--testZAdd :: Test-testZAdd = testCase "zadd/zrem/zcard/zscore/zincrby" $ do-    zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 3-    zscore "key" "v3"                        >>=? Just 40-    zincrby "key" 2 "v3"                     >>=? 42-    zrem "key" ["v3","notAKey"]              >>=? 1-    zcard "key"                              >>=? 2--testZRank :: Test-testZRank = testCase "zrank/zrevrank/zcount" $ do-    zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 3-    zrank "notAKey" "v1"                     >>=? Nothing-    zrank "key" "v1"                         >>=? Just 0-    zrevrank "key" "v1"                      >>=? Just 2-    zcount "key" 10 100                      >>=? 1+testsZSets = [testZSets, testZStore] -testZRemRange :: Test-testZRemRange = testCase "zremrangebyscore/zremrangebyrank" $ do-    zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 3-    zremrangebyrank "key" 0 1                >>=? 2-    zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 2-    zremrangebyscore "key" 10 100            >>=? 1+testZSets :: Test+testZSets = testCase "sorted sets" $ do+    zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")]          >>=? 3+    zcard "key"                                       >>=? 3+    zscore "key" "v3"                                 >>=? Just 40+    zincrby "key" 2 "v3"                              >>=? 42+                                                     +    zrank "key" "v1"                                  >>=? Just 0+    zrevrank "key" "v1"                               >>=? Just 2+    zcount "key" 10 100                               >>=? 1 -testZRange :: Test-testZRange = testCase "zrange/zrevrange/zrangebyscore/zrevrangebyscore" $ do-    zadd "key" [(1,"v1"),(2,"v2"),(3,"v3")]           >>=? 3     zrange "key" 0 1                                  >>=? ["v1","v2"]     zrevrange "key" 0 1                               >>=? ["v3","v2"]     zrangeWithscores "key" 0 1                        >>=? [("v1",1),("v2",2)]-    zrevrangeWithscores "key" 0 1                     >>=? [("v3",3),("v2",2)]+    zrevrangeWithscores "key" 0 1                     >>=? [("v3",42),("v2",2)]     zrangebyscore "key" 0.5 1.5                       >>=? ["v1"]     zrangebyscoreWithscores "key" 0.5 1.5             >>=? [("v1",1)]     zrangebyscoreLimit "key" 0.5 2.5 0 1              >>=? ["v1"]@@ -504,6 +337,10 @@     zrevrangebyscoreWithscores "key" 1.5 0.5          >>=? [("v1",1)]     zrevrangebyscoreLimit "key" 2.5 0.5 0 1           >>=? ["v2"]     zrevrangebyscoreWithscoresLimit "key" 2.5 0.5 0 1 >>=? [("v2",2)]+    +    zrem "key" ["v2"]                                 >>=? 1+    zremrangebyscore "key" 10 100                     >>=? 1+    zremrangebyrank "key" 0 0                         >>=? 1  testZStore :: Test testZStore = testCase "zunionstore/zinterstore" $ do@@ -541,7 +378,7 @@                 PMessage{..} -> return (punsubscribe [msgPattern])          pubSub (subscribe [] `mappend` psubscribe []) $ \_ -> do-            liftIO $ Test.assertFailure "no subs: should return immediately"+            liftIO $ HUnit.assertFailure "no subs: should return immediately"             undefined  ------------------------------------------------------------------------------@@ -575,10 +412,14 @@         scriptExists [scriptHash, "notAScript"] >>=? [True, False]         scriptFlush                             >>=? Ok         -- start long running script from another client-        liftIO $ forkIO $ runRedis conn $ do-            Left _ <- eval "while true do end" [] []-                        :: Redis (Either Reply Integer)-            return ()+        configSet "lua-time-limit" "100"        >>=? Ok+        liftIO $ do+            forkIO $ runRedis conn $ do+                -- we must pattern match to block the thread+                Left _ <- eval "while true do end" [] []+                    :: Redis (Either Reply Integer)+                return ()+            threadDelay $ 10^(5 :: Int)         scriptKill                              >>=? Ok  ------------------------------------------------------------------------------@@ -608,18 +449,27 @@ -- testsServer :: [Test] testsServer =-    [testBgrewriteaof, testFlushall, testInfo, testConfig, testSlowlog-    ,testDebugObject]+    [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig+    ,testSlowlog, testDebugObject] +testServer :: Test+testServer = testCase "server" $ do+    Right (_,_) <- time+    slaveof "no" "one" >>=? Ok+    return ()+ testBgrewriteaof :: Test testBgrewriteaof = testCase "bgrewriteaof/bgsave/save" $ do     save >>=? Ok     Right (Status _) <- bgsave+    -- Redis needs time to finish the bgsave+    liftIO $ threadDelay (10^(5 :: Int))     Right (Status _) <- bgrewriteaof     return ()  testConfig :: Test testConfig = testCase "config/auth" $ do+    configGet "requirepass"        >>=? [("requirepass", "")]     configSet "requirepass" "pass" >>=? Ok     auth "pass"                    >>=? Ok     configSet "requirepass" ""     >>=? Ok@@ -646,5 +496,4 @@ testDebugObject = testCase "debugObject/debugSegfault" $ do     set "key" "value" >>=? Ok     Right _ <- debugObject "key"-    -- Right Ok <- debugSegfault     return ()