diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs --- a/benchmark/Benchmark.hs +++ b/benchmark/Benchmark.hs @@ -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 () + diff --git a/hedis.cabal b/hedis.cabal --- a/hedis.cabal +++ b/hedis.cabal @@ -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 () 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 diff --git a/src/Database/Redis.hs b/src/Database/Redis.hs --- a/src/Database/Redis.hs +++ b/src/Database/Redis.hs @@ -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 diff --git a/src/Database/Redis/Commands.hs b/src/Database/Redis/Commands.hs --- a/src/Database/Redis/Commands.hs +++ b/src/Database/Redis/Commands.hs @@ -13,10 +13,12 @@ -- ** Keys del, -- |Delete a key (). +dump, -- |Return a serialized version of the value stored at the specified key. (). exists, -- |Determine if a key exists (). expire, -- |Set a key's time to live in seconds (). expireat, -- |Set the expiration for a key as a UNIX timestamp (). keys, -- |Find all keys matching the given pattern (). +migrate, -- |Atomically transfer a key from a Redis instance to another one. (). move, -- |Move a key to another database (). objectRefcount, -- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. objectEncoding, -- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. @@ -28,6 +30,7 @@ randomkey, -- |Return a random key from the keyspace (). rename, -- |Rename a key (). renamenx, -- |Rename a key, only if the new key does not exist (). +restore, -- |Create a key using the provided serialized value, previously obtained using DUMP. (). SortOpts(..), defaultSortOpts, SortOrder(..), @@ -73,8 +76,8 @@ rpushx, -- |Append a value to a list, only if the list exists (). -- ** Scripting -eval, -- |Execute a Lua script server side (). The Redis command @EVAL@ is split up into 'eval', 'evalsha'. -evalsha, -- |Execute a Lua script server side (). The Redis command @EVAL@ is split up into 'eval', 'evalsha'. +eval, -- |Execute a Lua script server side (). +evalsha, -- |Execute a Lua script server side (). scriptExists, -- |Check existence of scripts in the script cache. (). scriptFlush, -- |Remove all the scripts from the script cache. (). scriptKill, -- |Kill the script currently in execution. (). @@ -88,7 +91,6 @@ configSet, -- |Set a configuration parameter to the given value (). dbsize, -- |Return the number of keys in the selected database (). debugObject, -- |Get debugging information about a key (). -debugSegfault, -- |Make the server crash (). flushall, -- |Remove all keys from all databases (). flushdb, -- |Remove all keys from the current database (). info, -- |Get information and statistics about the server (). @@ -148,6 +150,12 @@ -- ** Strings append, -- |Append a value to a key (). +bitcount, -- |Count set bits in a string (). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. +bitcountRange, -- |Count set bits in a string (). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. +bitopAnd, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. +bitopOr, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. +bitopXor, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. +bitopNot, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. decr, -- |Decrement the integer value of a key by one (). decrby, -- |Decrement the integer value of a key by the given number (). get, -- |Get the value of a key (). @@ -182,6 +190,9 @@ -- -- * SHUTDOWN () -- +-- +-- * 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) diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -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 diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -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 diff --git a/src/Database/Redis/ProtocolPipelining.hs b/src/Database/Redis/ProtocolPipelining.hs new file mode 100644 --- /dev/null +++ b/src/Database/Redis/ProtocolPipelining.hs @@ -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 diff --git a/src/Database/Redis/PubSub.hs b/src/Database/Redis/PubSub.hs --- a/src/Database/Redis/PubSub.hs +++ b/src/Database/Redis/PubSub.hs @@ -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(..)) diff --git a/src/Database/Redis/Transactions.hs b/src/Database/Redis/Transactions.hs --- a/src/Database/Redis/Transactions.hs +++ b/src/Database/Redis/Transactions.hs @@ -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 diff --git a/src/Database/Redis/Types.hs b/src/Database/Redis/Types.hs --- a/src/Database/Redis/Types.hs +++ b/src/Database/Redis/Types.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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 ()