redis-0.1: Database/Redis/Redis.hs
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-}
-- | Main Redis API and protocol implementation
module Database.Redis.Redis (
-- * Types ans Constructors
Redis(..),
Reply(..),
Interval(..),
IsInterval(..),
SortOptions(..),
sortDefaults,
fromRInline, fromRBulk, fromRMulti, fromRMultiBulk,
fromRInt, fromROk, noError, takeAll,
-- * Database connection
localhost, defaultPort,
connect, disconnect, isConnected,
-- * Redis commands
-- ** Generic
ping, auth, quit, shutdown,
multi, exec, run_multi, exists,
del, getType, keys, randomKey, rename,
renameNx, dbsize, expire, expireAt,
ttl, select, move, flushDb,
flushAll, info,
-- ** Strings
set, setNx, mSet, mSetNx,
get, getSet, mGet,
incr, incrBy, decr,
decrBy, append,
-- ** Lists
rpush, lpush, llen, lrange, ltrim,
lindex, lset, lrem, lpop, rpop,
rpoplpush, blpop, brpop,
-- ** Sets
sadd, srem, spop, smove, scard, sismember,
smembers, srandmember, sinter, sinterStore,
sunion, sunionStore, sdiff, sdiffStore,
-- ** Sorted sets
zadd, zrem, zincrBy, zrange,
zrevrange, zrangebyscore, zcount,
zremrangebyscore, zcard, zscore,
-- ** Sorting
sort, listRelated,
-- ** Persistent control
save, bgsave, lastsave, bgrewriteaof
)
where
import qualified Network.Socket as S
import qualified System.IO as IO
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as U
import Data.Maybe (fromJust)
-- | Redis connection descriptor
data Redis = Redis { server :: (String, String), -- ^ hostname and port pair
handle :: IO.Handle -- ^ real network connection
}
deriving (Show, Eq)
-- | Redis command variants
data Command = CInline String
| CMInline [String]
| CBulk [String] String
| CMBulk [String]
-- | Redis reply variants
data Reply = RTimeout -- ^ Timeout. Currently unused
| ROk -- ^ \"Ok\" reply
| RPong -- ^ Reply for the ping command
| RQueued -- ^ Used inside multi-exec block
| RError String -- ^ Some kind of server-side error
| RInline String -- ^ Simple oneline reply
| RInt Int -- ^ Integer reply
| RBulk (Maybe String) -- ^ Multiline reply
| RMulti (Maybe [Reply]) -- ^ Complex reply. It may consists of various type of replys
deriving (Show, Eq)
-- | Unwraps RInline reply.
--
-- Throws an exception when called with something different from RInline
fromRInline :: (Monad m) => Reply -> m String
fromRInline reply = case reply of
RError msg -> error msg
RInline s -> return s
_ -> error $ "wrong reply, RInline expected: " ++ (show reply)
-- | Unwraps RBulk reply.
--
-- Throws an exception when called with something different from RBulk
fromRBulk :: (Monad m) => Reply -> m (Maybe String)
fromRBulk reply = case reply of
RError msg -> error msg
RBulk s -> return s
_ -> error $ "wrong reply, RBulk expected: " ++ (show reply)
-- | Unwraps RMulti reply
--
-- Throws an exception when called with something different from RMulti
fromRMulti :: (Monad m) => Reply -> m (Maybe [Reply])
fromRMulti reply = case reply of
RError msg -> error msg
RMulti ss -> return ss
_ -> error $ "wrong reply, RMulti expected: " ++ (show reply)
-- | Unwraps RMulti reply filled with RBulk
--
-- Throws an exception when called with something different from RMulti
fromRMultiBulk :: (Monad m) => Reply -> m (Maybe [Maybe String])
fromRMultiBulk reply = fromRMulti reply >>= return . (>>= sequence . map fromRBulk)
-- | Unwraps RInt reply
--
-- Throws an exception when called with something different from RInt
fromRInt :: (Monad m) => Reply -> m Int
fromRInt reply = case reply of
RError msg -> error msg
RInt n -> return n
_ -> error $ "wrong reply, RInt expected: " ++ (show reply)
-- | Unwraps ROk reply
--
-- Throws an exception when called with something different from ROk
fromROk :: (Monad m) => Reply -> m ()
fromROk reply = case reply of
RError msg -> error msg
ROk -> return ()
_ -> error $ "wrong reply, ROk expected: " ++ (show reply)
-- | Unwraps every non-error reply
--
-- Throws an exception when called with something different from RMulti
noError :: (Monad m) => Reply -> m ()
noError reply = case reply of
RError msg -> error msg
_ -> return ()
urn = U.fromString "\r\n"
uspace = U.fromString " "
uminus = U.fromString "-"
uplus = U.fromString "+"
ucolon = U.fromString ":"
ubucks = U.fromString "$"
uasterisk = U.fromString "*"
hPutRn h = B.hPut h urn
-- | default Redis port
defaultPort :: String
defaultPort = "6379"
-- | just a localhost
localhost :: String
localhost = "localhost"
-- | a (0, -1) range - takes all element from a list in lrange, zrange
-- and so on
takeAll :: (Int, Int)
takeAll = (0, -1)
-- | Conects to Redis server and returns connection descriptor
connect :: String -> String -> IO Redis
connect hostname port =
do serveraddr <- head `fmap` S.getAddrInfo Nothing (Just hostname) (Just port)
s <- S.socket (S.addrFamily serveraddr) S.Stream S.defaultProtocol
S.setSocketOption s S.KeepAlive 1
S.connect s (S.addrAddress serveraddr)
h <- S.socketToHandle s IO.ReadWriteMode
IO.hSetBuffering h (IO.BlockBuffering Nothing)
return $ Redis (hostname, port) h
-- | Close connection
disconnect :: Redis -> IO ()
disconnect = IO.hClose . handle
-- | Returns True when connection handler is opened
isConnected :: Redis -> IO Bool
isConnected = IO.hIsOpen . handle
{- ================ Private =============== -}
send :: IO.Handle -> [String] -> IO ()
send h [] = return ()
send h (s:ls) = let bs = U.fromString s
in B.hPut h bs >> B.hPut h uspace >> send h ls
sendCommand :: Redis -> Command -> IO ()
sendCommand r (CInline s) = let h = handle r
bs = U.fromString s
in B.hPut h bs >> hPutRn h >> IO.hFlush h
sendCommand r (CMInline ls) = let h = handle r
in send h ls >> hPutRn h >> IO.hFlush h
sendCommand r (CBulk lcmd s) = let h = handle r
bs = U.fromString s
size = U.fromString $ show $ B.length bs
in do send h lcmd
B.hPut h uspace
B.hPut h size
hPutRn h
B.hPut h bs
hPutRn h
IO.hFlush h
sendCommand r (CMBulk strings) = let h = handle r
sendls [] = return ()
sendls (l:ls) = let bs = U.fromString l
size = U.fromString . show . B.length
in do B.hPut h ubucks
B.hPut h $ size bs
hPutRn h
B.hPut h bs
hPutRn h
sendls ls
in do B.hPut h uasterisk
B.hPut h $ U.fromString $ show $ length strings
hPutRn h
sendls strings
IO.hFlush h
recv :: Redis -> IO Reply
recv r = do first <- bsToStr `fmap` B.hGetLine h
case first of
('-':rest) -> recv_err rest
('+':rest) -> recv_inline rest
(':':rest) -> recv_int rest
('$':rest) -> recv_bulk rest
('*':rest) -> recv_multi rest
where
h = handle r
bsToStr = (takeWhile (\c -> c /= '\r' && c /= '\n')) . U.toString
recv_err :: String -> IO Reply
recv_err rest = return $ RError rest
recv_inline :: String -> IO Reply
recv_inline rest = return $ case rest of
"OK" -> ROk
"PONG" -> RPong
"QUEUED" -> RQueued
_ -> RInline rest
recv_int :: String -> IO Reply
recv_int rest = let reply = read rest :: Int
in return $ RInt reply
recv_bulk :: String -> IO Reply
recv_bulk rest = let size = read rest :: Int
in do body <- recv_bulk_body size
return $ RBulk body
recv_bulk_body :: Int -> IO (Maybe String)
recv_bulk_body (-1) = return Nothing
recv_bulk_body size = do body <- B.hGet h (size + 2)
let reply = U.toString $ B.take size body
return $ Just reply
recv_multi :: String -> IO Reply
recv_multi rest = let cnt = read rest :: Int
in do bulks <- recv_multi_n cnt
return $ RMulti bulks
recv_multi_n :: Int -> IO (Maybe [Reply])
recv_multi_n (-1) = return Nothing
recv_multi_n 0 = return $ Just []
recv_multi_n n = do this <- recv r
tail <- fromJust `fmap` recv_multi_n (n-1)
return $ Just (this : tail)
{- ============ Just commands ============= -}
-- | ping - pong
--
-- RPong returned if no errors happends
ping :: Redis -> IO Reply
ping r = sendCommand r (CInline "PING") >> recv r
-- | Password authentication
--
-- ROk returned
auth :: Redis
-> String -- ^ password
-> IO Reply
auth r pwd = sendCommand r (CMInline ["AUTH", pwd] ) >> recv r
-- | Quit and close connection
quit :: Redis -> IO ()
quit r = sendCommand r (CInline "QUIT") >> disconnect r
-- | Stop all the clients, save the DB, then quit the server
shutdown :: Redis -> IO Reply
shutdown r = sendCommand r (CInline "SHUTDOWN") >> recv r
-- | Begin the multi-exec block
--
-- ROk returned
multi :: Redis -> IO Reply
multi r = sendCommand r (CInline "MULTI") >> recv r
-- | Execute queued commands
--
-- RMulti returned - replys for all executed commands
exec :: Redis -> IO Reply
exec r = sendCommand r (CInline "EXEC") >> recv r
-- | Run commands within multi-exec block
--
-- RMulti returned - replys for all executed commands
run_multi :: Redis
-> [IO Reply] -- ^ IO actions to run
-> IO Reply
run_multi r cs = let cs' = map (>>= noError) cs
in do multi r
sequence_ cs'
exec r
-- | Test if the key exists
--
-- (RInt 1) returned if the key exists and (RInt 0) otherwise
exists :: Redis
-> String -- ^ target key
-> IO Reply
exists r key = sendCommand r (CMBulk ["EXISTS", key]) >> recv r
-- | Remove the key
--
-- (RInt 0) returned if no keys were removed or (RInt n) with removed keys count
del :: Redis
-> String -- ^ target key
-> IO Reply
del r key = sendCommand r (CMBulk ["DEL", key]) >> recv r
-- | Return the type of the value stored at key in form of a string
--
-- RInline with one of "none", "string", "list", "set", "zset" returned
getType :: Redis
-> String -- ^ target key
-> IO Reply
getType r key = sendCommand r (CMBulk ["TYPE", key]) >> recv r
-- | Returns all the keys matching the glob-style pattern as space separated strings
--
-- RBulk returned
keys :: Redis
-> String -- ^ target key
-> IO Reply
keys r pattern = sendCommand r (CMInline ["KEYS", pattern]) >> recv r
-- | Return random key name
--
-- RInline returned
randomKey :: Redis -> IO Reply
randomKey r = sendCommand r (CInline "RANDOMKEY") >> recv r
-- | Rename the key. If key with that name exists it'll be overwritten.
--
-- ROk returned
rename :: Redis
-> String -- ^ source key
-> String -- ^ destination key
-> IO Reply
rename r from to = sendCommand r (CMBulk ["RENAME", from, to]) >> recv r
-- | Rename the key if no keys with destination name exists.
--
-- (RInt 1) returned if key was renamed and (RInt 0) otherwise
renameNx :: Redis
-> String -- ^ source key
-> String -- ^ destination key
-> IO Reply
renameNx r from to = sendCommand r (CMBulk ["RENAMENX", from, to]) >> recv r
-- | Get the number of keys in the currently selected database
--
-- RInt returned
dbsize :: Redis -> IO Reply
dbsize r = sendCommand r (CInline "DBSIZE") >> recv r
-- | Set an expiration timeout in seconds on the specified key.
--
-- For more information see <http://code.google.com/p/redis/wiki/ExpireCommand>
--
-- (RInt 1) returned if timeout was set and (RInt 0) otherwise
expire :: Redis
-> String -- ^ target key
-> Int -- ^ timeout in seconds
-> IO Reply
expire r key seconds = sendCommand r (CMBulk ["EXPIRE", key, show seconds]) >> recv r
-- | Set an expiration time in form of UNIX timestamp on the specified key
--
-- For more information see <http://code.google.com/p/redis/wiki/ExpireCommand>
--
-- (RInt 1) returned if timeout was set and (RInt 0) otherwise
expireAt :: Redis
-> String -- ^ target key
-> Int -- ^ timeout in seconds
-> IO Reply
expireAt r key timestamp = sendCommand r (CMBulk ["EXPIRE", key, show timestamp]) >> recv r
-- | Return the remining time to live of the key or -1 if key has no
-- associated timeout
--
-- RInt returned
ttl :: Redis
-> String -- ^ target key
-> IO Reply
ttl r key = sendCommand r (CMBulk ["TTL", key]) >> recv r
-- | Select the DB with the specified zero-based numeric index
--
-- ROk returned
select :: Redis
-> Int -- ^ database number
-> IO Reply
select r db = sendCommand r (CMInline ["SELECT", show db]) >> recv r
-- | Move the specified key from the currently selected DB to the
-- specified destination DB. If such a key is already exists in the
-- target DB no data modification performed.
--
-- (RInt 1) returned if the key was moved and (RInt 0) otherwise
move :: Redis
-> String -- ^ target key
-> Int -- ^ destination database number
-> IO Reply
move r key db = sendCommand r (CMBulk ["MOVE", key, show db]) >> recv r
-- | Delete all the keys of the currently selected DB
--
-- ROk returned
flushDb :: Redis -> IO Reply
flushDb r = sendCommand r (CInline "FLUSHDB") >> recv r
-- | Delete all the keys of all the existing databases
--
-- ROk returned
flushAll :: Redis -> IO Reply
flushAll r = sendCommand r (CInline "FLUSHALL") >> recv r
-- | Returns different information and statistics about the server
--
-- for more information see <http://code.google.com/p/redis/wiki/InfoCommand>
--
-- RBulk returned
info :: Redis -> IO Reply
info r = sendCommand r (CInline "INFO") >> recv r
-- | Set the string value as value of the key
--
-- ROk returned
set :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
set r key val = sendCommand r (CMBulk ["SET", key, val]) >> recv r
-- | Set the key value if key does not exists
--
-- (RInt 1) returned if key was set and (RInt 0) otherwise
setNx :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
setNx r key val = sendCommand r (CMBulk ["SETNX", key, val]) >> recv r
-- | Atomically set multiple keys
--
-- ROk returned
mSet :: Redis
-> [(String, String)] -- ^ (key, value) pairs
-> IO Reply
mSet r ks = let interlace' [] ls = ls
interlace' ((a, b):rest) ls = interlace' rest (a:b:ls)
interlace ls = interlace' ls []
in sendCommand r (CMBulk ("MSET" : interlace ks)) >> recv r
-- | Atomically set multiple keys if none of them exists.
--
-- (RInt 1) returned if all keys was set and (RInt 0) otherwise
mSetNx :: Redis
-> [(String, String)] -- ^ (key, value) pairs
-> IO Reply
mSetNx r ks = let interlace' [] ls = ls
interlace' ((a, b):rest) ls = interlace' rest (a:b:ls)
interlace ls = interlace' ls []
in sendCommand r (CMBulk ("MSETNX" : interlace ks)) >> recv r
-- | Get the value of the specified key.
--
-- RBulk returned
get :: Redis
-> String -- ^ target key
-> IO Reply
get r key = sendCommand r (CMBulk ["GET", key]) >> recv r
-- | Atomically set this value and return the old value
--
-- RBulk returned
getSet :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
getSet r key val = sendCommand r (CMBulk ["GETSET", key, val]) >> recv r
-- | Get the values of all specified keys
--
-- RMulti filled with RBulk replys returned
mGet :: Redis
-> [String] -- ^ target keys
-> IO Reply
mGet r keys = sendCommand r (CMBulk ("MGET" : keys)) >> recv r
-- | Increment the key value by one
--
-- RInt returned with new key value
incr :: Redis
-> String -- ^ target key
-> IO Reply
incr r key = sendCommand r (CMBulk ["INCR", key]) >> recv r
-- | Increment the key value by N
--
-- RInt returned with new key value
incrBy :: Redis
-> String -- ^ target key
-> Int -- ^ increment
-> IO Reply
incrBy r key n = sendCommand r (CMBulk ["INCRBY", key, show n]) >> recv r
-- | Decrement the key value by one
--
-- RInt returned with new key value
decr :: Redis
-> String -- ^ target key
-> IO Reply
decr r key = sendCommand r (CMBulk ["DECR", key]) >> recv r
-- | Decrement the key value by N
--
-- RInt returned with new key value
decrBy :: Redis
-> String -- ^ target key
-> Int -- ^ decrement
-> IO Reply
decrBy r key n = sendCommand r (CMBulk ["DECRBY", key, show n]) >> recv r
-- | Append string to the string-typed key
--
-- RInt returned - the length of resulting string
append :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
append r key str = sendCommand r (CMBulk ["APPEND", key, str]) >> recv r
-- | Add string value to the head of the list-type key
--
-- ROk returned or RError if key is not a list
rpush :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
rpush r key val = sendCommand r (CMBulk ["RPUSH", key, val]) >> recv r
-- | Add string value to the tail of the list-type key
--
-- ROk returned or RError if key is not a list
lpush :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
lpush r key val = sendCommand r (CMBulk ["LPUSH", key, val]) >> recv r
-- | Return lenght of the list. Note that for not-existing keys it
-- returns zero length.
--
-- RInt returned or RError if key is not a list
llen :: Redis
-> String -- ^ target key
-> IO Reply
llen r key = sendCommand r (CMBulk ["LLEN", key]) >> recv r
-- | Return the specified range of list elements. List indexed from 0
-- to (llen - 1). lrange returns slice including \"from\" and \"to\"
-- elements, eg. lrange 0 2 will return the first three elements of
-- the list.
--
-- Parameters \"from\" and \"to\" may also be negative. If so it will counts as
-- offset from end ot the list. eg. -1 - is the last element of the
-- list, -2 - is the second from the end and so on.
--
-- RMulti filled with RBulk returned
lrange :: Redis
-> String -- ^ traget key
-> (Int, Int) -- ^ (from, to) pair
-> IO Reply
lrange r key (from, to) = sendCommand r (CMBulk ["LRANGE", key, show from, show to]) >> recv r
-- | Trim list so that it will contain only the specified range of elements.
--
-- ROk returned
ltrim :: Redis
-> String -- ^ target key
-> (Int, Int) -- ^ (from, to) pair
-> IO Reply
ltrim r key (from, to) = sendCommand r (CMBulk ["LTRIM", key, show from, show to]) >> recv r
-- | Return the specified element of the list by its index
--
-- RBulk returned
lindex :: Redis
-> String -- ^ target key
-> Int -- ^ index
-> IO Reply
lindex r key index = sendCommand r (CMBulk ["LINDEX", key, show index]) >> recv r
-- | Set the list's value indexed by an /index/ to the new value
--
-- ROk returned if element was set and RError if index is out of
-- range or key is not a list
lset :: Redis -> String -> Int -> String -> IO Reply
lset r key index val = sendCommand r (CMBulk ["LSET", key, show index, val]) >> recv r
-- | Remove the first /count/ occurrences of the /value/ element from the list
--
-- RInt returned - the number of elements removed
lrem :: Redis
-> String -- ^ target key
-> Int -- ^ occurrences
-> String -- ^ value
-> IO Reply
lrem r key count value = sendCommand r (CMBulk ["LREM", key, show count, value]) >> recv r
-- | Atomically return and remove the first element of the list
--
-- RBulk returned
lpop :: Redis
-> String -- ^ target key
-> IO Reply
lpop r key = sendCommand r (CMBulk ["LPOP", key]) >> recv r
-- | Atomically return and remove the last element of the list
--
-- RBulk returned
rpop :: Redis
-> String -- ^ target key
-> IO Reply
rpop r key = sendCommand r (CMBulk ["RPOP", key]) >> recv r
-- | Atomically return and remove the last (tail) element of the
-- source list, and push the element as the first (head) element of
-- the destination list
--
-- RBulk returned
rpoplpush :: Redis
-> String -- ^ source key
-> String -- ^ destination key
-> IO Reply
rpoplpush r src dst = sendCommand r (CMBulk ["RPOPLPUSH", src, dst]) >> recv r
-- | Blocking lpop
--
-- For more information see <http://code.google.com/p/redis/wiki/BlpopCommand>
--
-- RMulti returned filled with key name and popped value
blpop :: Redis
-> [String] -- ^ keys list
-> Int -- ^ timeout
-> IO Reply
blpop r keys timeout = sendCommand r (CMBulk (("BLPOP" : keys) ++ [show timeout])) >> recv r
-- | Blocking rpop
--
-- For more information see <http://code.google.com/p/redis/wiki/BlpopCommand>
--
-- RMulti returned filled with key name and popped value
brpop :: Redis
-> [String] -- ^ keys list
-> Int -- ^ timeout
-> IO Reply
brpop r keys timeout = sendCommand r (CMBulk (("BRPOP" : keys) ++ [show timeout])) >> recv r
-- | Add the specified member to the set value stored at key
--
-- (RInt 1) returned if element was added and (RInt 0) if element was
-- already a member of the set
sadd :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
sadd r key val = sendCommand r (CMBulk ["SADD", key, val]) >> recv r
-- | Remove the specified member from the set value stored at key
--
-- (RInt 1) returned if element was removed and (RInt 0) if element
-- is not a member of the set
srem :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
srem r key val = sendCommand r (CMBulk ["SREM", key, val]) >> recv r
-- | Remove a random element from a Set returning it as return value
--
-- RBulk returned
spop :: Redis
-> String -- ^ target key
-> IO Reply
spop r key = sendCommand r (CMBulk ["SPOP", key]) >> recv r
-- | Move the specifided member from one set to another
--
-- (RInt 1) returned if element was moved and (RInt 0) if element
-- is not a member of the source set
smove :: Redis
-> String -- ^ source key
-> String -- ^ destination key
-> String -- ^ value
-> IO Reply
smove r src dst member = sendCommand r (CMBulk ["SMOVE", src, dst, member]) >> recv r
-- | Return the number of elements of the set. If key doesn't exists 0
-- returned.
--
-- RInt returned
scard :: Redis
-> String -- ^ target key
-> IO Reply
scard r key = sendCommand r (CMBulk ["SCARD", key]) >> recv r
-- | Test if element is member of the set. If key doesn't exists 0
-- returned.
--
-- (RInt 1) returned if element is member of the set and (RInt 0) otherwise
sismember :: Redis
-> String -- ^ target key
-> IO Reply
sismember r key = sendCommand r (CMBulk ["SISMEMBER", key]) >> recv r
-- | Return all the members (elements) of the set
--
-- RMulti filled with RBulk returned
smembers :: Redis
-> String -- ^ target key
-> IO Reply
smembers r key = sendCommand r (CMBulk ["SMEMBERS", key]) >> recv r
-- | Return a random element from a set
--
-- RBulk returned
srandmember :: Redis
-> String -- ^ target key
-> IO Reply
srandmember r key = sendCommand r (CMBulk ["SRANDMEMBER", key]) >> recv r
-- | Return the members of a set resulting from the intersection of
-- all the specifided sets
--
-- RMulti filled with RBulk returned
sinter :: Redis
-> [String] -- ^ keys list
-> IO Reply
sinter r keys = sendCommand r (CMBulk ("SINTER" : keys)) >> recv r
-- | The same as 'sinter' but instead of being returned the resulting set
-- is stored
--
-- ROk returned
sinterStore :: Redis
-> String -- ^ where to store resulting set
-> [String] -- ^ sets list
-> IO Reply
sinterStore r dst keys = sendCommand r (CMBulk ("SINTERSTORE" : dst : keys)) >> recv r
-- | Return the members of a set resulting from the union of all the
-- specifided sets
--
-- RMulti filled with RBulk returned
sunion :: Redis
-> [String] -- ^ keys list
-> IO Reply
sunion r keys = sendCommand r (CMBulk ("SUNION" : keys)) >> recv r
-- | The same as 'sunion' but instead of being returned the resulting set
-- is stored
--
-- ROk returned
sunionStore :: Redis
-> String -- ^ where to store resulting set
-> [String] -- ^ sets list
-> IO Reply
sunionStore r dst keys = sendCommand r (CMBulk ("SUNIONSTORE" : dst : keys)) >> recv r
-- | Return the members of a set resulting from the difference between
-- the first set provided and all the successive sets
--
-- RMulti filled with RBulk returned
sdiff :: Redis
-> [String] -- ^ keys list
-> IO Reply
sdiff r keys = sendCommand r (CMBulk ("SDIFF" : keys)) >> recv r
-- | The same as 'sdiff' but instead of being returned the resulting
-- set is stored
--
-- ROk returned
sdiffStore :: Redis
-> String -- ^ where to store resulting set
-> [String] -- ^ sets list
-> IO Reply
sdiffStore r dst keys = sendCommand r (CMBulk ("SDIFFSTORE" : dst : keys)) >> recv r
-- | Add the specified member having the specifeid score to the sorted
-- set
--
-- (RInt 1) returned if new element was added and (RInt 0) if that
-- element was already a member of the sortet set and the score was
-- updated
zadd :: Redis
-> String -- ^ target key
-> Double -- ^ score
-> String -- ^ value
-> IO Reply
zadd r key score member = sendCommand r (CMBulk ["ZADD", key, show score, member]) >> recv r
-- | Remove the specified member from the sorted set
--
-- (RInt 1) returned if element was removed and (RInt 0) if element
-- was not a member of the sorted set
zrem :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
zrem r key member = sendCommand r (CMBulk ["ZREM", key, member]) >> recv r
-- | If /member/ already in the sorted set adds the /increment/ to its
-- score and updates the position of the element in the sorted set
-- accordingly. If member does not exist in the sorted set it is added
-- with increment as score (that is, like if the previous score was
-- virtually zero). The new score of the member is returned.
--
-- RBulk returned
zincrBy :: Redis
-> String -- ^ target key
-> Double -- ^ increment
-> String -- ^ value
-> IO Reply
zincrBy r key increment member = sendCommand r (CMBulk ["ZINCRBY", key, show increment, member]) >> recv r
-- | Return the specified elements of the sorted set. Start and end
-- are zero-based indexes. WITHSCORES paramenter indicates if it's
-- needed to return elements with its scores or not. If WITHSCORES is
-- True then the resulting list will be composed of value1, score1,
-- value2, score2 and so on.
--
-- RMulti filled with RBulk returned
zrange :: Redis
-> String -- ^ target key
-> (Int, Int) -- ^ (from, to) pair
-> Bool -- ^ withscores option
-> IO Reply
zrange r key limit withscores = let cmd' = ["ZRANGE", key, show $ fst limit, show $ snd limit]
cmd | withscores = cmd' ++ ["WITHSCORES"]
| otherwise = cmd'
in sendCommand r (CMBulk cmd) >> recv r
-- | Return the specified elements of the sorted set at the specified
-- key. The elements are considered sorted from the highest to the
-- lowerest score
--
-- RMulti filled with RBulk returned
zrevrange :: Redis
-> String -- ^ target key
-> (Int, Int) -- ^ (from, to) pair
-> Bool -- ^ withscores option
-> IO Reply
zrevrange r key limit withscores = let cmd' = ["ZREVRANGE", key, show $ fst limit, show $ snd limit]
cmd | withscores = cmd' ++ ["WITHSCORES"]
| otherwise = cmd'
in sendCommand r (CMBulk cmd) >> recv r
-- | Interval representation
data Interval a = Closed a a -- ^ closed interval [a, b]
| Open a a -- ^ open interval (a, b)
| LeftOpen a a -- ^ left-open interval (a, b]
| RightOpen a a -- ^ right-open interval [a, b)
deriving Show
-- | Class for conversion value to 'Interval'
--
-- Definied instances is:
--
-- * the Interval itself
--
-- * pair (a,b) for open interval
--
-- * two-member list [a, b] for closed interval (throws runtime error if the list length is different)
--
class IsInterval i a | i -> a where
toInterval :: i -> Interval a
-- | Trivial IsInterval instance
instance IsInterval (Interval a) a where
toInterval = id
-- | Pair (a, b) converted to open interval
instance IsInterval (a, a) a where
toInterval (a, b) = Open a b
-- | Two-element list [a, b] converted to closed interval. No static
-- checking of list length performed.
instance IsInterval [a] a where
toInterval (a : b : []) = Closed a b
toInterval _ = error "Interval cast error"
from (Closed a _) = show a
from (Open a _) = '(' : (show a)
from (LeftOpen a _) = '(' : (show a)
from (RightOpen a _) = show a
to (Closed _ a) = show a
to (Open _ a) = '(' : (show a)
to (LeftOpen _ a) = show a
to (RightOpen _ a) = '(' : (show a)
-- | Return the all the elements in the sorted set with a score that
-- lays within a given interval
--
-- RMulti filled with RBulk returned
zrangebyscore :: IsInterval i Double =>
Redis
-> String -- ^ target key
-> i -- ^ scores interval
-> Bool -- ^ withscores option
-> IO Reply
zrangebyscore r key i withscores = let cmd' = i' `seq` ["ZRANGEBYSCORE", key, from i', to i']
cmd | withscores = cmd' ++ ["WITHSCORES"]
| otherwise = cmd'
i' = toInterval i
in cmd `seq` sendCommand r (CMBulk cmd) >> recv r
-- | Count a number of elements of the sorted set with a score that
-- lays within a given interval
--
-- RInt returned
zcount :: IsInterval i Double =>
Redis
-> String -- ^ target key
-> i -- ^ scores interval
-> IO Reply
zcount r key i = let cmd = i' `seq` ["ZCOUNT", key, from i', to i']
i' = toInterval i
in cmd `seq` sendCommand r (CMBulk cmd) >> recv r
-- | Remove all the elements in the sorted set with a score that lays
-- within a given interval
--
-- RInt returned - the number of elements removed
zremrangebyscore :: Redis
-> String -- ^ target key
-> (Double, Double) -- ^ (from, to) pair. zremrangebyscore
-- currently doesn't supports
-- open intervals
-> IO Reply
zremrangebyscore r key (from, to) = sendCommand r (CMBulk ["ZREMRANGEBYSCORE", key, show from, show to]) >> recv r
-- | Return the sorted set cardinality (number of elements)
--
-- RInt returned
zcard :: Redis
-> String -- ^ target key
-> IO Reply
zcard r key = sendCommand r (CMBulk ["ZCARD", key]) >> recv r
-- | Return the score of the specified element of the sorted set
--
-- RBulk returned
zscore :: Redis
-> String -- ^ target key
-> String -- ^ value
-> IO Reply
zscore r key member = sendCommand r (CMBulk ["ZSCORE", key, member]) >> recv r
-- | Options data type for the 'sort' command
data SortOptions = SortOptions { desc :: Bool, -- ^ sort with descending order
limit :: (Int, Int), -- ^ return (from, to) elements
alpha :: Bool, -- ^ sort alphabetically
sort_by :: String, -- ^ sort by value from this key
get_obj :: [String], -- ^ return this keys values
store :: String -- ^ store result to this key
}
-- | Default options for the 'sort' command
sortDefaults :: SortOptions
sortDefaults = SortOptions { desc = False,
limit = takeAll,
alpha = False,
sort_by = "",
get_obj = [],
store = "" }
-- | Sort the elements contained in the List, Set, or Sorted Set
--
-- for more information see <http://code.google.com/p/redis/wiki/SortCommand>
--
-- RMulti filled with RBulk returned
sort :: Redis
-> String -- ^ target key
-> SortOptions -- ^ options
-> IO Reply
sort r key opt = let opt_s = buildOptions opt
buildOptions opt = let desc_s
| desc opt = ["DESC"]
| otherwise = []
limit_s
| (limit opt) == (0, 0) = []
| otherwise = ["LIMIT", (show $ fst $ limit opt), (show $ snd $ limit opt)]
alpha_s
| alpha opt = ["ALPHA"]
| otherwise = []
sort_by_s
| null $ sort_by opt = []
| otherwise = ["BY",(sort_by opt)]
get_obj_s
| null $ get_obj opt = []
| otherwise = "GET" : get_obj opt
store_s
| null $ store opt = []
| otherwise = ["STORE", store opt]
in concat [sort_by_s, limit_s, get_obj_s, desc_s, alpha_s, store_s]
in sendCommand r (CMBulk ("SORT" : key : opt_s)) >> recv r
-- | Shortcut for the 'sort' with some 'get_obj' and constant
-- 'sort_by' options
--
-- RMulti filled with RBulk returned
listRelated :: Redis
-> String -- ^ target key
-> String -- ^ key returned
-> (Int, Int) -- ^ range
-> IO Reply
listRelated r related key l = let opts = sortDefaults { sort_by = "x",
get_obj = [related],
limit = l }
in sort r key opts
-- | Save the whole dataset on disk
--
-- ROk returned
save :: Redis -> IO Reply
save r = sendCommand r (CInline "SAVE") >> recv r
-- | Save the DB in background
--
-- ROk returned
bgsave :: Redis -> IO Reply
bgsave r = sendCommand r (CInline "BGSAVE") >> recv r
-- | Return the UNIX TIME of the last DB save executed with success
--
-- RInt returned
lastsave :: Redis -> IO Reply
lastsave r = sendCommand r (CInline "LASTSAVE") >> recv r
-- | Rewrites the Append Only File in background
--
-- ROk returned
bgrewriteaof :: Redis -> IO Reply
bgrewriteaof r = sendCommand r (CInline "BGREWRITEAOF") >> recv r