hedis-0.6.9/0000755000000000000000000000000012552420631011010 5ustar0000000000000000hedis-0.6.9/CHANGELOG0000644000000000000000000000236412552420631012227 0ustar0000000000000000# Changelog for Hedis ## 0.6.4 * New connection option to automatically SELECT a database. ## 0.5 -> 0.6 * Changed return type of HDEL from Bool to Integer. * Some documentation updates. ## 0.5 -> 0.5.1 * New commands: DUMP, RESTORE, BITOP, BITCOUNT. * Removed the dependency on stm. * Improved performance of Queued in long transactions. * Minor documentation updates. ## 0.4.1 -> 0.5 * Added new Redis 2.6 commands, including Lua scripting support. * A transaction context is now created by using the 'multiExec' function. 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'. * The 'getType' command (the Redis TYPE command) now has a custom return type 'RedisType'. * Minor improvements and fixes to the documentation. ## 0.3.2 -> 0.4.1 * The following commands got a 'Maybe' added to their return type, to properly handle Redis returning `nil`-replies: `brpoplpush`, `lindex`, `lpop`, `objectEncoding`, `randomkey`, `rpop`, `rpoplpush`, `spop`, `srandmember`, `zrank`, `zrevrank`, `zscore`. * Updated dependencies on `bytestring-lexing` and `stm`. * Minor improvements and fixes to the documentation. hedis-0.6.9/hedis.cabal0000644000000000000000000000747612552420631013106 0ustar0000000000000000name: hedis version: 0.6.9 synopsis: Client library for the Redis datastore: supports full command set, pipelining. Description: Redis is an open source, advanced key-value store. It is often referred to as a data structure server since keys can contain strings, hashes, lists, sets and sorted sets. This library is a Haskell client for the Redis datastore. Compared to other Haskell client libraries it has some advantages: . [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 further commands, such as new commands from an experimental Redis version. . [Automatic Optimal Pipelining:] Commands are pipelined () as much as possible without any work by the user. See for a technical explanation of automatic optimal pipelining. . [Enforced Pub\/Sub semantics:] When subscribed to the Redis Pub\/Sub server (), clients are not allowed to issue commands other than subscribing to or unsubscribing from channels. This library uses the type system to enforce the correct behavior. . [Connect via TCP or Unix Domain Socket:] TCP sockets are the default way to connect to a Redis server. For connections to a server on the same machine, Unix domain sockets offer higher performance than the standard TCP connection. . For detailed documentation, see the "Database.Redis" module. . license: BSD3 license-file: LICENSE author: Falko Peters maintainer: falko.peters@gmail.com copyright: Copyright (c) 2011 Falko Peters category: Database build-type: Simple cabal-version: >=1.8 homepage: https://github.com/informatikr/hedis bug-reports: https://github.com/informatikr/hedis/issues extra-source-files: CHANGELOG source-repository head type: git location: https://github.com/informatikr/hedis library hs-source-dirs: src ghc-options: -Wall -fwarn-tabs ghc-prof-options: -auto-all exposed-modules: Database.Redis build-depends: attoparsec >= 0.12, base >= 4.6 && < 5, BoundedChan >= 1.0, bytestring >= 0.9, bytestring-lexing >= 0.5, mtl >= 2, network >= 2, resource-pool >= 0.2, time, vector >= 0.9 other-modules: Database.Redis.Core, Database.Redis.ProtocolPipelining, Database.Redis.Protocol, Database.Redis.PubSub, Database.Redis.Transactions, Database.Redis.Types Database.Redis.Commands, Database.Redis.ManualCommands benchmark hedis-benchmark type: exitcode-stdio-1.0 main-is: benchmark/Benchmark.hs build-depends: base == 4.*, mtl == 2.*, hedis, time >= 1.2 ghc-options: -O2 -Wall -rtsopts ghc-prof-options: -auto-all test-suite hedis-test type: exitcode-stdio-1.0 main-is: test/Test.hs build-depends: base == 4.*, bytestring >= 0.9 && < 0.11, 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 hedis-0.6.9/LICENSE0000644000000000000000000000276112552420631012023 0ustar0000000000000000Copyright (c)2011, Falko Peters All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Falko Peters nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hedis-0.6.9/Setup.hs0000644000000000000000000000005612552420631012445 0ustar0000000000000000import Distribution.Simple main = defaultMain hedis-0.6.9/benchmark/0000755000000000000000000000000012552420631012742 5ustar0000000000000000hedis-0.6.9/benchmark/Benchmark.hs0000644000000000000000000000546412552420631015201 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Concurrent import Control.Monad import Control.Monad.Trans import Data.Time import Database.Redis import Text.Printf nRequests, nClients :: Int nRequests = 100000 nClients = 50 main :: IO () main = do ---------------------------------------------------------------------- -- Preparation -- conn <- connect defaultConnectInfo runRedis conn $ do _ <- flushall Right _ <- mset [ ("k1","v1"), ("k2","v2"), ("k3","v3") , ("k4","v4"), ("k5","v5") ] return () ---------------------------------------------------------------------- -- Spawn clients -- start <- newEmptyMVar done <- newEmptyMVar replicateM_ nClients $ forkIO $ do runRedis conn $ forever $ do action <- liftIO $ takeMVar start action liftIO $ putMVar done () let timeAction name nActions action = do startT <- getCurrentTime -- each clients runs ACTION nRepetitions times let nRepetitions = nRequests `div` nClients `div` nActions replicateM_ nClients $ putMVar start (replicateM_ nRepetitions action) replicateM_ nClients $ takeMVar done stopT <- getCurrentTime let deltaT = realToFrac $ diffUTCTime stopT startT -- the real # of reqs send. We might have lost some due to 'div'. actualReqs = nRepetitions * nActions * nClients rqsPerSec = fromIntegral actualReqs / deltaT :: Double putStrLn $ printf "%-20s %10.2f Req/s" (name :: String) rqsPerSec ---------------------------------------------------------------------- -- Benchmarks -- timeAction "ping" 1 $ do Right Pong <- ping return () timeAction "get" 1 $ do Right Nothing <- get "key" return () timeAction "mget" 1 $ do Right vs <- mget ["k1","k2","k3","k4","k5"] let expected = map Just ["v1","v2","v3","v4","v5"] True <- return $ vs == expected return () timeAction "ping (pipelined)" 100 $ do pongs <- replicateM 100 ping 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 () hedis-0.6.9/src/0000755000000000000000000000000012552420631011577 5ustar0000000000000000hedis-0.6.9/src/Database/0000755000000000000000000000000012552420631013303 5ustar0000000000000000hedis-0.6.9/src/Database/Redis.hs0000644000000000000000000001437712552420631014721 0ustar0000000000000000module Database.Redis ( -- * How To Use This Module -- | -- Connect to a Redis server: -- -- @ -- -- connects to localhost:6379 -- conn <- 'connect' 'defaultConnectInfo' -- @ -- -- Send commands to the server: -- -- @ -- {-\# LANGUAGE OverloadedStrings \#-} -- ... -- 'runRedis' conn $ do -- 'set' \"hello\" \"hello\" -- set \"world\" \"world\" -- hello <- 'get' \"hello\" -- world <- get \"world\" -- liftIO $ print (hello,world) -- @ -- ** Command Type Signatures -- |Redis commands behave differently when issued in- or outside of a -- transaction. To make them work in both contexts, most command functions -- have a type signature similar to the following: -- -- @ -- 'echo' :: ('RedisCtx' m f) => ByteString -> m (f ByteString) -- @ -- -- Here is how to interpret this type signature: -- -- * The argument types are independent of the execution context. 'echo' -- always takes a 'ByteString' parameter, whether in- or outside of a -- transaction. This is true for all command functions. -- -- * All Redis commands return their result wrapped in some \"container\". -- The type @f@ of this container depends on the commands execution -- context @m@. The 'ByteString' return type in the example is specific -- to the 'echo' command. For other commands, it will often be another -- type. -- -- * In the \"normal\" context 'Redis', outside of any transactions, -- results are wrapped in an @'Either' 'Reply'@. -- -- * Inside a transaction, in the 'RedisTx' context, results are wrapped in -- a 'Queued'. -- -- In short, you can view any command with a 'RedisCtx' constraint in the -- type signature, to \"have two types\". For example 'echo' \"has both -- types\": -- -- @ -- echo :: ByteString -> Redis (Either Reply ByteString) -- echo :: ByteString -> RedisTx (Queued ByteString) -- @ -- -- [Exercise] What are the types of 'expire' inside a transaction and -- 'lindex' outside of a transaction? The solutions are at the very -- bottom of this page. -- ** Lua Scripting -- |Lua values returned from the 'eval' and 'evalsha' functions will be -- converted to Haskell values by the 'decode' function from the -- 'RedisResult' type class. -- -- @ -- Lua Type | Haskell Type | Conversion Example -- --------------|--------------------|----------------------------- -- Number | Integer | 1.23 => 1 -- String | ByteString, Double | \"1.23\" => \"1.23\" or 1.23 -- Boolean | Bool | false => False -- Table | List | {1,2} => [1,2] -- @ -- -- Additionally, any of the Haskell types from the table above can be -- wrapped in a 'Maybe': -- -- @ -- 42 => Just 42 :: Maybe Integer -- nil => Nothing :: Maybe Integer -- @ -- -- Note that Redis imposes some limitations on the possible conversions: -- -- * Lua numbers can only be converted to Integers. Only Lua strings can be -- interpreted as Doubles. -- -- * Associative Lua tables can not be converted at all. Returned tables -- must be \"arrays\", i.e. indexed only by integers. -- -- The Redis Scripting website () -- documents the exact semantics of the scripting commands and value -- conversion. -- ** Automatic Pipelining -- |Commands are automatically pipelined as much as possible. For example, -- in the above \"hello world\" example, all four commands are pipelined. -- Automatic pipelining makes use of Haskell's laziness. As long as a -- previous reply is not evaluated, subsequent commands can be pipelined. -- -- Automatic pipelining also works across several calls to 'runRedis', as -- long as replies are only evaluated /outside/ the 'runRedis' block. -- -- To keep memory usage low, the number of requests \"in the pipeline\" is -- limited (per connection) to 1000. After that number, the next command is -- sent only when at least one reply has been received. That means, command -- functions may block until there are less than 1000 outstanding replies. -- -- ** Error Behavior -- | -- [Operations against keys holding the wrong kind of value:] Outside of a -- transaction, if the Redis server returns an 'Error', command functions -- will return 'Left' the 'Reply'. The library user can inspect the error -- 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'. -- -- [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, RedisCtx(), MonadRedis(), -- * Connection Connection, connect, ConnectInfo(..),defaultConnectInfo, HostName,PortID(..), -- * Commands module Database.Redis.Commands, -- * Transactions module Database.Redis.Transactions, -- * Pub\/Sub module Database.Redis.PubSub, -- * Low-Level Command API sendRequest, Reply(..),Status(..),RedisResult(..),ConnectionLostException(..), -- |[Solution to Exercise] -- -- Type of 'expire' inside a transaction: -- -- > expire :: ByteString -> Integer -> RedisTx (Queued Bool) -- -- Type of 'lindex' outside of a transaction: -- -- > lindex :: ByteString -> Integer -> Redis (Either Reply ByteString) -- ) where 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 import Database.Redis.Commands hedis-0.6.9/src/Database/Redis/0000755000000000000000000000000012552420631014351 5ustar0000000000000000hedis-0.6.9/src/Database/Redis/Commands.hs0000644000000000000000000011344512552420631016456 0ustar0000000000000000-- Generated by GenCmds.hs. DO NOT EDIT. {-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Database.Redis.Commands ( -- ** Connection auth, -- |Authenticate to the server (). echo, -- |Echo the given string (). ping, -- |Ping the server (). quit, -- |Close the connection (). select, -- |Change the selected database for the current connection (). -- ** 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'. objectIdletime, -- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. persist, -- |Remove the expiration from a key (). pexpire, -- |Set a key's time to live in milliseconds (). pexpireat, -- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (). pttl, -- |Get the time to live for a key in milliseconds (). 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(..), sort, -- |Sort the elements in a list, set or sorted set (). The Redis command @SORT@ is split up into 'sort', 'sortStore'. sortStore, -- |Sort the elements in a list, set or sorted set (). The Redis command @SORT@ is split up into 'sort', 'sortStore'. ttl, -- |Get the time to live for a key (). RedisType(..), getType, -- |Determine the type stored at key (). -- ** Hashes hdel, -- |Delete one or more hash fields (). hexists, -- |Determine if a hash field exists (). hget, -- |Get the value of a hash field (). hgetall, -- |Get all the fields and values in a hash (). hincrby, -- |Increment the integer value of a hash field by the given number (). hincrbyfloat, -- |Increment the float value of a hash field by the given amount (). hkeys, -- |Get all the fields in a hash (). hlen, -- |Get the number of fields in a hash (). hmget, -- |Get the values of all the given hash fields (). hmset, -- |Set multiple hash fields to multiple values (). hset, -- |Set the string value of a hash field (). hsetnx, -- |Set the value of a hash field, only if the field does not exist (). hvals, -- |Get all the values in a hash (). -- ** Lists blpop, -- |Remove and get the first element in a list, or block until one is available (). brpop, -- |Remove and get the last element in a list, or block until one is available (). brpoplpush, -- |Pop a value from a list, push it to another list and return it; or block until one is available (). lindex, -- |Get an element from a list by its index (). linsertBefore, -- |Insert an element before or after another element in a list (). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. linsertAfter, -- |Insert an element before or after another element in a list (). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. llen, -- |Get the length of a list (). lpop, -- |Remove and get the first element in a list (). lpush, -- |Prepend one or multiple values to a list (). lpushx, -- |Prepend a value to a list, only if the list exists (). lrange, -- |Get a range of elements from a list (). lrem, -- |Remove elements from a list (). lset, -- |Set the value of an element in a list by its index (). ltrim, -- |Trim a list to the specified range (). rpop, -- |Remove and get the last element in a list (). rpoplpush, -- |Remove the last element in a list, append it to another list and return it (). rpush, -- |Append one or multiple values to a list (). rpushx, -- |Append a value to a list, only if the list exists (). -- ** Scripting 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. (). scriptLoad, -- |Load the specified Lua script into the script cache. (). -- ** Server bgrewriteaof, -- |Asynchronously rewrite the append-only file (). bgsave, -- |Asynchronously save the dataset to disk (). configGet, -- |Get the value of a configuration parameter (). configResetstat, -- |Reset the stats returned by INFO (). 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 (). flushall, -- |Remove all keys from all databases (). flushdb, -- |Remove all keys from the current database (). info, -- |Get information and statistics about the server (). lastsave, -- |Get the UNIX time stamp of the last successful save to disk (). save, -- |Synchronously save the dataset to disk (). slaveof, -- |Make the server a slave of another instance, or promote it as master (). Slowlog(..), slowlogGet, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. slowlogLen, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. slowlogReset, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. time, -- |Return the current server time (). -- ** Sets sadd, -- |Add one or more members to a set (). scard, -- |Get the number of members in a set (). sdiff, -- |Subtract multiple sets (). sdiffstore, -- |Subtract multiple sets and store the resulting set in a key (). sinter, -- |Intersect multiple sets (). sinterstore, -- |Intersect multiple sets and store the resulting set in a key (). sismember, -- |Determine if a given value is a member of a set (). smembers, -- |Get all the members in a set (). smove, -- |Move a member from one set to another (). spop, -- |Remove and return a random member from a set (). srandmember, -- |Get a random member from a set (). srem, -- |Remove one or more members from a set (). sunion, -- |Add multiple sets (). sunionstore, -- |Add multiple sets and store the resulting set in a key (). -- ** Sorted Sets zadd, -- |Add one or more members to a sorted set, or update its score if it already exists (). zcard, -- |Get the number of members in a sorted set (). zcount, -- |Count the members in a sorted set with scores within the given values (). zincrby, -- |Increment the score of a member in a sorted set (). Aggregate(..), zinterstore, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. zinterstoreWeights, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. zrange, -- |Return a range of members in a sorted set, by index (). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. zrangeWithscores, -- |Return a range of members in a sorted set, by index (). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. zrangebyscore, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. zrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. zrangebyscoreLimit, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. zrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. zrank, -- |Determine the index of a member in a sorted set (). zrem, -- |Remove one or more members from a sorted set (). zremrangebyrank, -- |Remove all members in a sorted set within the given indexes (). zremrangebyscore, -- |Remove all members in a sorted set within the given scores (). zrevrange, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. zrevrangeWithscores, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. zrevrangebyscore, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. zrevrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. zrevrangebyscoreLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. zrevrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. zrevrank, -- |Determine the index of a member in a sorted set, with scores ordered from high to low (). zscore, -- |Get the score associated with the given member in a sorted set (). zunionstore, -- |Add multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. zunionstoreWeights, -- |Add multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. -- ** 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 (). getbit, -- |Returns the bit value at offset in the string value stored at key (). getrange, -- |Get a substring of the string stored at a key (). getset, -- |Set the string value of a key and return its old value (). incr, -- |Increment the integer value of a key by one (). incrby, -- |Increment the integer value of a key by the given amount (). incrbyfloat, -- |Increment the float value of a key by the given amount (). mget, -- |Get the values of all the given keys (). mset, -- |Set multiple keys to multiple values (). msetnx, -- |Set multiple keys to multiple values, only if none of the keys exist (). psetex, -- |Set the value and expiration in milliseconds of a key (). set, -- |Set the string value of a key (). setbit, -- |Sets or clears the bit at offset in the string value stored at key (). setex, -- |Set the value and expiration of a key (). setnx, -- |Set the value of a key, only if the key does not exist (). setrange, -- |Overwrite part of a string at key starting at the specified offset (). strlen, -- |Get the length of the value stored in a key (). -- * Unimplemented Commands -- |These commands are not implemented, as of now. Library -- users can implement these or other commands from -- experimental Redis versions by using the 'sendRequest' -- function. -- -- * MONITOR () -- -- -- * SYNC () -- -- -- * SHUTDOWN () -- -- -- * DEBUG SEGFAULT () -- ) where import Prelude hiding (min,max) import Data.ByteString (ByteString) import Database.Redis.ManualCommands import Database.Redis.Types import Database.Redis.Core bgrewriteaof :: (RedisCtx m f) => m (f Status) bgrewriteaof = sendRequest (["BGREWRITEAOF"] ) sinter :: (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 ) sunionstore :: (RedisCtx m f) => ByteString -- ^ destination -> [ByteString] -- ^ key -> m (f Integer) sunionstore destination key = sendRequest (["SUNIONSTORE"] ++ [encode destination] ++ map encode key ) setex :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ seconds -> ByteString -- ^ value -> m (f Status) setex key seconds value = sendRequest (["SETEX"] ++ [encode key] ++ [encode seconds] ++ [encode value] ) hlen :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) hlen key = sendRequest (["HLEN"] ++ [encode key] ) scard :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) scard key = sendRequest (["SCARD"] ++ [encode key] ) zremrangebyscore :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ min -> Double -- ^ max -> m (f Integer) zremrangebyscore key min max = sendRequest (["ZREMRANGEBYSCORE"] ++ [encode key] ++ [encode min] ++ [encode max] ) rpushx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f Integer) rpushx key value = sendRequest (["RPUSHX"] ++ [encode key] ++ [encode value] ) spop :: (RedisCtx m f) => ByteString -- ^ key -> m (f (Maybe ByteString)) spop key = sendRequest (["SPOP"] ++ [encode key] ) pttl :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) pttl key = sendRequest (["PTTL"] ++ [encode key] ) rpush :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ value -> m (f Integer) rpush key value = sendRequest (["RPUSH"] ++ [encode key] ++ map encode value ) debugObject :: (RedisCtx m f) => ByteString -- ^ key -> m (f ByteString) debugObject key = sendRequest (["DEBUG","OBJECT"] ++ [encode key] ) randomkey :: (RedisCtx m f) => m (f (Maybe ByteString)) randomkey = sendRequest (["RANDOMKEY"] ) bgsave :: (RedisCtx m f) => m (f Status) bgsave = sendRequest (["BGSAVE"] ) 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] ) 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] ) sdiffstore :: (RedisCtx m f) => ByteString -- ^ destination -> [ByteString] -- ^ key -> m (f Integer) sdiffstore destination key = sendRequest (["SDIFFSTORE"] ++ [encode destination] ++ map encode key ) blpop :: (RedisCtx m f) => [ByteString] -- ^ key -> Integer -- ^ timeout -> m (f (Maybe (ByteString,ByteString))) blpop key timeout = sendRequest (["BLPOP"] ++ map encode key ++ [encode timeout] ) 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] ) sismember :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ member -> m (f Bool) sismember key member = sendRequest (["SISMEMBER"] ++ [encode key] ++ [encode member] ) incr :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) incr key = sendRequest (["INCR"] ++ [encode key] ) hget :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> m (f (Maybe ByteString)) hget key field = sendRequest (["HGET"] ++ [encode key] ++ [encode field] ) expireat :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ timestamp -> m (f Bool) expireat key timestamp = sendRequest (["EXPIREAT"] ++ [encode key] ++ [encode timestamp] ) info :: (RedisCtx m f) => m (f ByteString) info = sendRequest (["INFO"] ) sdiff :: (RedisCtx m f) => [ByteString] -- ^ key -> m (f [ByteString]) sdiff key = sendRequest (["SDIFF"] ++ map encode key ) 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 -> Integer -- ^ index -> ByteString -- ^ value -> m (f Status) lset key index value = sendRequest (["LSET"] ++ [encode key] ++ [encode index] ++ [encode value] ) get :: (RedisCtx m f) => ByteString -- ^ key -> m (f (Maybe ByteString)) get key = sendRequest (["GET"] ++ [encode key] ) scriptFlush :: (RedisCtx m f) => m (f Status) scriptFlush = sendRequest (["SCRIPT","FLUSH"] ) lpop :: (RedisCtx m f) => ByteString -- ^ key -> m (f (Maybe ByteString)) lpop key = sendRequest (["LPOP"] ++ [encode key] ) lastsave :: (RedisCtx m f) => m (f Integer) lastsave = sendRequest (["LASTSAVE"] ) dbsize :: (RedisCtx m f) => m (f Integer) dbsize = sendRequest (["DBSIZE"] ) zadd :: (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 ) hmget :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ field -> m (f [Maybe ByteString]) hmget key field = sendRequest (["HMGET"] ++ [encode key] ++ map encode field ) expire :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ seconds -> m (f Bool) expire key seconds = sendRequest (["EXPIRE"] ++ [encode key] ++ [encode seconds] ) mget :: (RedisCtx m f) => [ByteString] -- ^ key -> m (f [Maybe ByteString]) mget key = sendRequest (["MGET"] ++ map encode key ) hexists :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> m (f Bool) hexists key field = sendRequest (["HEXISTS"] ++ [encode key] ++ [encode field] ) 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 ) configSet :: (RedisCtx m f) => ByteString -- ^ parameter -> ByteString -- ^ value -> m (f Status) configSet parameter value = sendRequest (["CONFIG","SET"] ++ [encode parameter] ++ [encode value] ) 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"] ) 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] ) incrbyfloat :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ increment -> m (f Double) incrbyfloat key increment = sendRequest (["INCRBYFLOAT"] ++ [encode key] ++ [encode increment] ) setrange :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ offset -> ByteString -- ^ value -> m (f Integer) setrange key offset value = sendRequest (["SETRANGE"] ++ [encode key] ++ [encode offset] ++ [encode value] ) hincrbyfloat :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> Double -- ^ increment -> m (f Double) hincrbyfloat key field increment = sendRequest (["HINCRBYFLOAT"] ++ [encode key] ++ [encode field] ++ [encode increment] ) zrevrank :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ member -> m (f (Maybe Integer)) zrevrank key member = sendRequest (["ZREVRANK"] ++ [encode key] ++ [encode member] ) lindex :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ index -> m (f (Maybe ByteString)) lindex key index = sendRequest (["LINDEX"] ++ [encode key] ++ [encode index] ) sadd :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ member -> m (f Integer) sadd key member = sendRequest (["SADD"] ++ [encode key] ++ map encode member ) srandmember :: (RedisCtx m f) => ByteString -- ^ key -> m (f (Maybe ByteString)) srandmember key = sendRequest (["SRANDMEMBER"] ++ [encode key] ) zscore :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ member -> m (f (Maybe Double)) zscore key member = sendRequest (["ZSCORE"] ++ [encode key] ++ [encode member] ) persist :: (RedisCtx m f) => ByteString -- ^ key -> m (f Bool) persist key = sendRequest (["PERSIST"] ++ [encode key] ) 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] ) rpoplpush :: (RedisCtx m f) => ByteString -- ^ source -> ByteString -- ^ destination -> m (f (Maybe ByteString)) rpoplpush source destination = sendRequest (["RPOPLPUSH"] ++ [encode source] ++ [encode destination] ) hgetall :: (RedisCtx m f) => ByteString -- ^ key -> m (f [(ByteString,ByteString)]) hgetall key = sendRequest (["HGETALL"] ++ [encode key] ) mset :: (RedisCtx m f) => [(ByteString,ByteString)] -- ^ keyValue -> m (f Status) mset keyValue = sendRequest (["MSET"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue ) 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 ) 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] ) brpop :: (RedisCtx m f) => [ByteString] -- ^ key -> Integer -- ^ timeout -> m (f (Maybe (ByteString,ByteString))) brpop key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout] ) hsetnx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> ByteString -- ^ value -> m (f Bool) hsetnx key field value = sendRequest (["HSETNX"] ++ [encode key] ++ [encode field] ++ [encode value] ) configGet :: (RedisCtx m f) => ByteString -- ^ parameter -> m (f [(ByteString,ByteString)]) configGet parameter = sendRequest (["CONFIG","GET"] ++ [encode parameter] ) zrank :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ member -> m (f (Maybe Integer)) zrank key member = sendRequest (["ZRANK"] ++ [encode key] ++ [encode member] ) hkeys :: (RedisCtx m f) => ByteString -- ^ key -> m (f [ByteString]) hkeys key = sendRequest (["HKEYS"] ++ [encode key] ) ttl :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) ttl key = sendRequest (["TTL"] ++ [encode key] ) getset :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f (Maybe ByteString)) getset key value = sendRequest (["GETSET"] ++ [encode key] ++ [encode value] ) slaveof :: (RedisCtx m f) => ByteString -- ^ host -> ByteString -- ^ port -> m (f Status) slaveof host port = sendRequest (["SLAVEOF"] ++ [encode host] ++ [encode port] ) setnx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f Bool) setnx key value = sendRequest (["SETNX"] ++ [encode key] ++ [encode value] ) dump :: (RedisCtx m f) => ByteString -- ^ key -> m (f ByteString) dump key = sendRequest (["DUMP"] ++ [encode key] ) keys :: (RedisCtx m f) => ByteString -- ^ pattern -> m (f [ByteString]) keys pattern = sendRequest (["KEYS"] ++ [encode pattern] ) echo :: (RedisCtx m f) => ByteString -- ^ message -> m (f ByteString) echo message = sendRequest (["ECHO"] ++ [encode message] ) getbit :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ offset -> m (f Integer) getbit key offset = sendRequest (["GETBIT"] ++ [encode key] ++ [encode offset] ) quit :: (RedisCtx m f) => m (f Status) quit = sendRequest (["QUIT"] ) srem :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ member -> m (f Integer) srem key member = sendRequest (["SREM"] ++ [encode key] ++ map encode member ) move :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ db -> 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] ) msetnx :: (RedisCtx m f) => [(ByteString,ByteString)] -- ^ keyValue -> m (f Bool) msetnx keyValue = sendRequest (["MSETNX"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue ) save :: (RedisCtx m f) => m (f Status) save = sendRequest (["SAVE"] ) ltrim :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f Status) ltrim key start stop = sendRequest (["LTRIM"] ++ [encode key] ++ [encode start] ++ [encode stop] ) 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] ) pexpireat :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ millisecondsTimestamp -> m (f Bool) pexpireat key millisecondsTimestamp = sendRequest (["PEXPIREAT"] ++ [encode key] ++ [encode millisecondsTimestamp] ) zcard :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) zcard key = sendRequest (["ZCARD"] ++ [encode key] ) renamenx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ newkey -> m (f Bool) renamenx key newkey = sendRequest (["RENAMENX"] ++ [encode key] ++ [encode newkey] ) llen :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) llen key = sendRequest (["LLEN"] ++ [encode key] ) pexpire :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ milliseconds -> m (f Bool) pexpire key milliseconds = sendRequest (["PEXPIRE"] ++ [encode key] ++ [encode milliseconds] ) decrby :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ decrement -> m (f Integer) decrby key decrement = sendRequest (["DECRBY"] ++ [encode key] ++ [encode decrement] ) lrange :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f [ByteString]) lrange key start stop = sendRequest (["LRANGE"] ++ [encode key] ++ [encode start] ++ [encode stop] ) sinterstore :: (RedisCtx m f) => ByteString -- ^ destination -> [ByteString] -- ^ key -> m (f Integer) sinterstore destination key = sendRequest (["SINTERSTORE"] ++ [encode destination] ++ map encode key ) rename :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ newkey -> m (f Status) rename key newkey = sendRequest (["RENAME"] ++ [encode key] ++ [encode newkey] ) 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] ) hvals :: (RedisCtx m f) => ByteString -- ^ key -> m (f [ByteString]) hvals key = sendRequest (["HVALS"] ++ [encode key] ) zrem :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ member -> m (f Integer) zrem key member = sendRequest (["ZREM"] ++ [encode key] ++ map encode member ) decr :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) decr key = sendRequest (["DECR"] ++ [encode key] ) configResetstat :: (RedisCtx m f) => m (f Status) configResetstat = sendRequest (["CONFIG","RESETSTAT"] ) flushall :: (RedisCtx m f) => m (f Status) flushall = sendRequest (["FLUSHALL"] ) hdel :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ field -> m (f Integer) hdel key field = sendRequest (["HDEL"] ++ [encode key] ++ map encode field ) setbit :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ offset -> ByteString -- ^ value -> m (f Integer) setbit key offset value = sendRequest (["SETBIT"] ++ [encode key] ++ [encode offset] ++ [encode value] ) del :: (RedisCtx m f) => [ByteString] -- ^ key -> m (f Integer) del key = sendRequest (["DEL"] ++ map encode key ) scriptKill :: (RedisCtx m f) => m (f Status) scriptKill = sendRequest (["SCRIPT","KILL"] ) incrby :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ increment -> m (f Integer) incrby key increment = sendRequest (["INCRBY"] ++ [encode key] ++ [encode increment] ) hincrby :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> Integer -- ^ increment -> 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"] ) hset :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> ByteString -- ^ value -> m (f Bool) hset key field value = sendRequest (["HSET"] ++ [encode key] ++ [encode field] ++ [encode value] ) strlen :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) strlen key = sendRequest (["STRLEN"] ++ [encode key] ) flushdb :: (RedisCtx m f) => m (f Status) flushdb = sendRequest (["FLUSHDB"] ) lpushx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f Integer) lpushx key value = sendRequest (["LPUSHX"] ++ [encode key] ++ [encode value] ) smove :: (RedisCtx m f) => ByteString -- ^ source -> ByteString -- ^ destination -> ByteString -- ^ member -> m (f Bool) smove source destination member = sendRequest (["SMOVE"] ++ [encode source] ++ [encode destination] ++ [encode member] ) zremrangebyrank :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f Integer) zremrangebyrank key start stop = sendRequest (["ZREMRANGEBYRANK"] ++ [encode key] ++ [encode start] ++ [encode stop] ) set :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f Status) set key value = sendRequest (["SET"] ++ [encode key] ++ [encode value] ) lpush :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ value -> m (f Integer) lpush key value = sendRequest (["LPUSH"] ++ [encode key] ++ map encode value ) hedis-0.6.9/src/Database/Redis/Core.hs0000644000000000000000000001443312552420631015602 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, RecordWildCards, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} module Database.Redis.Core ( Connection, connect, ConnectInfo(..), defaultConnectInfo, Redis(),runRedis, RedisCtx(..), MonadRedis(..), send, recv, sendRequest, auth, select ) where import Prelude import Control.Applicative import Control.Monad.Reader import qualified Data.ByteString as B import Data.Pool import Data.Time import Network import Database.Redis.Protocol import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Types -------------------------------------------------------------------------------- -- The Redis Monad -- -- |Context for normal command execution, outside of transactions. Use -- 'runRedis' to run actions of this type. -- -- 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 (PP.Connection Reply) IO a) deriving (Monad, MonadIO, Functor, Applicative) -- |This class captures the following behaviour: In a context @m@, a command -- will return it's result wrapped in a \"container\" of type @f@. -- -- Please refer to the Command Type Signatures section of this page for more -- information. class (MonadRedis m) => RedisCtx m f | m -> f where returnDecode :: RedisResult a => Reply -> m (f a) instance RedisCtx Redis (Either Reply) where returnDecode = return . decode class (Monad m) => MonadRedis m where liftRedis :: Redis a -> m a instance MonadRedis Redis where liftRedis = id -- |Interact with a Redis datastore specified by the given 'Connection'. -- -- Each call of 'runRedis' takes a network connection from the 'Connection' -- pool and runs the given 'Redis' action. Calls to 'runRedis' may thus block -- while all connections from the pool are in use. runRedis :: Connection -> Redis a -> IO a runRedis (Conn pool) redis = withResource pool $ \conn -> runRedisInternal conn redis -- |Internal version of 'runRedis' that does not depend on the 'Connection' -- abstraction. Used to run the AUTH command when connecting. runRedisInternal :: PP.Connection Reply -> Redis a -> IO a runRedisInternal env (Redis redis) = runReaderT redis env recv :: (MonadRedis m) => m Reply recv = liftRedis $ Redis $ ask >>= liftIO . PP.recv send :: (MonadRedis m) => [B.ByteString] -> m () send req = liftRedis $ Redis $ do 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 -- below. -- -- @ -- -- |Redis DEBUG OBJECT command -- debugObject :: ByteString -> 'Redis' (Either 'Reply' ByteString) -- debugObject key = 'sendRequest' [\"DEBUG\", \"OBJECT\", key] -- @ -- sendRequest :: (RedisCtx m f, RedisResult a) => [B.ByteString] -> m (f a) sendRequest req = do r <- liftRedis $ Redis $ do conn <- ask liftIO $ PP.request conn (renderRequest req) returnDecode r -------------------------------------------------------------------------------- -- Connection -- -- |A threadsafe pool of network connections to a Redis server. Use the -- 'connect' function to create one. newtype Connection = Conn (Pool (PP.Connection Reply)) -- |Information for connnecting to a Redis server. -- -- It is recommended to not use the 'ConnInfo' data constructor directly. -- Instead use 'defaultConnectInfo' and update it with record syntax. For -- example to connect to a password protected Redis server running on localhost -- and listening to the default port: -- -- @ -- myConnectInfo :: ConnectInfo -- myConnectInfo = defaultConnectInfo {connectAuth = Just \"secret\"} -- @ -- data ConnectInfo = ConnInfo { connectHost :: HostName , connectPort :: PortID , connectAuth :: Maybe B.ByteString -- ^ When the server is protected by a password, set 'connectAuth' to 'Just' -- the password. Each connection will then authenticate by the 'auth' -- command. , connectDatabase :: Integer -- ^ Each connection will 'select' the database with the given index. , connectMaxConnections :: Int -- ^ Maximum number of connections to keep open. The smallest acceptable -- value is 1. , connectMaxIdleTime :: NominalDiffTime -- ^ Amount of time for which an unused connection is kept open. The -- 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'. } deriving Show -- |Default information for connecting: -- -- @ -- connectHost = \"localhost\" -- connectPort = PortNumber 6379 -- Redis default port -- connectAuth = Nothing -- No password -- connectDatabase = 0 -- SELECT database 0 -- connectMaxConnections = 50 -- Up to 50 connections -- connectMaxIdleTime = 30 -- Keep open for 30 seconds -- @ -- defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnInfo { connectHost = "localhost" , connectPort = PortNumber 6379 , connectAuth = Nothing , connectDatabase = 0 , connectMaxConnections = 50 , connectMaxIdleTime = 30 } -- |Opens a 'Connection' to a Redis server designated by the given -- 'ConnectInfo'. connect :: ConnectInfo -> IO Connection connect ConnInfo{..} = Conn <$> createPool create destroy 1 connectMaxIdleTime connectMaxConnections where create = do conn <- PP.connect connectHost connectPort reply runRedisInternal conn $ do -- AUTH case connectAuth of Nothing -> return () Just pass -> void $ auth pass -- SELECT when (connectDatabase /= 0) (void $ select connectDatabase) return conn destroy = PP.disconnect -- The AUTH command. It has to be here because it is used in 'connect'. auth :: B.ByteString -- ^ password -> Redis (Either Reply Status) auth password = sendRequest ["AUTH", password] -- The SELECT command. Used in 'connect'. select :: RedisCtx m f => Integer -- ^ index -> m (f Status) select ix = sendRequest ["SELECT", encode ix]hedis-0.6.9/src/Database/Redis/ManualCommands.hs0000644000000000000000000002604312552420631017611 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleContexts #-} module Database.Redis.ManualCommands where import Prelude hiding (min,max) import Data.ByteString (ByteString) import Database.Redis.Core import Database.Redis.Protocol import Database.Redis.Types objectRefcount :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) objectRefcount key = sendRequest ["OBJECT", "refcount", encode key] objectIdletime :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) objectIdletime key = sendRequest ["OBJECT", "idletime", encode key] objectEncoding :: (RedisCtx m f) => ByteString -- ^ key -> m (f ByteString) objectEncoding key = sendRequest ["OBJECT", "encoding", encode key] linsertBefore :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ pivot -> ByteString -- ^ value -> m (f Integer) linsertBefore key pivot value = sendRequest ["LINSERT", encode key, "BEFORE", encode pivot, encode value] linsertAfter :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ pivot -> ByteString -- ^ value -> m (f Integer) linsertAfter key pivot value = sendRequest ["LINSERT", encode key, "AFTER", encode pivot, encode value] getType :: (RedisCtx m f) => ByteString -- ^ key -> m (f RedisType) getType key = sendRequest ["TYPE", encode key] -- |A single entry from the slowlog. data Slowlog = Slowlog { slowlogId :: Integer -- ^ A unique progressive identifier for every slow log entry. , slowlogTimestamp :: Integer -- ^ The unix timestamp at which the logged command was processed. , slowlogMicros :: Integer -- ^ The amount of time needed for its execution, in microseconds. , slowlogCmd :: [ByteString] -- ^ The command and it's arguments. } deriving (Show, Eq) instance RedisResult Slowlog where decode (MultiBulk (Just [logId,timestamp,micros,cmd])) = do slowlogId <- decode logId slowlogTimestamp <- decode timestamp slowlogMicros <- decode micros slowlogCmd <- decode cmd return Slowlog{..} decode r = Left r slowlogGet :: (RedisCtx m f) => Integer -- ^ cnt -> m (f [Slowlog]) slowlogGet n = sendRequest ["SLOWLOG", "GET", encode n] slowlogLen :: (RedisCtx m f) => m (f Integer) slowlogLen = sendRequest ["SLOWLOG", "LEN"] slowlogReset :: (RedisCtx m f) => m (f Status) slowlogReset = sendRequest ["SLOWLOG", "RESET"] zrange :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f [ByteString]) zrange key start stop = sendRequest ["ZRANGE", encode key, encode start, encode stop] zrangeWithscores :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f [(ByteString, Double)]) zrangeWithscores key start stop = sendRequest ["ZRANGE", encode key, encode start, encode stop, "WITHSCORES"] zrevrange :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f [ByteString]) zrevrange key start stop = sendRequest ["ZREVRANGE", encode key, encode start, encode stop] zrevrangeWithscores :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f [(ByteString, Double)]) zrevrangeWithscores key start stop = sendRequest ["ZREVRANGE", encode key, encode start, encode stop ,"WITHSCORES"] zrangebyscore :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ min -> Double -- ^ max -> m (f [ByteString]) zrangebyscore key min max = sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max] zrangebyscoreWithscores :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ min -> Double -- ^ max -> m (f [(ByteString, Double)]) zrangebyscoreWithscores key min max = sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max ,"WITHSCORES"] zrangebyscoreLimit :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ min -> Double -- ^ max -> Integer -- ^ offset -> Integer -- ^ count -> m (f [ByteString]) zrangebyscoreLimit key min max offset count = sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max ,"LIMIT", encode offset, encode count] zrangebyscoreWithscoresLimit :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ min -> Double -- ^ max -> Integer -- ^ offset -> Integer -- ^ count -> m (f [(ByteString, Double)]) zrangebyscoreWithscoresLimit key min max offset count = sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max ,"WITHSCORES","LIMIT", encode offset, encode count] zrevrangebyscore :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ max -> Double -- ^ min -> m (f [ByteString]) zrevrangebyscore key min max = sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max] zrevrangebyscoreWithscores :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ max -> Double -- ^ min -> m (f [(ByteString, Double)]) zrevrangebyscoreWithscores key min max = sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max ,"WITHSCORES"] zrevrangebyscoreLimit :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ max -> Double -- ^ min -> Integer -- ^ offset -> Integer -- ^ count -> m (f [ByteString]) zrevrangebyscoreLimit key min max offset count = sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max ,"LIMIT", encode offset, encode count] zrevrangebyscoreWithscoresLimit :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ max -> Double -- ^ min -> Integer -- ^ offset -> Integer -- ^ count -> m (f [(ByteString, Double)]) zrevrangebyscoreWithscoresLimit key min max offset count = sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max ,"WITHSCORES","LIMIT", encode offset, encode count] -- |Options for the 'sort' command. data SortOpts = SortOpts { sortBy :: Maybe ByteString , sortLimit :: (Integer,Integer) , sortGet :: [ByteString] , sortOrder :: SortOrder , sortAlpha :: Bool } deriving (Show, Eq) -- |Redis default 'SortOpts'. Equivalent to omitting all optional parameters. -- -- @ -- SortOpts -- { sortBy = Nothing -- omit the BY option -- , sortLimit = (0,-1) -- return entire collection -- , sortGet = [] -- omit the GET option -- , sortOrder = Asc -- sort in ascending order -- , sortAlpha = False -- sort numerically, not lexicographically -- } -- @ -- defaultSortOpts :: SortOpts defaultSortOpts = SortOpts { sortBy = Nothing , sortLimit = (0,-1) , sortGet = [] , sortOrder = Asc , sortAlpha = False } data SortOrder = Asc | Desc deriving (Show, Eq) sortStore :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ destination -> SortOpts -> m (f Integer) sortStore key dest = sortInternal key (Just dest) sort :: (RedisCtx m f) => ByteString -- ^ key -> SortOpts -> m (f [ByteString]) sort key = sortInternal key Nothing sortInternal :: (RedisResult a, RedisCtx m f) => ByteString -- ^ key -> Maybe ByteString -- ^ destination -> SortOpts -> m (f a) sortInternal key destination SortOpts{..} = sendRequest $ concat [["SORT", encode key], by, limit, get, order, alpha, store] where by = maybe [] (\pattern -> ["BY", pattern]) sortBy limit = let (off,cnt) = sortLimit in ["LIMIT", encode off, encode cnt] get = concatMap (\pattern -> ["GET", pattern]) sortGet order = case sortOrder of Desc -> ["DESC"]; Asc -> ["ASC"] alpha = ["ALPHA" | sortAlpha] store = maybe [] (\dest -> ["STORE", dest]) destination data Aggregate = Sum | Min | Max deriving (Show,Eq) zunionstore :: (RedisCtx m f) => ByteString -- ^ destination -> [ByteString] -- ^ keys -> Aggregate -> m (f Integer) zunionstore dest keys = zstoreInternal "ZUNIONSTORE" dest keys [] zunionstoreWeights :: (RedisCtx m f) => ByteString -- ^ destination -> [(ByteString,Double)] -- ^ weighted keys -> Aggregate -> m (f Integer) zunionstoreWeights dest kws = let (keys,weights) = unzip kws in zstoreInternal "ZUNIONSTORE" dest keys weights zinterstore :: (RedisCtx m f) => ByteString -- ^ destination -> [ByteString] -- ^ keys -> Aggregate -> m (f Integer) zinterstore dest keys = zstoreInternal "ZINTERSTORE" dest keys [] zinterstoreWeights :: (RedisCtx m f) => ByteString -- ^ destination -> [(ByteString,Double)] -- ^ weighted keys -> Aggregate -> m (f Integer) zinterstoreWeights dest kws = let (keys,weights) = unzip kws in zstoreInternal "ZINTERSTORE" dest keys weights zstoreInternal :: (RedisCtx m f) => ByteString -- ^ cmd -> ByteString -- ^ destination -> [ByteString] -- ^ keys -> [Double] -- ^ weights -> Aggregate -> m (f Integer) zstoreInternal cmd dest keys weights aggregate = sendRequest $ concat [ [cmd, dest, encode . toInteger $ length keys], keys , if null weights then [] else "WEIGHTS" : map encode weights , ["AGGREGATE", aggregate'] ] where aggregate' = case aggregate of Sum -> "SUM" Min -> "MIN" Max -> "MAX" eval :: (RedisCtx m f, RedisResult a) => ByteString -- ^ script -> [ByteString] -- ^ keys -> [ByteString] -- ^ args -> m (f a) eval script keys args = sendRequest $ ["EVAL", script, encode numkeys] ++ keys ++ args where numkeys = toInteger (length keys) evalsha :: (RedisCtx m f, RedisResult a) => ByteString -- ^ script -> [ByteString] -- ^ keys -> [ByteString] -- ^ args -> m (f a) evalsha script keys args = 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 : kshedis-0.6.9/src/Database/Redis/Protocol.hs0000644000000000000000000000365512552420631016517 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Database.Redis.Protocol (Reply(..), reply, renderRequest) where import Prelude hiding (error, take) import Control.Applicative import Data.Attoparsec.ByteString (takeTill) import Data.Attoparsec.ByteString.Char8 hiding (takeTill) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -- |Low-level representation of replies from the Redis server. data Reply = SingleLine ByteString | Error ByteString | Integer Integer | Bulk (Maybe ByteString) | MultiBulk (Maybe [Reply]) deriving (Eq, Show) ------------------------------------------------------------------------------ -- Request -- renderRequest :: [ByteString] -> ByteString renderRequest req = B.concat (argCnt:args) where argCnt = B.concat ["*", showBS (length req), crlf] args = map renderArg req renderArg :: ByteString -> ByteString renderArg arg = B.concat ["$", argLen arg, crlf, arg, crlf] where argLen = showBS . B.length showBS :: (Show a) => a -> ByteString showBS = B.pack . show crlf :: ByteString crlf = "\r\n" ------------------------------------------------------------------------------ -- Reply parsers -- reply :: Parser Reply reply = choice [singleLine, integer, bulk, multiBulk, error] singleLine :: Parser Reply singleLine = SingleLine <$> (char '+' *> takeTill isEndOfLine <* endOfLine) error :: Parser Reply error = Error <$> (char '-' *> takeTill isEndOfLine <* endOfLine) integer :: Parser Reply integer = Integer <$> (char ':' *> signed decimal <* endOfLine) bulk :: Parser Reply bulk = Bulk <$> do len <- char '$' *> signed decimal <* endOfLine if len < 0 then return Nothing else Just <$> take len <* endOfLine multiBulk :: Parser Reply multiBulk = MultiBulk <$> do len <- char '*' *> signed decimal <* endOfLine if len < 0 then return Nothing else Just <$> count len reply hedis-0.6.9/src/Database/Redis/ProtocolPipelining.hs0000644000000000000000000001110512552420631020523 0ustar0000000000000000{-# 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 import Control.Concurrent (ThreadId, forkIO, killThread) import Control.Concurrent.BoundedChan import Control.Exception import Control.Monad import Data.Attoparsec.ByteString 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. -- -- The list of thunks must be deconstructed lazily, i.e. strictly matching (:) -- would block until a reply can be read. Using 'head' and 'tail' achieves ~2% -- more req/s in pipelined code than a lazy pattern match @~(r:rs)@. 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 hedis-0.6.9/src/Database/Redis/PubSub.hs0000644000000000000000000001674512552420631016122 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, RecordWildCards, EmptyDataDecls, FlexibleInstances, FlexibleContexts #-} module Database.Redis.PubSub ( publish, pubSub, Message(..), PubSub(), subscribe, unsubscribe, psubscribe, punsubscribe ) where import Control.Applicative import Control.Monad import Control.Monad.State import Data.ByteString.Char8 (ByteString) import Data.Monoid import qualified Database.Redis.Core as Core import Database.Redis.Protocol (Reply(..)) import Database.Redis.Types -- |While in PubSub mode, we keep track of the number of current subscriptions -- (as reported by Redis replies) and the number of messages we expect to -- receive after a SUBSCRIBE or PSUBSCRIBE command. We can safely leave the -- PubSub mode when both these numbers are zero. data PubSubState = PubSubState { subCnt, pending :: Int } modifyPending :: (MonadState PubSubState m) => (Int -> Int) -> m () modifyPending f = modify $ \s -> s{ pending = f (pending s) } putSubCnt :: (MonadState PubSubState m) => Int -> m () putSubCnt n = modify $ \s -> s{ subCnt = n } data Subscribe data Unsubscribe data Channel data Pattern -- |Encapsulates subscription changes. Use 'subscribe', 'unsubscribe', -- 'psubscribe', 'punsubscribe' or 'mempty' to construct a value. Combine -- values by using the 'Monoid' interface, i.e. 'mappend' and 'mconcat'. data PubSub = PubSub { subs :: Cmd Subscribe Channel , unsubs :: Cmd Unsubscribe Channel , psubs :: Cmd Subscribe Pattern , punsubs :: Cmd Unsubscribe Pattern } deriving (Eq) instance Monoid PubSub where mempty = PubSub mempty mempty mempty mempty mappend p1 p2 = PubSub { subs = subs p1 `mappend` subs p2 , unsubs = unsubs p1 `mappend` unsubs p2 , psubs = psubs p1 `mappend` psubs p2 , punsubs = punsubs p1 `mappend` punsubs p2 } data Cmd a b = DoNothing | Cmd { changes :: [ByteString] } deriving (Eq) instance Monoid (Cmd Subscribe a) where mempty = DoNothing mappend DoNothing x = x mappend x DoNothing = x mappend (Cmd xs) (Cmd ys) = Cmd (xs ++ ys) instance Monoid (Cmd Unsubscribe a) where mempty = DoNothing mappend DoNothing x = x mappend x DoNothing = x -- empty subscription list => unsubscribe all channels and patterns mappend (Cmd []) _ = Cmd [] mappend _ (Cmd []) = Cmd [] mappend (Cmd xs) (Cmd ys) = Cmd (xs ++ ys) class Command a where redisCmd :: a -> ByteString updatePending :: a -> Int -> Int sendCmd :: (Command (Cmd a b)) => Cmd a b -> StateT PubSubState Core.Redis () sendCmd DoNothing = return () sendCmd cmd = do lift $ Core.send (redisCmd cmd : changes cmd) modifyPending (updatePending cmd) plusChangeCnt :: Cmd a b -> Int -> Int plusChangeCnt DoNothing = id plusChangeCnt (Cmd cs) = (+ length cs) instance Command (Cmd Subscribe Channel) where redisCmd = const "SUBSCRIBE" updatePending = plusChangeCnt instance Command (Cmd Subscribe Pattern) where redisCmd = const "PSUBSCRIBE" updatePending = plusChangeCnt instance Command (Cmd Unsubscribe Channel) where redisCmd = const "UNSUBSCRIBE" updatePending = const id instance Command (Cmd Unsubscribe Pattern) where redisCmd = const "PUNSUBSCRIBE" updatePending = const id data Message = Message { msgChannel, msgMessage :: ByteString} | PMessage { msgPattern, msgChannel, msgMessage :: ByteString} deriving (Show) data PubSubReply = Subscribed | Unsubscribed Int | Msg Message ------------------------------------------------------------------------------ -- Public Interface -- -- |Post a message to a channel (). publish :: (Core.RedisCtx m f) => ByteString -- ^ channel -> ByteString -- ^ message -> m (f Integer) publish channel message = Core.sendRequest ["PUBLISH", channel, message] -- |Listen for messages published to the given channels -- (). subscribe :: [ByteString] -- ^ channel -> PubSub subscribe [] = mempty subscribe cs = mempty{ subs = Cmd cs } -- |Stop listening for messages posted to the given channels -- (). unsubscribe :: [ByteString] -- ^ channel -> PubSub unsubscribe cs = mempty{ unsubs = Cmd cs } -- |Listen for messages published to channels matching the given patterns -- (). psubscribe :: [ByteString] -- ^ pattern -> PubSub psubscribe [] = mempty psubscribe ps = mempty{ psubs = Cmd ps } -- |Stop listening for messages posted to channels matching the given patterns -- (). punsubscribe :: [ByteString] -- ^ pattern -> PubSub punsubscribe ps = mempty{ punsubs = Cmd ps } -- |Listens to published messages on subscribed channels and channels matching -- the subscribed patterns. For documentation on the semantics of Redis -- Pub\/Sub see . -- -- The given callback function is called for each received message. -- Subscription changes are triggered by the returned 'PubSub'. To keep -- subscriptions unchanged, the callback can return 'mempty'. -- -- Example: Subscribe to the \"news\" channel indefinitely. -- -- @ -- pubSub (subscribe [\"news\"]) $ \\msg -> do -- putStrLn $ \"Message from \" ++ show (msgChannel msg) -- return mempty -- @ -- -- Example: Receive a single message from the \"chat\" channel. -- -- @ -- pubSub (subscribe [\"chat\"]) $ \\msg -> do -- putStrLn $ \"Message from \" ++ show (msgChannel msg) -- return $ unsubscribe [\"chat\"] -- @ -- pubSub :: PubSub -- ^ Initial subscriptions. -> (Message -> IO PubSub) -- ^ Callback function. -> Core.Redis () pubSub initial callback | initial == mempty = return () | otherwise = evalStateT (send initial) (PubSubState 0 0) where send :: PubSub -> StateT PubSubState Core.Redis () send PubSub{..} = do sendCmd subs sendCmd unsubs sendCmd psubs sendCmd punsubs recv recv :: StateT PubSubState Core.Redis () recv = do reply <- lift Core.recv case decodeMsg reply of Msg msg -> liftIO (callback msg) >>= send Subscribed -> modifyPending (subtract 1) >> recv Unsubscribed n -> do putSubCnt n PubSubState{..} <- get unless (subCnt == 0 && pending == 0) recv ------------------------------------------------------------------------------ -- Helpers -- decodeMsg :: Reply -> PubSubReply decodeMsg r@(MultiBulk (Just (r0:r1:r2:rs))) = either (errMsg r) id $ do kind <- decode r0 case kind :: ByteString of "message" -> Msg <$> decodeMessage "pmessage" -> Msg <$> decodePMessage "subscribe" -> return Subscribed "psubscribe" -> return Subscribed "unsubscribe" -> Unsubscribed <$> decodeCnt "punsubscribe" -> Unsubscribed <$> decodeCnt _ -> errMsg r where decodeMessage = Message <$> decode r1 <*> decode r2 decodePMessage = PMessage <$> decode r1 <*> decode r2 <*> decode (head rs) decodeCnt = fromInteger <$> decode r2 decodeMsg r = errMsg r errMsg :: Reply -> a errMsg r = error $ "Hedis: expected pub/sub-message but got: " ++ show r hedis-0.6.9/src/Database/Redis/Transactions.hs0000644000000000000000000001042412552420631017356 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} module Database.Redis.Transactions ( watch, unwatch, multiExec, Queued(), TxResult(..), RedisTx(), ) where import Control.Applicative import Control.Monad.State.Strict import Data.ByteString (ByteString) import Data.Vector (Vector, fromList, (!)) import Database.Redis.Core import Database.Redis.Protocol import Database.Redis.Types -- |Command-context inside of MULTI\/EXEC transactions. Use 'multiExec' to run -- actions of this type. -- -- 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 Int Redis a) deriving (Monad, MonadIO, Functor, Applicative) runRedisTx :: RedisTx a -> Redis a runRedisTx (RedisTx r) = evalStateT r 0 instance MonadRedis RedisTx where liftRedis = RedisTx . lift instance RedisCtx RedisTx Queued where returnDecode _queued = RedisTx $ do -- 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 -- after returning from a 'multiExec' transaction. -- -- 'Queued' values are composable by utilizing the 'Functor', 'Applicative' or -- 'Monad' interfaces. data Queued a = Queued (Vector Reply -> Either Reply a) instance Functor Queued where fmap f (Queued g) = Queued (fmap f . g) instance Applicative Queued where pure x = Queued (const $ Right x) Queued f <*> Queued x = Queued $ \rs -> do f' <- f rs x' <- x rs return (f' x') instance Monad Queued where return = pure Queued x >>= f = Queued $ \rs -> do x' <- x rs let Queued f' = f x' f' rs -- | Result of a 'multiExec' transaction. data TxResult a = TxSuccess a -- ^ Transaction completed successfully. The wrapped value corresponds to -- the 'Queued' value returned from the 'multiExec' argument action. | TxAborted -- ^ Transaction aborted due to an earlier 'watch' command. | TxError String -- ^ At least one of the commands returned an 'Error' reply. deriving (Show, Eq) -- |Watch the given keys to determine execution of the MULTI\/EXEC block -- (). watch :: [ByteString] -- ^ key -> Redis (Either Reply Status) watch key = sendRequest ("WATCH" : key) -- |Forget about all watched keys (). unwatch :: Redis (Either Reply Status) unwatch = sendRequest ["UNWATCH"] -- |Run commands inside a transaction. For documentation on the semantics of -- Redis transaction see . -- -- Inside the transaction block, command functions return their result wrapped -- in a 'Queued'. The 'Queued' result is a proxy object for the actual -- command\'s result, which will only be available after @EXEC@ing the -- transaction. -- -- Example usage (note how 'Queued' \'s 'Applicative' instance is used to -- combine the two individual results): -- -- @ -- runRedis conn $ do -- set \"hello\" \"hello\" -- set \"world\" \"world\" -- helloworld <- 'multiExec' $ do -- hello <- get \"hello\" -- world <- get \"world\" -- return $ (,) \<$\> hello \<*\> world -- liftIO (print helloworld) -- @ 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 case r of MultiBulk rs -> return $ maybe TxAborted (either (TxError . show) TxSuccess . f . fromList) rs _ -> error $ "hedis: EXEC returned " ++ show r multi :: Redis (Either Reply Status) multi = sendRequest ["MULTI"] exec :: Redis Reply exec = either id id <$> sendRequest ["EXEC"] hedis-0.6.9/src/Database/Redis/Types.hs0000644000000000000000000000643112552420631016015 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, OverlappingInstances, TypeSynonymInstances, OverloadedStrings #-} module Database.Redis.Types where import Control.Applicative import Data.ByteString.Char8 (ByteString, pack) import qualified Data.ByteString.Lex.Fractional as F (readSigned, readDecimal) import qualified Data.ByteString.Lex.Integral as I (readSigned, readDecimal) import Database.Redis.Protocol ------------------------------------------------------------------------------ -- Classes of types Redis understands -- class RedisArg a where encode :: a -> ByteString class RedisResult a where decode :: Reply -> Either Reply a ------------------------------------------------------------------------------ -- RedisArg instances -- instance RedisArg ByteString where encode = id instance RedisArg Integer where encode = pack . show instance RedisArg Double where encode = pack . show ------------------------------------------------------------------------------ -- RedisResult instances -- data Status = Ok | Pong | Status ByteString deriving (Show, Eq) data RedisType = None | String | Hash | List | Set | ZSet deriving (Show, Eq) instance RedisResult Reply where decode = Right instance RedisResult ByteString where decode (SingleLine s) = Right s decode (Bulk (Just s)) = Right s decode r = Left r instance RedisResult Integer where decode (Integer n) = Right n decode r = maybe (Left r) (Right . fst) . I.readSigned I.readDecimal =<< decode r instance RedisResult Double where decode r = maybe (Left r) (Right . fst) . F.readSigned F.readDecimal =<< decode r instance RedisResult Status where decode (SingleLine s) = Right $ case s of "OK" -> Ok "PONG" -> Pong _ -> Status s decode r = Left r instance RedisResult RedisType where decode (SingleLine s) = Right $ case s of "none" -> None "string" -> String "hash" -> Hash "list" -> List "set" -> Set "zset" -> ZSet _ -> error $ "Hedis: unhandled redis type: " ++ show s decode r = Left r instance RedisResult Bool where decode (Integer 1) = Right True decode (Integer 0) = Right False decode (Bulk Nothing) = Right False -- Lua boolean false = nil bulk reply decode r = Left r instance (RedisResult a) => RedisResult (Maybe a) where decode (Bulk Nothing) = Right Nothing decode (MultiBulk Nothing) = Right Nothing decode r = Just <$> decode r instance (RedisResult a) => RedisResult [a] where decode (MultiBulk (Just rs)) = mapM decode rs decode r = Left r instance (RedisResult a, RedisResult b) => RedisResult (a,b) where decode (MultiBulk (Just [x, y])) = (,) <$> decode x <*> decode y decode r = Left r instance (RedisResult k, RedisResult v) => RedisResult [(k,v)] where decode r = case r of (MultiBulk (Just rs)) -> pairs rs _ -> Left r where pairs [] = Right [] pairs (_:[]) = Left r pairs (r1:r2:rs) = do k <- decode r1 v <- decode r2 kvs <- pairs rs return $ (k,v) : kvs hedis-0.6.9/test/0000755000000000000000000000000012552420631011767 5ustar0000000000000000hedis-0.6.9/test/Test.hs0000644000000000000000000004124312552420631013246 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, RecordWildCards #-} module Main (main) where import Prelude hiding (catch) import Control.Applicative import Control.Concurrent import Control.Monad import Control.Monad.Trans import Data.Monoid (mappend) import Data.Time import Data.Time.Clock.POSIX 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 ------------------------------------------------------------------------------ -- Main and helpers -- main :: IO () main = do conn <- connect defaultConnectInfo Test.defaultMain (tests conn) type Test = Connection -> Test.Test testCase :: String -> Redis () -> Test 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 -> HUnit.assertFailure $ "Redis error: " ++ show reply Right actual -> expected HUnit.@=? actual assert :: Bool -> Redis () assert = liftIO . HUnit.assert ------------------------------------------------------------------------------ -- Tests -- 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 , testEvalReplies ] testConstantSpacePipelining :: Test testConstantSpacePipelining = testCase "constant-space pipelining" $ do -- This testcase should not exceed the maximum heap size, as set in -- the run-test.sh script. replicateM_ 100000 ping -- If the program didn't crash, pipelining takes constant memory. assert True testForceErrorReply :: Test testForceErrorReply = testCase "force error reply" $ do set "key" "value" -- key is not a hash -> wrong kind of value reply <- hkeys "key" assert $ case reply of Left (Error _) -> True _ -> False testPipelining :: Test testPipelining = testCase "pipelining" $ do let n = 10 tPipe <- deltaT $ do pongs <- replicateM n ping assert $ pongs == replicate n (Right Pong) tNoPipe <- deltaT $ replicateM_ n (ping >>=? Pong) -- pipelining should at least be twice as fast. assert $ tNoPipe / tPipe > 2 where deltaT redis = do start <- liftIO $ getCurrentTime 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 = [ testKeys, testExpireAt, testSort, testGetType, testObject ] 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 t <- ceiling . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime let expiry = t+1 expireat "key" expiry >>=? True pexpireat "key" (expiry*1000) >>=? True testSort :: Test testSort = testCase "sort" $ do lpush "ids" ["1","2","3"] >>=? 3 sort "ids" defaultSortOpts >>=? ["1","2","3"] sortStore "ids" "anotherKey" defaultSortOpts >>=? 3 mset [("weight_1","1") ,("weight_2","2") ,("weight_3","3") ,("object_1","foo") ,("object_2","bar") ,("object_3","baz") ] let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True , sortLimit = (1,2) , sortBy = Just "weight_*" , sortGet = ["#", "object_*"] } sort "ids" opts >>=? ["2", "bar", "1", "foo"] testGetType :: Test testGetType = testCase "getType" $ do getType "key" >>=? None forM_ ts $ \(setKey, typ) -> do setKey getType "key" >>=? typ del ["key"] >>=? 1 where ts = [ (set "key" "value" >>=? Ok, String) , (hset "key" "field" "value" >>=? True, Hash) , (lpush "key" ["value"] >>=? 1, List) , (sadd "key" ["member"] >>=? 1, Set) , (zadd "key" [(42,"member"),(12.3,"value")] >>=? 2, ZSet) ] testObject :: Test testObject = testCase "object" $ do set "key" "value" >>=? Ok objectRefcount "key" >>=? 1 Right _ <- objectEncoding "key" objectIdletime "key" >>=? 0 ------------------------------------------------------------------------------ -- Strings -- testsStrings :: [Test] testsStrings = [testStrings, testBitops] 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 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 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 -- testHashes :: Test testHashes = testCase "hashes" $ do hset "key" "field" "value" >>=? True hsetnx "key" "field" "value" >>=? False 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"] >>=? 1 hmset "key" [("field","40")] >>=? Ok hincrby "key" "field" 2 >>=? 42 hincrbyfloat "key" "field" 2 >>=? 44 ------------------------------------------------------------------------------ -- Lists -- testsLists :: [Test] testsLists = [testLists, testBpop] 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 testBpop :: Test testBpop = testCase "blocking push/pop" $ do lpush "key" ["v3","v2","v1"] >>=? 3 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 = [testZSets, testZStore] 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 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",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"] zrangebyscoreWithscoresLimit "key" 0.5 2.5 0 1 >>=? [("v1",1)] zrevrangebyscore "key" 1.5 0.5 >>=? ["v1"] 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 zadd "k1" [(1, "v1"), (2, "v2")] zadd "k2" [(2, "v2"), (3, "v3")] zinterstore "newkey" ["k1","k2"] Sum >>=? 1 zinterstoreWeights "newkey" [("k1",1),("k2",2)] Max >>=? 1 zunionstore "newkey" ["k1","k2"] Sum >>=? 3 zunionstoreWeights "newkey" [("k1",1),("k2",2)] Min >>=? 3 ------------------------------------------------------------------------------ -- Pub/Sub -- testPubSub :: Test testPubSub conn = testCase "pubSub" go conn where go = do -- producer liftIO $ forkIO $ do runRedis conn $ do let t = 10^(5 :: Int) liftIO $ threadDelay t publish "chan1" "hello" >>=? 1 liftIO $ threadDelay t publish "chan2" "world" >>=? 1 return () -- consumer pubSub (subscribe ["chan1"]) $ \msg -> do -- ready for a message case msg of Message{..} -> return (unsubscribe [msgChannel] `mappend` psubscribe ["chan*"]) PMessage{..} -> return (punsubscribe [msgPattern]) pubSub (subscribe [] `mappend` psubscribe []) $ \_ -> do liftIO $ HUnit.assertFailure "no subs: should return immediately" undefined ------------------------------------------------------------------------------ -- Transaction -- testTransaction :: Test testTransaction = testCase "transaction" $ do watch ["k1", "k2"] >>=? Ok unwatch >>=? Ok set "foo" "foo" set "bar" "bar" foobar <- multiExec $ do foo <- get "foo" bar <- get "bar" return $ (,) <$> foo <*> bar assert $ foobar == TxSuccess (Just "foo", Just "bar") ------------------------------------------------------------------------------ -- Scripting -- testScripting :: Test testScripting conn = testCase "scripting" go conn where go = do let script = "return {false, 42}" scriptRes = (False, 42 :: Integer) Right scriptHash <- scriptLoad script eval script [] [] >>=? scriptRes evalsha scriptHash [] [] >>=? scriptRes scriptExists [scriptHash, "notAScript"] >>=? [True, False] scriptFlush >>=? Ok -- start long running script from another client 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 ------------------------------------------------------------------------------ -- Connection -- testsConnection :: [Test] testsConnection = [ testEcho, testPing, testSelect ] testEcho :: Test testEcho = testCase "echo" $ echo ("value" ) >>=? "value" testPing :: Test testPing = testCase "ping" $ ping >>=? Pong testQuit :: Test testQuit = testCase "quit" $ quit >>=? Ok testSelect :: Test testSelect = testCase "select" $ do select 13 >>=? Ok select 0 >>=? Ok ------------------------------------------------------------------------------ -- Server -- testsServer :: [Test] testsServer = [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 testFlushall :: Test testFlushall = testCase "flushall/flushdb" $ do flushall >>=? Ok flushdb >>=? Ok testInfo :: Test testInfo = testCase "info/lastsave/dbsize" $ do Right _ <- info Right _ <- lastsave dbsize >>=? 0 configResetstat >>=? Ok testSlowlog :: Test testSlowlog = testCase "slowlog" $ do slowlogReset >>=? Ok slowlogGet 5 >>=? [] slowlogLen >>=? 0 testDebugObject :: Test testDebugObject = testCase "debugObject/debugSegfault" $ do set "key" "value" >>=? Ok Right _ <- debugObject "key" return ()