packages feed

hedis (empty) → 0.1

raw patch · 12 files changed

+1687/−0 lines, 12 filesdep +attoparsecdep +basedep +bytestringsetup-changed

Dependencies added: attoparsec, base, bytestring, bytestring-lexing, hedis, mtl, network, time

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/Benchmark.hs view
@@ -0,0 +1,67 @@+{-# 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 = 10000+nClients  = 50+++main :: IO ()+main = do+    ----------------------------------------------------------------------+    -- Preparation+    --+    conn <- connect "localhost" (PortNumber 6379)+    runRedis conn $ do+        Right _ <- mset [ ("k1","v1"), ("k2","v2"), ("k3","v3")+                        , ("k4","v4"), ("k5","v5") ]+        return ()+    +    disconnect conn+    +    ----------------------------------------------------------------------+    -- Spawn clients+    --+    start <- newEmptyMVar+    done  <- newEmptyMVar+    replicateM_ nClients $ forkIO $ do+        c <- connect "localhost" (PortNumber 6379)+        runRedis c $ forever $ do+            action <- liftIO $ takeMVar start+            replicateM_ (nRequests `div` nClients) $ action+            liftIO $ putMVar done ()++    let timeAction name action = do+        startT <- getCurrentTime+        replicateM_ nClients $ putMVar start action+        replicateM_ nClients $ takeMVar done+        stopT <- getCurrentTime+        let deltaT    = realToFrac $ diffUTCTime stopT startT+            rqsPerSec = fromIntegral nRequests / deltaT :: Double+        putStrLn $ printf "%-10s %.2f Req/s" (name :: String) rqsPerSec++    ----------------------------------------------------------------------+    -- Benchmarks+    --+    timeAction "ping" $ do+        Right Pong <- ping+        return ()+        +    timeAction "get" $ do+        Right Nothing <- get "key"+        return ()+    +    timeAction "mget" $ do+        Right vs <- mget ["k1","k2","k3","k4","k5"]+        let expected = map Just ["v1","v2","v3","v4","v5"]+        True <- return $ vs == expected+        return ()+
+ hedis.cabal view
@@ -0,0 +1,80 @@+name:               hedis+version:            0.1+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.4 command set:] All Redis commands +        (<http://redis.io/commands>) are available as haskell functions. The +        exceptions to the rule are a handfull of internal and debugging+        commands: MONITOR, DEBUG OBJECT, DEBUG SEGFAULT, SYNC. If needed, these+        commands can easily be implemented by the library user with the+        'sendRequest' function.+    .+    [Pipelining \"Just Works\":] Commands are pipelined +        (<http://redis.io/topics/pipelining>) as much as possible without any+        work by the user.+    .+    [Enforced Pub\/Sub semantics:] When subscribed to the Redis Pub\/Sub server+        (<http://redis.io/topics/pubsub>), 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.+    .+    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++bug-reports: https://github.com/informatikr/hedis/issues++flag benchmark+    description: Build the benchmark executable.+    default: False++library+  hs-source-dirs:   src+  ghc-options:      -Wall+  ghc-prof-options: -auto-all+  exposed-modules:  Database.Redis+  build-depends:    attoparsec == 0.10.*,+                    base == 4.*,+                    bytestring == 0.9.*,+                    bytestring-lexing == 0.2.*,+                    mtl == 2.*,+                    network == 2.*++  other-modules:    Database.Redis.Internal,+                    Database.Redis.PubSub,+                    Database.Redis.Reply,+                    Database.Redis.Request,+                    Database.Redis.Types+                    Database.Redis.Commands,+                    Database.Redis.ManualCommands++executable hedis-benchmark+    main-is: benchmark/Benchmark.hs+    ghc-options: -Wall -rtsopts+    ghc-prof-options: -auto-all+    if ! flag(benchmark)+        buildable: False+    else+        build-depends:+            base >= 4,+            mtl == 2.0.*,+            hedis,+            time >= 1.2++source-repository head+  type:     git+  location: https://github.com/informatikr/hedis
+ src/Database/Redis.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings, CPP #-}++module Database.Redis (+    +    -- * The Redis Monad+    Redis(), runRedis,+    +    -- * Connection+    RedisConn, connect, disconnect,+    HostName,PortID(..),defaultPort,+    +    -- * Commands+	module Database.Redis.Commands,++    -- * Pub\/Sub+    module Database.Redis.PubSub,++    -- * Low-Level Requests and Replies+    sendRequest,+    -- |'sendRequest' can be used to implement one of the unimplemented +    --  commands, as shown below.+    --+    -- @+    -- -- |Redis DEBUG OBJECT command+    -- debugObject :: ByteString -> 'Redis' (Either 'Reply' ByteString)+    -- debugObject key = 'sendRequest' [\"DEBUG\", \"OBJECT\", 'encode' key]+    -- @+    --+    Reply(..),Status(..),RedisResult(..)+    +) where++import Database.Redis.Internal+import Database.Redis.PubSub+import Database.Redis.Reply+import Database.Redis.Types++import Database.Redis.Commands
+ src/Database/Redis/Commands.hs view
@@ -0,0 +1,779 @@+-- Generated by GenCmds.hs. DO NOT EDIT.++{-# LANGUAGE OverloadedStrings #-}++module Database.Redis.Commands (++-- ** Connection+auth, -- |Authenticate to the server (<http://redis.io/commands/auth>).+echo, -- |Echo the given string (<http://redis.io/commands/echo>).+ping, -- |Ping the server (<http://redis.io/commands/ping>).+quit, -- |Close the connection (<http://redis.io/commands/quit>).+select, -- |Change the selected database for the current connection (<http://redis.io/commands/select>).++-- ** Keys+del, -- |Delete a key (<http://redis.io/commands/del>).+exists, -- |Determine if a key exists (<http://redis.io/commands/exists>).+expire, -- |Set a key's time to live in seconds (<http://redis.io/commands/expire>).+expireat, -- |Set the expiration for a key as a UNIX timestamp (<http://redis.io/commands/expireat>).+keys, -- |Find all keys matching the given pattern (<http://redis.io/commands/keys>).+move, -- |Move a key to another database (<http://redis.io/commands/move>).+objectRefcount, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'.+objectEncoding, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'.+objectIdletime, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'.+persist, -- |Remove the expiration from a key (<http://redis.io/commands/persist>).+randomkey, -- |Return a random key from the keyspace (<http://redis.io/commands/randomkey>).+rename, -- |Rename a key (<http://redis.io/commands/rename>).+renamenx, -- |Rename a key, only if the new key does not exist (<http://redis.io/commands/renamenx>).+SortOpts(..),+defaultSortOpts,+SortOrder(..),+sort, -- |Sort the elements in a list, set or sorted set (<http://redis.io/commands/sort>). The Redis command @SORT@ is split up into 'sort', 'sortStore'.+sortStore, -- |Sort the elements in a list, set or sorted set (<http://redis.io/commands/sort>). The Redis command @SORT@ is split up into 'sort', 'sortStore'.+ttl, -- |Get the time to live for a key (<http://redis.io/commands/ttl>).+getType, -- |Determine the type stored at key (<http://redis.io/commands/type>).++-- ** Hashes+hdel, -- |Delete one or more hash fields (<http://redis.io/commands/hdel>).+hexists, -- |Determine if a hash field exists (<http://redis.io/commands/hexists>).+hget, -- |Get the value of a hash field (<http://redis.io/commands/hget>).+hgetall, -- |Get all the fields and values in a hash (<http://redis.io/commands/hgetall>).+hincrby, -- |Increment the integer value of a hash field by the given number (<http://redis.io/commands/hincrby>).+hkeys, -- |Get all the fields in a hash (<http://redis.io/commands/hkeys>).+hlen, -- |Get the number of fields in a hash (<http://redis.io/commands/hlen>).+hmget, -- |Get the values of all the given hash fields (<http://redis.io/commands/hmget>).+hmset, -- |Set multiple hash fields to multiple values (<http://redis.io/commands/hmset>).+hset, -- |Set the string value of a hash field (<http://redis.io/commands/hset>).+hsetnx, -- |Set the value of a hash field, only if the field does not exist (<http://redis.io/commands/hsetnx>).+hvals, -- |Get all the values in a hash (<http://redis.io/commands/hvals>).++-- ** Lists+blpop, -- |Remove and get the first element in a list, or block until one is available (<http://redis.io/commands/blpop>).+brpop, -- |Remove and get the last element in a list, or block until one is available (<http://redis.io/commands/brpop>).+brpoplpush, -- |Pop a value from a list, push it to another list and return it; or block until one is available (<http://redis.io/commands/brpoplpush>).+lindex, -- |Get an element from a list by its index (<http://redis.io/commands/lindex>).+linsertBefore, -- |Insert an element before or after another element in a list (<http://redis.io/commands/linsert>). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'.+linsertAfter, -- |Insert an element before or after another element in a list (<http://redis.io/commands/linsert>). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'.+llen, -- |Get the length of a list (<http://redis.io/commands/llen>).+lpop, -- |Remove and get the first element in a list (<http://redis.io/commands/lpop>).+lpush, -- |Prepend one or multiple values to a list (<http://redis.io/commands/lpush>).+lpushx, -- |Prepend a value to a list, only if the list exists (<http://redis.io/commands/lpushx>).+lrange, -- |Get a range of elements from a list (<http://redis.io/commands/lrange>).+lrem, -- |Remove elements from a list (<http://redis.io/commands/lrem>).+lset, -- |Set the value of an element in a list by its index (<http://redis.io/commands/lset>).+ltrim, -- |Trim a list to the specified range (<http://redis.io/commands/ltrim>).+rpop, -- |Remove and get the last element in a list (<http://redis.io/commands/rpop>).+rpoplpush, -- |Remove the last element in a list, append it to another list and return it (<http://redis.io/commands/rpoplpush>).+rpush, -- |Append one or multiple values to a list (<http://redis.io/commands/rpush>).+rpushx, -- |Append a value to a list, only if the list exists (<http://redis.io/commands/rpushx>).++-- ** Server+bgrewriteaof, -- |Asynchronously rewrite the append-only file (<http://redis.io/commands/bgrewriteaof>).+bgsave, -- |Asynchronously save the dataset to disk (<http://redis.io/commands/bgsave>).+configGet, -- |Get the value of a configuration parameter (<http://redis.io/commands/config-get>).+configResetstat, -- |Reset the stats returned by INFO (<http://redis.io/commands/config-resetstat>).+configSet, -- |Set a configuration parameter to the given value (<http://redis.io/commands/config-set>).+dbsize, -- |Return the number of keys in the selected database (<http://redis.io/commands/dbsize>).+flushall, -- |Remove all keys from all databases (<http://redis.io/commands/flushall>).+flushdb, -- |Remove all keys from the current database (<http://redis.io/commands/flushdb>).+info, -- |Get information and statistics about the server (<http://redis.io/commands/info>).+lastsave, -- |Get the UNIX time stamp of the last successful save to disk (<http://redis.io/commands/lastsave>).+save, -- |Synchronously save the dataset to disk (<http://redis.io/commands/save>).+shutdown, -- |Synchronously save the dataset to disk and then shut down the server (<http://redis.io/commands/shutdown>).+slaveof, -- |Make the server a slave of another instance, or promote it as master (<http://redis.io/commands/slaveof>).+slowlogGet, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'.+slowlogLen, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'.+slowlogReset, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'.++-- ** Sets+sadd, -- |Add one or more members to a set (<http://redis.io/commands/sadd>).+scard, -- |Get the number of members in a set (<http://redis.io/commands/scard>).+sdiff, -- |Subtract multiple sets (<http://redis.io/commands/sdiff>).+sdiffstore, -- |Subtract multiple sets and store the resulting set in a key (<http://redis.io/commands/sdiffstore>).+sinter, -- |Intersect multiple sets (<http://redis.io/commands/sinter>).+sinterstore, -- |Intersect multiple sets and store the resulting set in a key (<http://redis.io/commands/sinterstore>).+sismember, -- |Determine if a given value is a member of a set (<http://redis.io/commands/sismember>).+smembers, -- |Get all the members in a set (<http://redis.io/commands/smembers>).+smove, -- |Move a member from one set to another (<http://redis.io/commands/smove>).+spop, -- |Remove and return a random member from a set (<http://redis.io/commands/spop>).+srandmember, -- |Get a random member from a set (<http://redis.io/commands/srandmember>).+srem, -- |Remove one or more members from a set (<http://redis.io/commands/srem>).+sunion, -- |Add multiple sets (<http://redis.io/commands/sunion>).+sunionstore, -- |Add multiple sets and store the resulting set in a key (<http://redis.io/commands/sunionstore>).++-- ** Sorted Sets+zadd, -- |Add one or more members to a sorted set, or update its score if it already exists (<http://redis.io/commands/zadd>).+zcard, -- |Get the number of members in a sorted set (<http://redis.io/commands/zcard>).+zcount, -- |Count the members in a sorted set with scores within the given values (<http://redis.io/commands/zcount>).+zincrby, -- |Increment the score of a member in a sorted set (<http://redis.io/commands/zincrby>).+Aggregate(..),+zinterstore, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zinterstore>). 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 (<http://redis.io/commands/zinterstore>). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'.+zrange, -- |Return a range of members in a sorted set, by index (<http://redis.io/commands/zrange>). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'.+zrangeWithscores, -- |Return a range of members in a sorted set, by index (<http://redis.io/commands/zrange>). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'.+zrangebyscore, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'.+zrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'.+zrangebyscoreLimit, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'.+zrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'.+zrank, -- |Determine the index of a member in a sorted set (<http://redis.io/commands/zrank>).+zrem, -- |Remove one or more members from a sorted set (<http://redis.io/commands/zrem>).+zremrangebyrank, -- |Remove all members in a sorted set within the given indexes (<http://redis.io/commands/zremrangebyrank>).+zremrangebyscore, -- |Remove all members in a sorted set within the given scores (<http://redis.io/commands/zremrangebyscore>).+zrevrange, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (<http://redis.io/commands/zrevrange>). 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 (<http://redis.io/commands/zrevrange>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrank>).+zscore, -- |Get the score associated with the given member in a sorted set (<http://redis.io/commands/zscore>).+zunionstore, -- |Add multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zunionstore>). 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 (<http://redis.io/commands/zunionstore>). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'.++-- ** Strings+append, -- |Append a value to a key (<http://redis.io/commands/append>).+decr, -- |Decrement the integer value of a key by one (<http://redis.io/commands/decr>).+decrby, -- |Decrement the integer value of a key by the given number (<http://redis.io/commands/decrby>).+get, -- |Get the value of a key (<http://redis.io/commands/get>).+getbit, -- |Returns the bit value at offset in the string value stored at key (<http://redis.io/commands/getbit>).+getrange, -- |Get a substring of the string stored at a key (<http://redis.io/commands/getrange>).+getset, -- |Set the string value of a key and return its old value (<http://redis.io/commands/getset>).+incr, -- |Increment the integer value of a key by one (<http://redis.io/commands/incr>).+incrby, -- |Increment the integer value of a key by the given number (<http://redis.io/commands/incrby>).+mget, -- |Get the values of all the given keys (<http://redis.io/commands/mget>).+mset, -- |Set multiple keys to multiple values (<http://redis.io/commands/mset>).+msetnx, -- |Set multiple keys to multiple values, only if none of the keys exist (<http://redis.io/commands/msetnx>).+set, -- |Set the string value of a key (<http://redis.io/commands/set>).+setbit, -- |Sets or clears the bit at offset in the string value stored at key (<http://redis.io/commands/setbit>).+setex, -- |Set the value and expiration of a key (<http://redis.io/commands/setex>).+setnx, -- |Set the value of a key, only if the key does not exist (<http://redis.io/commands/setnx>).+setrange, -- |Overwrite part of a string at key starting at the specified offset (<http://redis.io/commands/setrange>).+strlen, -- |Get the length of the value stored in a key (<http://redis.io/commands/strlen>).++-- ** Transactions+discard, -- |Discard all commands issued after MULTI (<http://redis.io/commands/discard>).+exec, -- |Execute all commands issued after MULTI (<http://redis.io/commands/exec>).+multi, -- |Mark the start of a transaction block (<http://redis.io/commands/multi>).+unwatch, -- |Forget about all watched keys (<http://redis.io/commands/unwatch>).+watch, -- |Watch the given keys to determine execution of the MULTI/EXEC block (<http://redis.io/commands/watch>).++-- * Unimplemented Commands+-- |These commands are not implemented, as of now. Library users can implement them with the 'sendRequest' function.+--+-- * EVAL (<http://redis.io/commands/eval>)+--+--+-- * MONITOR (<http://redis.io/commands/monitor>)+--+--+-- * DEBUG OBJECT (<http://redis.io/commands/debug-object>)+--+--+-- * DEBUG SEGFAULT (<http://redis.io/commands/debug-segfault>)+--+--+-- * SYNC (<http://redis.io/commands/sync>)+--+) where++import Prelude hiding (min,max)+import Data.ByteString (ByteString)+import Database.Redis.ManualCommands+import Database.Redis.Types+import Database.Redis.Internal+import Database.Redis.Reply++flushall+    :: Redis (Either Reply Status)+flushall  = sendRequest (["FLUSHALL"] )++hdel+    :: ByteString -- ^ key+    -> [ByteString] -- ^ field+    -> Redis (Either Reply Bool)+hdel key field = sendRequest (["HDEL"] ++ [encode key] ++ map encode field )++hincrby+    :: ByteString -- ^ key+    -> ByteString -- ^ field+    -> Integer -- ^ increment+    -> Redis (Either Reply Integer)+hincrby key field increment = sendRequest (["HINCRBY"] ++ [encode key] ++ [encode field] ++ [encode increment] )++configResetstat+    :: Redis (Either Reply Status)+configResetstat  = sendRequest (["CONFIG","RESETSTAT"] )++del+    :: [ByteString] -- ^ key+    -> Redis (Either Reply Integer)+del key = sendRequest (["DEL"] ++ map encode key )++zrevrank+    :: ByteString -- ^ key+    -> ByteString -- ^ member+    -> Redis (Either Reply Integer)+zrevrank key member = sendRequest (["ZREVRANK"] ++ [encode key] ++ [encode member] )++brpoplpush+    :: ByteString -- ^ source+    -> ByteString -- ^ destination+    -> Integer -- ^ timeout+    -> Redis (Either Reply ByteString)+brpoplpush source destination timeout = sendRequest (["BRPOPLPUSH"] ++ [encode source] ++ [encode destination] ++ [encode timeout] )++incrby+    :: ByteString -- ^ key+    -> Integer -- ^ increment+    -> Redis (Either Reply Integer)+incrby key increment = sendRequest (["INCRBY"] ++ [encode key] ++ [encode increment] )++rpop+    :: ByteString -- ^ key+    -> Redis (Either Reply ByteString)+rpop key = sendRequest (["RPOP"] ++ [encode key] )++setrange+    :: ByteString -- ^ key+    -> Integer -- ^ offset+    -> ByteString -- ^ value+    -> Redis (Either Reply Integer)+setrange key offset value = sendRequest (["SETRANGE"] ++ [encode key] ++ [encode offset] ++ [encode value] )++setbit+    :: ByteString -- ^ key+    -> Integer -- ^ offset+    -> ByteString -- ^ value+    -> Redis (Either Reply Integer)+setbit key offset value = sendRequest (["SETBIT"] ++ [encode key] ++ [encode offset] ++ [encode value] )++save+    :: Redis (Either Reply Status)+save  = sendRequest (["SAVE"] )++echo+    :: ByteString -- ^ message+    -> Redis (Either Reply ByteString)+echo message = sendRequest (["ECHO"] ++ [encode message] )++blpop+    :: [ByteString] -- ^ key+    -> Integer -- ^ timeout+    -> Redis (Either Reply (ByteString,ByteString))+blpop key timeout = sendRequest (["BLPOP"] ++ map encode key ++ [encode timeout] )++sdiffstore+    :: ByteString -- ^ destination+    -> [ByteString] -- ^ key+    -> Redis (Either Reply Integer)+sdiffstore destination key = sendRequest (["SDIFFSTORE"] ++ [encode destination] ++ map encode key )++move+    :: ByteString -- ^ key+    -> Integer -- ^ db+    -> Redis (Either Reply Bool)+move key db = sendRequest (["MOVE"] ++ [encode key] ++ [encode db] )++multi+    :: Redis (Either Reply Status)+multi  = sendRequest (["MULTI"] )++getrange+    :: ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ end+    -> Redis (Either Reply ByteString)+getrange key start end = sendRequest (["GETRANGE"] ++ [encode key] ++ [encode start] ++ [encode end] )++srem+    :: ByteString -- ^ key+    -> [ByteString] -- ^ member+    -> Redis (Either Reply Integer)+srem key member = sendRequest (["SREM"] ++ [encode key] ++ map encode member )++watch+    :: [ByteString] -- ^ key+    -> Redis (Either Reply Status)+watch key = sendRequest (["WATCH"] ++ map encode key )++getbit+    :: ByteString -- ^ key+    -> Integer -- ^ offset+    -> Redis (Either Reply Integer)+getbit key offset = sendRequest (["GETBIT"] ++ [encode key] ++ [encode offset] )++zcount+    :: ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> Redis (Either Reply Integer)+zcount key min max = sendRequest (["ZCOUNT"] ++ [encode key] ++ [encode min] ++ [encode max] )++quit+    :: Redis (Either Reply Status)+quit  = sendRequest (["QUIT"] )++msetnx+    :: [(ByteString,ByteString)] -- ^ keyValue+    -> Redis (Either Reply Bool)+msetnx keyValue = sendRequest (["MSETNX"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue )++sismember+    :: ByteString -- ^ key+    -> ByteString -- ^ member+    -> Redis (Either Reply Bool)+sismember key member = sendRequest (["SISMEMBER"] ++ [encode key] ++ [encode member] )++bgrewriteaof+    :: Redis (Either Reply Status)+bgrewriteaof  = sendRequest (["BGREWRITEAOF"] )++hmset+    :: ByteString -- ^ key+    -> [(ByteString,ByteString)] -- ^ fieldValue+    -> Redis (Either Reply Status)+hmset key fieldValue = sendRequest (["HMSET"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])fieldValue )++scard+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+scard key = sendRequest (["SCARD"] ++ [encode key] )++zincrby+    :: ByteString -- ^ key+    -> Integer -- ^ increment+    -> ByteString -- ^ member+    -> Redis (Either Reply Double)+zincrby key increment member = sendRequest (["ZINCRBY"] ++ [encode key] ++ [encode increment] ++ [encode member] )++sinter+    :: [ByteString] -- ^ key+    -> Redis (Either Reply [ByteString])+sinter key = sendRequest (["SINTER"] ++ map encode key )++mset+    :: [(ByteString,ByteString)] -- ^ keyValue+    -> Redis (Either Reply Status)+mset keyValue = sendRequest (["MSET"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue )++rpoplpush+    :: ByteString -- ^ source+    -> ByteString -- ^ destination+    -> Redis (Either Reply ByteString)+rpoplpush source destination = sendRequest (["RPOPLPUSH"] ++ [encode source] ++ [encode destination] )++hlen+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+hlen key = sendRequest (["HLEN"] ++ [encode key] )++setex+    :: ByteString -- ^ key+    -> Integer -- ^ seconds+    -> ByteString -- ^ value+    -> Redis (Either Reply Status)+setex key seconds value = sendRequest (["SETEX"] ++ [encode key] ++ [encode seconds] ++ [encode value] )++sunionstore+    :: ByteString -- ^ destination+    -> [ByteString] -- ^ key+    -> Redis (Either Reply Integer)+sunionstore destination key = sendRequest (["SUNIONSTORE"] ++ [encode destination] ++ map encode key )++brpop+    :: [ByteString] -- ^ key+    -> Integer -- ^ timeout+    -> Redis (Either Reply (ByteString,ByteString))+brpop key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout] )++hgetall+    :: ByteString -- ^ key+    -> Redis (Either Reply [(ByteString,ByteString)])+hgetall key = sendRequest (["HGETALL"] ++ [encode key] )++dbsize+    :: Redis (Either Reply Integer)+dbsize  = sendRequest (["DBSIZE"] )++lpop+    :: ByteString -- ^ key+    -> Redis (Either Reply ByteString)+lpop key = sendRequest (["LPOP"] ++ [encode key] )++hmget+    :: ByteString -- ^ key+    -> [ByteString] -- ^ field+    -> Redis (Either Reply [Maybe ByteString])+hmget key field = sendRequest (["HMGET"] ++ [encode key] ++ map encode field )++lrange+    :: ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> Redis (Either Reply [ByteString])+lrange key start stop = sendRequest (["LRANGE"] ++ [encode key] ++ [encode start] ++ [encode stop] )++expire+    :: ByteString -- ^ key+    -> Integer -- ^ seconds+    -> Redis (Either Reply Bool)+expire key seconds = sendRequest (["EXPIRE"] ++ [encode key] ++ [encode seconds] )++lastsave+    :: Redis (Either Reply Integer)+lastsave  = sendRequest (["LASTSAVE"] )++llen+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+llen key = sendRequest (["LLEN"] ++ [encode key] )++decrby+    :: ByteString -- ^ key+    -> Integer -- ^ decrement+    -> Redis (Either Reply Integer)+decrby key decrement = sendRequest (["DECRBY"] ++ [encode key] ++ [encode decrement] )++exec+    :: Redis (Either Reply Reply)+exec  = sendRequest (["EXEC"] )++mget+    :: [ByteString] -- ^ key+    -> Redis (Either Reply [Maybe ByteString])+mget key = sendRequest (["MGET"] ++ map encode key )++zadd+    :: ByteString -- ^ key+    -> [(Double,ByteString)] -- ^ scoreMember+    -> Redis (Either Reply Integer)+zadd key scoreMember = sendRequest (["ZADD"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])scoreMember )++keys+    :: ByteString -- ^ pattern+    -> Redis (Either Reply [ByteString])+keys pattern = sendRequest (["KEYS"] ++ [encode pattern] )++bgsave+    :: Redis (Either Reply Status)+bgsave  = sendRequest (["BGSAVE"] )++slaveof+    :: ByteString -- ^ host+    -> ByteString -- ^ port+    -> Redis (Either Reply Status)+slaveof host port = sendRequest (["SLAVEOF"] ++ [encode host] ++ [encode port] )++getset+    :: ByteString -- ^ key+    -> ByteString -- ^ value+    -> Redis (Either Reply (Maybe ByteString))+getset key value = sendRequest (["GETSET"] ++ [encode key] ++ [encode value] )++rpushx+    :: ByteString -- ^ key+    -> ByteString -- ^ value+    -> Redis (Either Reply Integer)+rpushx key value = sendRequest (["RPUSHX"] ++ [encode key] ++ [encode value] )++setnx+    :: ByteString -- ^ key+    -> ByteString -- ^ value+    -> Redis (Either Reply Bool)+setnx key value = sendRequest (["SETNX"] ++ [encode key] ++ [encode value] )++zrank+    :: ByteString -- ^ key+    -> ByteString -- ^ member+    -> Redis (Either Reply Integer)+zrank key member = sendRequest (["ZRANK"] ++ [encode key] ++ [encode member] )++zremrangebyscore+    :: ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> Redis (Either Reply Integer)+zremrangebyscore key min max = sendRequest (["ZREMRANGEBYSCORE"] ++ [encode key] ++ [encode min] ++ [encode max] )++ttl+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+ttl key = sendRequest (["TTL"] ++ [encode key] )++hkeys+    :: ByteString -- ^ key+    -> Redis (Either Reply [ByteString])+hkeys key = sendRequest (["HKEYS"] ++ [encode key] )++rpush+    :: ByteString -- ^ key+    -> [ByteString] -- ^ value+    -> Redis (Either Reply Integer)+rpush key value = sendRequest (["RPUSH"] ++ [encode key] ++ map encode value )++randomkey+    :: Redis (Either Reply ByteString)+randomkey  = sendRequest (["RANDOMKEY"] )++spop+    :: ByteString -- ^ key+    -> Redis (Either Reply ByteString)+spop key = sendRequest (["SPOP"] ++ [encode key] )++hsetnx+    :: ByteString -- ^ key+    -> ByteString -- ^ field+    -> ByteString -- ^ value+    -> Redis (Either Reply Bool)+hsetnx key field value = sendRequest (["HSETNX"] ++ [encode key] ++ [encode field] ++ [encode value] )++configGet+    :: ByteString -- ^ parameter+    -> Redis (Either Reply [(ByteString,ByteString)])+configGet parameter = sendRequest (["CONFIG","GET"] ++ [encode parameter] )++hvals+    :: ByteString -- ^ key+    -> Redis (Either Reply [ByteString])+hvals key = sendRequest (["HVALS"] ++ [encode key] )++exists+    :: ByteString -- ^ key+    -> Redis (Either Reply Bool)+exists key = sendRequest (["EXISTS"] ++ [encode key] )++sunion+    :: [ByteString] -- ^ key+    -> Redis (Either Reply [ByteString])+sunion key = sendRequest (["SUNION"] ++ map encode key )++zrem+    :: ByteString -- ^ key+    -> [ByteString] -- ^ member+    -> Redis (Either Reply Integer)+zrem key member = sendRequest (["ZREM"] ++ [encode key] ++ map encode member )++smembers+    :: ByteString -- ^ key+    -> Redis (Either Reply [ByteString])+smembers key = sendRequest (["SMEMBERS"] ++ [encode key] )++ping+    :: Redis (Either Reply Status)+ping  = sendRequest (["PING"] )++rename+    :: ByteString -- ^ key+    -> ByteString -- ^ newkey+    -> Redis (Either Reply Status)+rename key newkey = sendRequest (["RENAME"] ++ [encode key] ++ [encode newkey] )++decr+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+decr key = sendRequest (["DECR"] ++ [encode key] )++select+    :: Integer -- ^ index+    -> Redis (Either Reply Status)+select index = sendRequest (["SELECT"] ++ [encode index] )++hexists+    :: ByteString -- ^ key+    -> ByteString -- ^ field+    -> Redis (Either Reply Bool)+hexists key field = sendRequest (["HEXISTS"] ++ [encode key] ++ [encode field] )++auth+    :: ByteString -- ^ password+    -> Redis (Either Reply Status)+auth password = sendRequest (["AUTH"] ++ [encode password] )++sinterstore+    :: ByteString -- ^ destination+    -> [ByteString] -- ^ key+    -> Redis (Either Reply Integer)+sinterstore destination key = sendRequest (["SINTERSTORE"] ++ [encode destination] ++ map encode key )++shutdown+    :: Redis (Either Reply Status)+shutdown  = sendRequest (["SHUTDOWN"] )++configSet+    :: ByteString -- ^ parameter+    -> ByteString -- ^ value+    -> Redis (Either Reply Status)+configSet parameter value = sendRequest (["CONFIG","SET"] ++ [encode parameter] ++ [encode value] )++renamenx+    :: ByteString -- ^ key+    -> ByteString -- ^ newkey+    -> Redis (Either Reply Bool)+renamenx key newkey = sendRequest (["RENAMENX"] ++ [encode key] ++ [encode newkey] )++expireat+    :: ByteString -- ^ key+    -> Integer -- ^ timestamp+    -> Redis (Either Reply Bool)+expireat key timestamp = sendRequest (["EXPIREAT"] ++ [encode key] ++ [encode timestamp] )++get+    :: ByteString -- ^ key+    -> Redis (Either Reply (Maybe ByteString))+get key = sendRequest (["GET"] ++ [encode key] )++lrem+    :: ByteString -- ^ key+    -> Integer -- ^ count+    -> ByteString -- ^ value+    -> Redis (Either Reply Integer)+lrem key count value = sendRequest (["LREM"] ++ [encode key] ++ [encode count] ++ [encode value] )++incr+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+incr key = sendRequest (["INCR"] ++ [encode key] )++zcard+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+zcard key = sendRequest (["ZCARD"] ++ [encode key] )++ltrim+    :: ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> Redis (Either Reply Status)+ltrim key start stop = sendRequest (["LTRIM"] ++ [encode key] ++ [encode start] ++ [encode stop] )++append+    :: ByteString -- ^ key+    -> ByteString -- ^ value+    -> Redis (Either Reply Integer)+append key value = sendRequest (["APPEND"] ++ [encode key] ++ [encode value] )++lset+    :: ByteString -- ^ key+    -> Integer -- ^ index+    -> ByteString -- ^ value+    -> Redis (Either Reply Status)+lset key index value = sendRequest (["LSET"] ++ [encode key] ++ [encode index] ++ [encode value] )++info+    :: Redis (Either Reply ByteString)+info  = sendRequest (["INFO"] )++hget+    :: ByteString -- ^ key+    -> ByteString -- ^ field+    -> Redis (Either Reply (Maybe ByteString))+hget key field = sendRequest (["HGET"] ++ [encode key] ++ [encode field] )++sdiff+    :: [ByteString] -- ^ key+    -> Redis (Either Reply [ByteString])+sdiff key = sendRequest (["SDIFF"] ++ map encode key )++smove+    :: ByteString -- ^ source+    -> ByteString -- ^ destination+    -> ByteString -- ^ member+    -> Redis (Either Reply Bool)+smove source destination member = sendRequest (["SMOVE"] ++ [encode source] ++ [encode destination] ++ [encode member] )++flushdb+    :: Redis (Either Reply Status)+flushdb  = sendRequest (["FLUSHDB"] )++set+    :: ByteString -- ^ key+    -> ByteString -- ^ value+    -> Redis (Either Reply Status)+set key value = sendRequest (["SET"] ++ [encode key] ++ [encode value] )++zremrangebyrank+    :: ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> Redis (Either Reply Integer)+zremrangebyrank key start stop = sendRequest (["ZREMRANGEBYRANK"] ++ [encode key] ++ [encode start] ++ [encode stop] )++sadd+    :: ByteString -- ^ key+    -> [ByteString] -- ^ member+    -> Redis (Either Reply Integer)+sadd key member = sendRequest (["SADD"] ++ [encode key] ++ map encode member )++lpush+    :: ByteString -- ^ key+    -> [ByteString] -- ^ value+    -> Redis (Either Reply Integer)+lpush key value = sendRequest (["LPUSH"] ++ [encode key] ++ map encode value )++lindex+    :: ByteString -- ^ key+    -> Integer -- ^ index+    -> Redis (Either Reply ByteString)+lindex key index = sendRequest (["LINDEX"] ++ [encode key] ++ [encode index] )++zscore+    :: ByteString -- ^ key+    -> ByteString -- ^ member+    -> Redis (Either Reply Double)+zscore key member = sendRequest (["ZSCORE"] ++ [encode key] ++ [encode member] )++strlen+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+strlen key = sendRequest (["STRLEN"] ++ [encode key] )++unwatch+    :: Redis (Either Reply Status)+unwatch  = sendRequest (["UNWATCH"] )++hset+    :: ByteString -- ^ key+    -> ByteString -- ^ field+    -> ByteString -- ^ value+    -> Redis (Either Reply Bool)+hset key field value = sendRequest (["HSET"] ++ [encode key] ++ [encode field] ++ [encode value] )++lpushx+    :: ByteString -- ^ key+    -> ByteString -- ^ value+    -> Redis (Either Reply Integer)+lpushx key value = sendRequest (["LPUSHX"] ++ [encode key] ++ [encode value] )++discard+    :: Redis (Either Reply Status)+discard  = sendRequest (["DISCARD"] )++srandmember+    :: ByteString -- ^ key+    -> Redis (Either Reply ByteString)+srandmember key = sendRequest (["SRANDMEMBER"] ++ [encode key] )++persist+    :: ByteString -- ^ key+    -> Redis (Either Reply Bool)+persist key = sendRequest (["PERSIST"] ++ [encode key] )+++-- * Unimplemented Commands+-- |These commands are not implemented, as of now. Library users can implement them with the 'sendRequest' function.+--+-- * EVAL (<http://redis.io/commands/eval>)+--+--+-- * MONITOR (<http://redis.io/commands/monitor>)+--+--+-- * DEBUG OBJECT (<http://redis.io/commands/debug-object>)+--+--+-- * DEBUG SEGFAULT (<http://redis.io/commands/debug-segfault>)+--+--+-- * SYNC (<http://redis.io/commands/sync>)+--+
+ src/Database/Redis/Internal.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Database.Redis.Internal (+    HostName,PortID(..), defaultPort,+    RedisConn(), connect, disconnect,+    Redis(),runRedis,+    send,+    recv,+    sendRequest+) where++import Control.Applicative+import Control.Monad.RWS+import Control.Concurrent+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.Char8 as LB+import Network (HostName, PortID(..), connectTo)+import System.IO (Handle, hFlush, hClose, hIsOpen)++import Database.Redis.Reply+import Database.Redis.Request+import Database.Redis.Types++------------------------------------------------------------------------------+-- Connection+--++-- |Connection to a Redis server. Use the 'connect' function to create one.+--+--  A 'RedisConn' can only be used by a single thread at a time. This means that+--  calls to 'runRedis' or 'disconnet' may block when the 'RedisConn' is shared+--  between multiple threads.+data RedisConn = Conn (MVar (Handle, [Reply]))++withConn :: RedisConn+         -> (Handle -> [Reply] -> IO ([Reply], a))+         -> IO a+withConn (Conn conn) f = do+    (h,rs)     <- takeMVar conn+    (rs',a) <- f h rs+    putMVar conn (h,rs')+    return a++-- |Opens a connection to a Redis server at the given host and port.+connect :: HostName -> PortID -> IO RedisConn+connect host port = do+    h       <- connectTo host port+    replies <- parseReply <$> LB.hGetContents h+    Conn <$> newMVar (h, replies)++-- |Close the given connection.+--+--  May block when the given 'RedisConn' is shared between multiple threads. The+-- 'RedisConn' can not be re-used.+disconnect :: RedisConn -> IO ()+disconnect conn = withConn conn $ \h rs -> do+    open <- hIsOpen h+    when open (hClose h)+    return (rs, ())++-- | The Redis default port 6379. Equivalent to @'PortNumber' 6379@.+defaultPort :: PortID+defaultPort = PortNumber 6379++------------------------------------------------------------------------------+-- The Redis Monad+--+newtype Redis a = Redis (RWST Handle () [Reply] IO a)+    deriving (Monad, MonadIO, Functor, Applicative)++-- |Interact with a Redis datastore specified by the given 'RedisConn'.+--+--  May block when the given 'RedisConn' is shared between multiple threads.+runRedis :: RedisConn -> Redis a -> IO a+runRedis conn (Redis redis) = withConn conn $ \h rs -> do+    open <- hIsOpen h+    if open+        then do+            (a,rs',_) <- runRWST redis h rs+            return (rs',a)+        else error "Redis: disconnected"++send :: [B.ByteString] -> Redis ()+send req = Redis $ do+    h <- ask+    liftIO $ do+        B.hPut h $ renderRequest req+        hFlush h++recv :: Redis Reply+recv = Redis $ do+    -- head/tail avoids forcing the ':' constructor, enabling automatic+    -- pipelining.+    rs <- get+    put (tail rs)+    return (head rs)++-- |Sends a request to the Redis server, returning the 'decode'd reply.+sendRequest :: (RedisResult a) => [B.ByteString] -> Redis (Either Reply a)+sendRequest req = decode <$> (send req >> recv)
+ src/Database/Redis/ManualCommands.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}++module Database.Redis.ManualCommands where++import Prelude hiding (min,max)+import Data.ByteString (ByteString)+import Database.Redis.Internal+import Database.Redis.Reply+import Database.Redis.Types+++objectRefcount+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+objectRefcount key = sendRequest ["OBJECT", "refcount", encode key]++objectIdletime+    :: ByteString -- ^ key+    -> Redis (Either Reply Integer)+objectIdletime key = sendRequest ["OBJECT", "idletime", encode key]++objectEncoding+    :: ByteString -- ^ key+    -> Redis (Either Reply ByteString)+objectEncoding key = sendRequest ["OBJECT", "encoding", encode key]++linsertBefore+    :: ByteString -- ^ key+    -> ByteString -- ^ pivot+    -> ByteString -- ^ value+    -> Redis (Either Reply Integer)+linsertBefore key pivot value =+    sendRequest ["LINSERT", encode key, "BEFORE", encode pivot, encode value]++linsertAfter+    :: ByteString -- ^ key+    -> ByteString -- ^ pivot+    -> ByteString -- ^ value+    -> Redis (Either Reply Integer)+linsertAfter key pivot value =+        sendRequest ["LINSERT", encode key, "AFTER", encode pivot, encode value]++getType+    :: ByteString -- ^ key+    -> Redis (Either Reply Status)+getType key = sendRequest ["TYPE", encode key]++slowlogGet+    :: Integer -- ^ cnt+    -> Redis (Either Reply Reply)+slowlogGet n = sendRequest ["SLOWLOG", "GET", encode n]++slowlogLen :: Redis (Either Reply Integer)+slowlogLen = sendRequest ["SLOWLOG", "LEN"]++slowlogReset :: Redis (Either Reply Status)+slowlogReset = sendRequest ["SLOWLOG", "RESET"]++zrange+    :: ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> Redis (Either Reply [ByteString])+zrange key start stop =+    sendRequest ["ZRANGE", encode key, encode start, encode stop]++zrangeWithscores+    :: ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> Redis (Either Reply [(ByteString,Double)])+zrangeWithscores key start stop =+    sendRequest ["ZRANGE", encode key, encode start, encode stop, "WITHSCORES"]++zrevrange+    :: ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> Redis (Either Reply [ByteString])+zrevrange key start stop =+    sendRequest ["ZREVRANGE", encode key, encode start, encode stop]++zrevrangeWithscores+    :: ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> Redis (Either Reply [(ByteString,Double)])+zrevrangeWithscores key start stop =+    sendRequest ["ZREVRANGE", encode key, encode start, encode stop+                ,"WITHSCORES"]++zrangebyscore+    :: ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> Redis (Either Reply [ByteString])+zrangebyscore key min max =+    sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max]++zrangebyscoreWithscores+    :: ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> Redis (Either Reply [(ByteString,Double)])+zrangebyscoreWithscores key min max =+    sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max+                ,"WITHSCORES"]++zrangebyscoreLimit+    :: ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> Integer -- ^ offset+    -> Integer -- ^ count+    -> Redis (Either Reply [ByteString])+zrangebyscoreLimit key min max offset count =+    sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max+                ,"LIMIT", encode offset, encode count]++zrangebyscoreWithscoresLimit+    :: ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> Integer -- ^ offset+    -> Integer -- ^ count+    -> Redis (Either Reply [(ByteString,Double)])+zrangebyscoreWithscoresLimit key min max offset count =+    sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max+                ,"WITHSCORES","LIMIT", encode offset, encode count]++zrevrangebyscore+    :: ByteString -- ^ key+    -> Double -- ^ max+    -> Double -- ^ min+    -> Redis (Either Reply [ByteString])+zrevrangebyscore key min max =+    sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max]++zrevrangebyscoreWithscores+    :: ByteString -- ^ key+    -> Double -- ^ max+    -> Double -- ^ min+    -> Redis (Either Reply [(ByteString,Double)])+zrevrangebyscoreWithscores key min max =+    sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max+                ,"WITHSCORES"]++zrevrangebyscoreLimit+    :: ByteString -- ^ key+    -> Double -- ^ max+    -> Double -- ^ min+    -> Integer -- ^ offset+    -> Integer -- ^ count+    -> Redis (Either Reply [ByteString])+zrevrangebyscoreLimit key min max offset count =+    sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max+                ,"LIMIT", encode offset, encode count]++zrevrangebyscoreWithscoresLimit+    :: ByteString -- ^ key+    -> Double -- ^ max+    -> Double -- ^ min+    -> Integer -- ^ offset+    -> Integer -- ^ count+    -> Redis (Either Reply [(ByteString,Double)])+zrevrangebyscoreWithscoresLimit key min max offset count =+    sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max+                ,"WITHSCORES","LIMIT", encode offset, encode count]++data SortOpts = SortOpts+    { sortBy     :: Maybe ByteString+    , sortLimit  :: (Integer,Integer)+    , sortGet    :: [ByteString]+    , sortOrder  :: SortOrder+    , sortAlpha  :: Bool+    } deriving (Show, Eq)++defaultSortOpts :: SortOpts+defaultSortOpts = SortOpts+    { sortBy    = Nothing+    , sortLimit = (0,-1)+    , sortGet   = []+    , sortOrder = Asc+    , sortAlpha = False+    }++data SortOrder = Asc | Desc deriving (Show, Eq)++sortStore+    :: ByteString -- ^ key+    -> ByteString -- ^ destination+    -> SortOpts+    -> Redis (Either Reply Integer)+sortStore key dest = sortInternal key (Just dest)++sort+    :: ByteString -- ^ key+    -> SortOpts+    -> Redis (Either Reply [ByteString])+sort key = sortInternal key Nothing++sortInternal+    :: (RedisResult a)+    => ByteString -- ^ key+    -> Maybe ByteString -- ^ destination+    -> SortOpts+    -> Redis (Either Reply 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+    :: ByteString -- ^ destination+    -> [ByteString] -- ^ keys+    -> Aggregate+    -> Redis (Either Reply Integer)+zunionstore dest keys =+    zstoreInternal "ZUNIONSTORE" dest keys []++zunionstoreWeights+    :: ByteString -- ^ destination+    -> [(ByteString,Double)] -- ^ weighted keys+    -> Aggregate+    -> Redis (Either Reply Integer)+zunionstoreWeights dest kws =+    let (keys,weights) = unzip kws+    in zstoreInternal "ZUNIONSTORE" dest keys weights++zinterstore+    :: ByteString -- ^ destination+    -> [ByteString] -- ^ keys+    -> Aggregate+    -> Redis (Either Reply Integer)+zinterstore dest keys =+    zstoreInternal "ZINTERSTORE" dest keys []++zinterstoreWeights+    :: ByteString -- ^ destination+    -> [(ByteString,Double)] -- ^ weighted keys+    -> Aggregate+    -> Redis (Either Reply Integer)+zinterstoreWeights dest kws =+    let (keys,weights) = unzip kws+    in zstoreInternal "ZINTERSTORE" dest keys weights++zstoreInternal+    :: ByteString -- ^ cmd+    -> ByteString -- ^ destination+    -> [ByteString] -- ^ keys+    -> [Double] -- ^ weights+    -> Aggregate+    -> Redis (Either Reply 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"
+ src/Database/Redis/PubSub.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Database.Redis.PubSub (+    publish,+    pubSub,+    Message(..),+    PubSub(),+    subscribe, unsubscribe,+    psubscribe, punsubscribe,+) where++import Control.Applicative+import Control.Monad.Writer+import Data.ByteString.Char8 (ByteString)+import Data.Maybe+import Database.Redis.Internal (Redis)+import qualified Database.Redis.Internal as Internal+import Database.Redis.Reply+import Database.Redis.Types+++newtype PubSub = PubSub [[ByteString]]++instance Monoid PubSub where+    mempty                         = PubSub []+    mappend (PubSub p) (PubSub p') = PubSub (p ++ p')++data Message = Message  { msgChannel, msgMessage :: ByteString}+             | PMessage { msgPattern, msgChannel, msgMessage :: ByteString}+    deriving (Show)++------------------------------------------------------------------------------+-- Public Interface+--++-- |Post a message to a channel (<http://redis.io/commands/publish>).+publish+    :: ByteString -- ^ channel+    -> ByteString -- ^ message+    -> Redis (Either Reply Integer)+publish channel message =+    Internal.sendRequest ["PUBLISH", channel, message]++-- |Listen for messages published to the given channels+--  (<http://redis.io/commands/subscribe>).+subscribe+    :: [ByteString] -- ^ channel+    -> PubSub+subscribe = pubSubAction "SUBSCRIBE"++-- |Stop listening for messages posted to the given channels +--  (<http://redis.io/commands/unsubscribe>).+unsubscribe+    :: [ByteString] -- ^ channel+    -> PubSub+unsubscribe = pubSubAction "UNSUBSCRIBE"++-- |Listen for messages published to channels matching the given patterns +--  (<http://redis.io/commands/psubscribe>).+psubscribe+    :: [ByteString] -- ^ pattern+    -> PubSub+psubscribe = pubSubAction "PSUBSCRIBE"++-- |Stop listening for messages posted to channels matching the given patterns +--  (<http://redis.io/commands/punsubscribe>).+punsubscribe+    :: [ByteString] -- ^ pattern+    -> PubSub+punsubscribe = pubSubAction "PUNSUBSCRIBE"++-- |Listens to published messages on subscribed channels.+--  +--  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.+    -> Redis ()+pubSub p callback = send p 0+  where+    send (PubSub cmds) pending = do+        mapM_ Internal.send cmds+        recv (pending + length cmds)++    recv pending = do+        reply <- Internal.recv        +        case decodeMsg reply of+            Left cnt+                | cnt == 0 && pending == 0+                            -> return ()+                | otherwise -> send mempty (pending - 1)+            Right msg       -> do act <- liftIO $ callback msg+                                  send act pending++------------------------------------------------------------------------------+-- Helpers+--++pubSubAction :: ByteString -> [ByteString] -> PubSub+pubSubAction cmd chans = PubSub [cmd : chans]++decodeMsg :: Reply -> Either Integer Message+decodeMsg (MultiBulk (Just (r0:r1:r2:rs))) = either (error "decodeMsg") id $ do+    kind <- decode r0+    case kind :: ByteString of+        "message"  -> Right <$> decodeMessage+        "pmessage" -> Right <$> decodePMessage+        -- kind `elem` ["subscribe","unsubscribe","psubscribe","punsubscribe"]+        _          -> Left <$> decode r2+  where+    decodeMessage  = Message  <$> decode r1 <*> decode r2+    decodePMessage = PMessage <$> decode r1 <*> decode r2+                                    <*> decode (head rs)+        +decodeMsg r = error $ "not a message: " ++ show r
+ src/Database/Redis/Reply.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Redis.Reply (Reply(..), parseReply) where++import Prelude hiding (error, take)+import Control.Applicative+import Data.Attoparsec.Char8+import qualified Data.Attoparsec.Lazy as P+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++-- |Low-level representation of replies from the Redis server.+data Reply = SingleLine S.ByteString+           | Error S.ByteString+           | Integer Integer+           | Bulk (Maybe S.ByteString)+           | MultiBulk (Maybe [Reply])+         deriving (Eq, Show)++-- |Parse a lazy 'L.ByteString' into a (possibly infinite) list of 'Reply's.+parseReply :: L.ByteString -> [Reply]+parseReply input =+    case P.parse reply input of+        P.Fail _ _ _  -> []+        P.Done rest r -> r : parseReply rest++------------------------------------------------------------------------------+-- Reply parsers+--+reply :: Parser Reply+reply = choice [singleLine, integer, bulk, multiBulk, error]++singleLine :: Parser Reply+singleLine = SingleLine <$> '+' `prefixing` line++error :: Parser Reply+error = Error <$> '-' `prefixing` line++integer :: Parser Reply+integer = Integer <$> ':' `prefixing` signed decimal++bulk :: Parser Reply+bulk = Bulk <$> do    +    len <- '$' `prefixing` signed decimal+    if len < 0+        then return Nothing+        else Just <$> P.take len <* crlf++multiBulk :: Parser Reply+multiBulk = MultiBulk <$> do+        len <- '*' `prefixing` signed decimal+        if len < 0+            then return Nothing+            else Just <$> count len reply+++------------------------------------------------------------------------------+-- Helpers & Combinators+--+prefixing :: Char -> Parser a -> Parser a+c `prefixing` a = char c *> a <* crlf++crlf :: Parser S.ByteString+crlf = string "\r\n"++line :: Parser S.ByteString+line = takeTill (=='\r')
+ src/Database/Redis/Request.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Redis.Request (renderRequest) where++import qualified Data.ByteString.Char8 as S+++renderRequest :: [S.ByteString] -> S.ByteString+renderRequest req = S.concat (argCnt:args)+  where+    argCnt = S.concat ["*", showBS (length req), crlf]+    args   = map renderArg req+++renderArg :: S.ByteString -> S.ByteString+renderArg arg = S.concat ["$",  argLen arg, crlf, arg, crlf]+  where+    argLen = showBS . S.length+++showBS :: (Show a) => a -> S.ByteString+showBS = S.pack . show++crlf :: S.ByteString+crlf = "\r\n"
+ src/Database/Redis/Types.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances,+        TypeSynonymInstances, OverloadedStrings #-}++module Database.Redis.Types where++import Control.Applicative+import Control.Monad+import Data.ByteString.Char8 (ByteString, pack)+import Data.ByteString.Lex.Double (readDouble)+import Data.Maybe+import Database.Redis.Reply++------------------------------------------------------------------------------+-- 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 | None | String | Hash | List | Set | ZSet | Queued+    deriving (Show, Eq)++instance RedisResult Reply where+    decode = Right++instance RedisResult ByteString where+    decode (Bulk (Just s)) = Right s+    decode r               = Left r++instance RedisResult Integer where+    decode (Integer n) = Right n+    decode r           = Left r++instance RedisResult Double where+    decode r = maybe (Left r) (Right . fst) . readDouble =<< decode r++instance RedisResult Status where+    decode (SingleLine s) = Right $ case s of+        "OK"     -> Ok+        "PONG"   -> Pong+        "none"   -> None+        "string" -> String+        "hash"   -> Hash+        "list"   -> List+        "set"    -> Set+        "zset"   -> ZSet+        "QUEUED" -> Queued+        _        -> error $ "unhandled status-code: " ++ show s+    decode r = Left r++instance RedisResult Bool where+    decode (Integer 1) = Right True+    decode (Integer 0) = Right False+    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