module Database.Redis.Redis (
Redis,
Reply(..),
Message(..),
Interval(..),
IsInterval(..),
SortOptions(..),
Aggregate(..),
sortDefaults,
fromRInline, fromRBulk, fromRMulti, fromRMultiBulk,
fromRInt, fromROk, noError, parseMessage, takeAll,
localhost, defaultPort,
connect, disconnect, isConnected,
getServer, getDatabase,
ping, auth, quit, shutdown,
multi, exec, discard, run_multi,
watch, unwatch, run_cas, exists,
del, getType, keys, randomKey, rename,
renameNx, dbsize, expire, expireAt,
ttl, select, move, flushDb,
flushAll, info,
set, setNx, setEx, mSet, mSetNx,
get, getSet, mGet,
incr, incrBy, decr,
decrBy, append, substr,
rpush, lpush, llen, lrange, ltrim,
lindex, lset, lrem, lpop, rpop,
rpoplpush, blpop, brpop,
sadd, srem, spop, smove, scard, sismember,
smembers, srandmember, sinter, sinterStore,
sunion, sunionStore, sdiff, sdiffStore,
zadd, zrem, zincrBy, zrange,
zrevrange, zrangebyscore, zcount,
zremrangebyscore, zcard, zscore,
zrank, zrevrank, zremrangebyrank,
zunion, zinter, zunionStore, zinterStore,
hset, hget, hdel, hmset, hmget,
hincrby, hexists, hlen,
hkeys, hvals, hgetall,
sort, listRelated,
subscribed, subscribe, unsubscribe,
psubscribe, punsubscribe, publish,
listen,
save, bgsave, lastsave, bgrewriteaof
)
where
import Control.Concurrent.MVar
import Data.IORef
import qualified Network.Socket as S
import qualified System.IO as IO
import qualified Data.ByteString as B
import Data.ByteString (ByteString)
import Data.Maybe (fromJust, isNothing)
import Control.Monad (when)
import Database.Redis.ByteStringClass
import Database.Redis.Internal
defaultPort :: String
defaultPort = "6379"
localhost :: String
localhost = "localhost"
takeAll :: (Int, Int)
takeAll = (0, 1)
fromRInline :: (Monad m, BS s) => Reply s -> m s
fromRInline reply = case reply of
RError msg -> error msg
RInline s -> return s
_ -> error $ "wrong reply, RInline expected: " ++ (show reply)
fromRBulk :: (Monad m, BS s) => Reply s -> m (Maybe s)
fromRBulk reply = case reply of
RError msg -> error msg
RBulk s -> return s
_ -> error $ "wrong reply, RBulk expected: " ++ (show reply)
fromRMulti :: (Monad m, BS s) => Reply s -> m (Maybe [Reply s])
fromRMulti reply = case reply of
RError msg -> error msg
RMulti ss -> return ss
_ -> error $ "wrong reply, RMulti expected: " ++ (show reply)
fromRMultiBulk :: (Monad m, BS s) => Reply s -> m (Maybe [Maybe s])
fromRMultiBulk reply = fromRMulti reply >>= return . (>>= sequence . map fromRBulk)
fromRInt :: (Monad m, BS s) => Reply s -> m Int
fromRInt reply = case reply of
RError msg -> error msg
RInt n -> return n
_ -> error $ "wrong reply, RInt expected: " ++ (show reply)
fromROk :: (Monad m, BS s) => Reply s -> m ()
fromROk reply = case reply of
RError msg -> error msg
ROk -> return ()
_ -> error $ "wrong reply, ROk expected: " ++ (show reply)
noError :: (Monad m, BS s) => Reply s -> m ()
noError reply = case reply of
RError msg -> error msg
_ -> return ()
parseMessage :: (Monad m, BS s) => Reply ByteString -> m (Message s)
parseMessage reply = do rm <- fromRMulti reply
when (isNothing rm) $ error $ "error parsing message: " ++ (show reply)
let rm' = fromJust rm
mtype <- fromRBulk $ head rm'
when (isNothing mtype) $ error $ "error parsing message: " ++ (show reply)
return $ case fromJust mtype of
"subscribe" -> mksub MSubscribe $ tail rm'
"unsubscribe" -> mksub MUnsubscribe $ tail rm'
"psubscribe" -> mksub MPSubscribe $ tail rm'
"punsubscribe" -> mksub MPUnsubscribe $ tail rm'
"message" -> mkmsg $ tail rm'
"pmessage" -> mkpmsg $ tail rm'
where mksub f [RBulk (Just k), RInt n] = f (fromBS k) n
mkmsg [RBulk (Just k), RBulk (Just msg)] = MMessage (fromBS k) (fromBS msg)
mkpmsg [RBulk (Just p), RBulk (Just c), RBulk (Just msg)] = MPMessage (fromBS p) (fromBS c) (fromBS msg)
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)
lcnt <- newMVar Nothing
l <- newMVar ()
st <- newIORef $ RedisState (hostname, port) 0 h 0
return $ Redis lcnt l st
disconnect :: Redis -> IO ()
disconnect = withState' (IO.hClose . handle)
isConnected :: Redis -> IO Bool
isConnected = withState' (IO.hIsOpen . handle)
getServer :: Redis -> IO (String, String)
getServer = withState' (return . server)
getDatabase :: Redis -> IO Int
getDatabase = withState' (return . database)
ping :: Redis -> IO (Reply ())
ping = withState' (\rs -> sendCommand rs (CInline "PING") >> recv rs)
auth :: BS s =>
Redis
-> s
-> IO (Reply ())
auth r pwd = withState r (\rs -> sendCommand rs (CMInline ["AUTH", toBS pwd] ) >> recv rs)
quit :: Redis -> IO ()
quit r = withState r (sendCommand' (CInline "QUIT")) >> disconnect r
shutdown :: Redis -> IO ()
shutdown r = withState r (sendCommand' (CInline "SHUTDOWN")) >> disconnect r
multi :: Redis -> IO (Reply ())
multi = withState' (\rs -> sendCommand rs (CInline "MULTI") >> recv rs)
exec :: BS s => Redis -> IO (Reply s)
exec = withState' (\rs -> sendCommand rs (CInline "EXEC") >> recv rs)
discard :: Redis -> IO (Reply ())
discard = withState' (\rs -> sendCommand rs (CInline "DISCARD") >> recv rs)
run_multi :: (BS s) =>
Redis
-> [IO (Reply ())]
-> IO (Reply s)
run_multi r cs = let cs' = map (>>= noError) cs
in withState' (\rs -> do sendCommand rs (CInline "MULTI")
(recv rs :: IO (Reply ())) >>= fromROk
sequence_ cs'
sendCommand rs (CInline "EXEC")
recv rs) r
watch :: BS s =>
Redis
-> [s]
-> IO (Reply ())
watch r keys = withState r (\rs -> sendCommand rs (CMBulk ("WATCH" : map toBS keys)) >> recv rs)
unwatch :: Redis -> IO (Reply ())
unwatch = withState' (\rs -> sendCommand rs (CInline "UNWATCH") >> recv rs)
run_cas :: (BS s1, BS s2) =>
Redis
-> [s1]
-> IO (Reply s2)
-> IO (Reply s2)
run_cas r keys cs = let keys' = map toBS keys
in withState r (\rs -> do sendCommand rs (CMBulk ("WATCH" : keys'))
(recv rs :: IO (Reply ())) >>= fromROk
res <- cs
sendCommand rs (CInline "UNWATCH")
(recv rs :: IO (Reply ())) >>= fromROk
return res)
exists :: BS s =>
Redis
-> s
-> IO (Reply Int)
exists r key = withState r (\rs -> sendCommand rs (CMBulk ["EXISTS", toBS key]) >> recv rs)
del :: BS s =>
Redis
-> s
-> IO (Reply Int)
del r key = withState r (\rs -> sendCommand rs (CMBulk ["DEL", toBS key]) >> recv rs)
getType :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
getType r key = withState r (\rs -> sendCommand rs (CMBulk ["TYPE", toBS key]) >> recv rs)
keys :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
keys r pattern = withState r (\rs -> sendCommand rs (CMInline ["KEYS", toBS pattern]) >> recv rs)
randomKey :: BS s => Redis -> IO (Reply s)
randomKey r = withState r (\rs -> sendCommand rs (CInline "RANDOMKEY") >> recv rs)
rename :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply ())
rename r from to = withState r (\rs -> sendCommand rs (CMBulk ["RENAME", toBS from, toBS to]) >> recv rs)
renameNx :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
renameNx r from to = withState r (\rs -> sendCommand rs (CMBulk ["RENAMENX", toBS from, toBS to]) >> recv rs)
dbsize :: Redis -> IO (Reply Int)
dbsize r = withState r (\rs -> sendCommand rs (CInline "DBSIZE") >> recv rs)
expire :: BS s =>
Redis
-> s
-> Int
-> IO (Reply Int)
expire r key seconds = withState r (\rs -> sendCommand rs (CMBulk ["EXPIRE", toBS key, toBS seconds]) >> recv rs)
expireAt :: BS s =>
Redis
-> s
-> Int
-> IO (Reply Int)
expireAt r key timestamp = withState r (\rs -> sendCommand rs (CMBulk ["EXPIREAT", toBS key, toBS timestamp]) >> recv rs)
ttl :: BS s =>
Redis
-> s
-> IO (Reply Int)
ttl r key = withState r (\rs -> sendCommand rs (CMBulk ["TTL", toBS key]) >> recv rs)
select :: Redis
-> Int
-> IO (Reply ())
select r db = inState r $ \rs -> do sendCommand rs (CMInline ["SELECT", toBS db])
reply <- recv rs
return (rs { database = db }, reply)
move :: BS s =>
Redis
-> s
-> Int
-> IO (Reply Int)
move r key db = withState r (\rs -> sendCommand rs (CMBulk ["MOVE", toBS key, toBS db]) >> recv rs)
flushDb :: Redis -> IO (Reply ())
flushDb r = withState r (\rs -> sendCommand rs (CInline "FLUSHDB") >> recv rs)
flushAll :: Redis -> IO (Reply ())
flushAll r = withState r (\rs -> sendCommand rs (CInline "FLUSHALL") >> recv rs)
info :: BS s => Redis -> IO (Reply s)
info r = withState r (\rs -> sendCommand rs (CInline "INFO") >> recv rs)
set :: (BS s1, BS s2) => Redis
-> s1
-> s2
-> IO (Reply ())
set r key val = withState r (\rs -> sendCommand rs (CMBulk ["SET", toBS key, toBS val]) >> recv rs)
setNx :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
setNx r key val = withState r (\rs -> sendCommand rs (CMBulk ["SETNX", toBS key, toBS val]) >> recv rs)
setEx :: (BS s1, BS s2) =>
Redis
-> s1
-> Int
-> s2
-> IO (Reply ())
setEx r key seconds val = withState r (\rs -> sendCommand rs (CMBulk ["SETEX", toBS key, toBS seconds, toBS val]) >> recv rs)
mSet :: (BS s1, BS s2) =>
Redis
-> [(s1, s2)]
-> IO (Reply ())
mSet r ks = let interlace' [] ls = ls
interlace' ((a, b):rest) ls = interlace' rest (toBS a : toBS b : ls)
interlace ls = interlace' ls []
in withState r (\rs -> sendCommand rs (CMBulk ("MSET" : interlace ks)) >> recv rs)
mSetNx :: (BS s1, BS s2) =>
Redis
-> [(s1, s2)]
-> IO (Reply Int)
mSetNx r ks = let interlace' [] ls = ls
interlace' ((a, b):rest) ls = interlace' rest (toBS a : toBS b : ls)
interlace ls = interlace' ls []
in withState r (\rs -> sendCommand rs (CMBulk ("MSETNX" : interlace ks)) >> recv rs)
get :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
get r key = withState r (\rs -> sendCommand rs (CMBulk ["GET", toBS key]) >> recv rs)
getSet :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> s2
-> IO (Reply s3)
getSet r key val = withState r (\rs -> sendCommand rs (CMBulk ["GETSET", toBS key, toBS val]) >> recv rs)
mGet :: (BS s1, BS s2) =>
Redis
-> [s1]
-> IO (Reply s2)
mGet r keys = withState r (\rs -> sendCommand rs (CMBulk ("MGET" : map toBS keys)) >> recv rs)
incr :: BS s =>
Redis
-> s
-> IO (Reply Int)
incr r key = withState r (\rs -> sendCommand rs (CMBulk ["INCR", toBS key]) >> recv rs)
incrBy :: BS s =>
Redis
-> s
-> Int
-> IO (Reply Int)
incrBy r key n = withState r (\rs -> sendCommand rs (CMBulk ["INCRBY", toBS key, toBS n]) >> recv rs)
decr :: BS s =>
Redis
-> s
-> IO (Reply Int)
decr r key = withState r (\rs -> sendCommand rs (CMBulk ["DECR", toBS key]) >> recv rs)
decrBy :: BS s =>
Redis
-> s
-> Int
-> IO (Reply Int)
decrBy r key n = withState r (\rs -> sendCommand rs (CMBulk ["DECRBY", toBS key, toBS n]) >> recv rs)
append :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
append r key str = withState r (\rs -> sendCommand rs (CMBulk ["APPEND", toBS key, toBS str]) >> recv rs)
substr :: (BS s1, BS s2) =>
Redis
-> s1
-> (Int, Int)
-> IO (Reply s2)
substr r key (from, to) = withState r (\rs -> sendCommand rs (CMBulk ["SUBSTR", toBS key, toBS from, toBS to]) >> recv rs)
rpush :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
rpush r key val = withState r (\rs -> sendCommand rs (CMBulk ["RPUSH", toBS key, toBS val]) >> recv rs)
lpush :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
lpush r key val = withState r (\rs -> sendCommand rs (CMBulk ["LPUSH", toBS key, toBS val]) >> recv rs)
llen :: BS s =>
Redis
-> s
-> IO (Reply Int)
llen r key = withState r (\rs -> sendCommand rs (CMBulk ["LLEN", toBS key]) >> recv rs)
lrange :: (BS s1, BS s2) =>
Redis
-> s1
-> (Int, Int)
-> IO (Reply s2)
lrange r key (from, to) = withState r (\rs -> sendCommand rs (CMBulk ["LRANGE", toBS key, toBS from, toBS to]) >> recv rs)
ltrim :: BS s =>
Redis
-> s
-> (Int, Int)
-> IO (Reply ())
ltrim r key (from, to) = withState r (\rs -> sendCommand rs (CMBulk ["LTRIM", toBS key, toBS from, toBS to]) >> recv rs)
lindex :: (BS s1, BS s2) =>
Redis
-> s1
-> Int
-> IO (Reply s2)
lindex r key index = withState r (\rs -> sendCommand rs (CMBulk ["LINDEX", toBS key, toBS index]) >> recv rs)
lset :: (BS s1, BS s2) =>
Redis
-> s1
-> Int
-> s2
-> IO (Reply ())
lset r key index val = withState r (\rs -> sendCommand rs (CMBulk ["LSET", toBS key, toBS index, toBS val]) >> recv rs)
lrem :: (BS s1, BS s2) =>
Redis
-> s1
-> Int
-> s2
-> IO (Reply Int)
lrem r key count value = withState r (\rs -> sendCommand rs (CMBulk ["LREM", toBS key, toBS count, toBS value]) >> recv rs)
lpop :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
lpop r key = withState r (\rs -> sendCommand rs (CMBulk ["LPOP", toBS key]) >> recv rs)
rpop :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
rpop r key = withState r (\rs -> sendCommand rs (CMBulk ["RPOP", toBS key]) >> recv rs)
rpoplpush :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> s2
-> IO (Reply s3)
rpoplpush r src dst = withState r (\rs -> sendCommand rs (CMBulk ["RPOPLPUSH", toBS src, toBS dst]) >> recv rs)
blpop :: (BS s1, BS s2) =>
Redis
-> [s1]
-> Int
-> IO (Reply s2)
blpop r keys timeout = withState r (\rs -> sendCommand rs (CMBulk (("BLPOP" : map toBS keys) ++ [toBS timeout])) >> recv rs)
brpop :: (BS s1, BS s2) =>
Redis
-> [s1]
-> Int
-> IO (Reply s2)
brpop r keys timeout = withState r (\rs -> sendCommand rs (CMBulk (("BRPOP" : map toBS keys) ++ [toBS timeout])) >> recv rs)
sadd :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
sadd r key val = withState r (\rs -> sendCommand rs (CMBulk ["SADD", toBS key, toBS val]) >> recv rs)
srem :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
srem r key val = withState r (\rs -> sendCommand rs (CMBulk ["SREM", toBS key, toBS val]) >> recv rs)
spop :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
spop r key = withState r (\rs -> sendCommand rs (CMBulk ["SPOP", toBS key]) >> recv rs)
smove :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> s2
-> s3
-> IO (Reply Int)
smove r src dst member = withState r (\rs -> sendCommand rs (CMBulk ["SMOVE", toBS src, toBS dst, toBS member]) >> recv rs)
scard :: BS s =>
Redis
-> s
-> IO (Reply Int)
scard r key = withState r (\rs -> sendCommand rs (CMBulk ["SCARD", toBS key]) >> recv rs)
sismember :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
sismember r key val = withState r (\rs -> sendCommand rs (CMBulk ["SISMEMBER", toBS key, toBS val]) >> recv rs)
smembers :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
smembers r key = withState r (\rs -> sendCommand rs (CMBulk ["SMEMBERS", toBS key]) >> recv rs)
srandmember :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
srandmember r key = withState r (\rs -> sendCommand rs (CMBulk ["SRANDMEMBER", toBS key]) >> recv rs)
sinter :: (BS s1, BS s2) =>
Redis
-> [s1]
-> IO (Reply s2)
sinter r keys = withState r (\rs -> sendCommand rs (CMBulk ("SINTER" : map toBS keys)) >> recv rs)
sinterStore :: (BS s1, BS s2) =>
Redis
-> s1
-> [s2]
-> IO (Reply ())
sinterStore r dst keys = withState r (\rs -> sendCommand rs (CMBulk ("SINTERSTORE" : toBS dst : map toBS keys)) >> recv rs)
sunion :: (BS s1, BS s2) =>
Redis
-> [s1]
-> IO (Reply s2)
sunion r keys = withState r (\rs -> sendCommand rs (CMBulk ("SUNION" : map toBS keys)) >> recv rs)
sunionStore :: (BS s1, BS s2) =>
Redis
-> s1
-> [s2]
-> IO (Reply ())
sunionStore r dst keys = withState r (\rs -> sendCommand rs (CMBulk ("SUNIONSTORE" : toBS dst : map toBS keys)) >> recv rs)
sdiff :: (BS s1, BS s2) =>
Redis
-> [s1]
-> IO (Reply s2)
sdiff r keys = withState r (\rs -> sendCommand rs (CMBulk ("SDIFF" : map toBS keys)) >> recv rs)
sdiffStore :: (BS s1, BS s2) =>
Redis
-> s1
-> [s2]
-> IO (Reply ())
sdiffStore r dst keys = withState r (\rs -> sendCommand rs (CMBulk ("SDIFFSTORE" : toBS dst : map toBS keys)) >> recv rs)
zadd :: (BS s1, BS s2) =>
Redis
-> s1
-> Double
-> s2
-> IO (Reply Int)
zadd r key score member = withState r (\rs -> sendCommand rs (CMBulk ["ZADD", toBS key, toBS score, toBS member]) >> recv rs)
zrem :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
zrem r key member = withState r (\rs -> sendCommand rs (CMBulk ["ZREM", toBS key, toBS member]) >> recv rs)
zincrBy :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> Double
-> s2
-> IO (Reply s3)
zincrBy r key increment member = withState r (\rs -> sendCommand rs (CMBulk ["ZINCRBY", toBS key, toBS increment, toBS member]) >> recv rs)
zrange :: (BS s1, BS s2) =>
Redis
-> s1
-> (Int, Int)
-> Bool
-> IO (Reply s2)
zrange r key limit withscores = let cmd' = ["ZRANGE", toBS key, toBS $ fst limit, toBS $ snd limit]
cmd | withscores = cmd' ++ ["WITHSCORES"]
| otherwise = cmd'
in withState r (\rs -> sendCommand rs (CMBulk cmd) >> recv rs)
zrevrange :: (BS s1, BS s2) =>
Redis
-> s1
-> (Int, Int)
-> Bool
-> IO (Reply s2)
zrevrange r key limit withscores = let cmd' = ["ZREVRANGE", toBS key, toBS $ fst limit, toBS $ snd limit]
cmd | withscores = cmd' ++ ["WITHSCORES"]
| otherwise = cmd'
in withState r (\rs -> sendCommand rs (CMBulk cmd) >> recv rs)
data Interval a = Closed a a
| Open a a
| LeftOpen a a
| RightOpen a a
deriving Show
class IsInterval i a | i -> a where
toInterval :: i -> Interval a
instance IsInterval (Interval a) a where
toInterval = id
instance IsInterval (a, a) a where
toInterval (a, b) = Open a b
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)
zrangebyscore :: (IsInterval i Double, BS s1, BS s2) =>
Redis
-> s1
-> i
-> Bool
-> IO (Reply s2)
zrangebyscore r key i withscores = let cmd' = i' `seq` ["ZRANGEBYSCORE", toBS key, toBS (from i'), toBS (to i')]
cmd | withscores = cmd' ++ ["WITHSCORES"]
| otherwise = cmd'
i' = toInterval i
in cmd `seq` withState r (\rs -> sendCommand rs (CMBulk cmd) >> recv rs)
zcount :: (IsInterval i Double, BS s) =>
Redis
-> s
-> i
-> IO (Reply Int)
zcount r key i = let cmd = i' `seq` ["ZCOUNT", toBS key, toBS (from i'), toBS (to i')]
i' = toInterval i
in cmd `seq` withState r (\rs -> sendCommand rs (CMBulk cmd) >> recv rs)
zremrangebyscore :: BS s =>
Redis
-> s
-> (Double, Double)
-> IO (Reply Int)
zremrangebyscore r key (from, to) = withState r (\rs -> sendCommand rs (CMBulk ["ZREMRANGEBYSCORE", toBS key, toBS from, toBS to]) >> recv rs)
zcard :: BS s =>
Redis
-> s
-> IO (Reply Int)
zcard r key = withState r (\rs -> sendCommand rs (CMBulk ["ZCARD", toBS key]) >> recv rs)
zscore :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> s2
-> IO (Reply s3)
zscore r key member = withState r (\rs -> sendCommand rs (CMBulk ["ZSCORE", toBS key, toBS member]) >> recv rs)
zrank :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
zrank r key member = withState r (\rs -> sendCommand rs (CMBulk ["ZRANK", toBS key, toBS member]) >> recv rs)
zrevrank :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
zrevrank r key member = withState r (\rs -> sendCommand rs (CMBulk ["ZREVRANK", toBS key, toBS member]) >> recv rs)
zremrangebyrank :: (BS s) =>
Redis
-> s
-> (Int, Int)
-> IO (Reply Int)
zremrangebyrank r key (from, to) =
withState r (\rs -> sendCommand rs (CMBulk ["ZREMRANGEBYRANK", toBS key, toBS from, toBS to]) >> recv rs)
data Aggregate = SUM | MIN | MAX
deriving (Eq, Show)
zunionStore :: (BS s1, BS s2) =>
Redis
-> s1
-> [s2]
-> [Double]
-> Aggregate
-> IO (Reply Int)
zunionStore r dst src weights aggregate =
let src_s = toBS (length src) : map toBS src
weight_s | null weights = []
| otherwise = "WEIGHTS" : map toBS weights
aggr_s | aggregate == SUM = []
| otherwise = ["AGGREGATE", toBS (show aggregate)]
in withState r (\rs -> sendCommand rs (CMBulk (("ZUNIONSTORE" : toBS dst : src_s) ++ weight_s ++ aggr_s)) >> recv rs)
zunion :: (BS s1, BS s2) => Redis -> s1 -> [s2] -> [Double] -> Aggregate -> IO (Reply Int)
zunion = zunionStore
zinterStore :: (BS s1, BS s2) =>
Redis
-> s1
-> [s2]
-> [Double]
-> Aggregate
-> IO (Reply Int)
zinterStore r dst src weights aggregate =
let src_s = toBS (length src) : map toBS src
weight_s | null weights = []
| otherwise = "WEIGHTS" : map toBS weights
aggr_s | aggregate == SUM = []
| otherwise = ["AGGREGATE", toBS (show aggregate)]
in withState r (\rs -> sendCommand rs (CMBulk (("ZINTER" : toBS dst : src_s) ++ weight_s ++ aggr_s)) >> recv rs)
zinter :: (BS s1, BS s2) => Redis -> s1 -> [s2] -> [Double] -> Aggregate -> IO (Reply Int)
zinter = zinterStore
hset :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> s2
-> s3
-> IO (Reply Int)
hset r key field value = withState r (\rs -> sendCommand rs (CMBulk ["HSET", toBS key, toBS field, toBS value]) >> recv rs)
hget :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> s2
-> IO (Reply s3)
hget r key field = withState r (\rs -> sendCommand rs (CMBulk ["HGET", toBS key, toBS field]) >> recv rs)
hdel :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
hdel r key field = withState r (\rs -> sendCommand rs (CMBulk ["HDEL", toBS key, toBS field]) >> recv rs)
hmset :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> [(s2, s3)]
-> IO (Reply ())
hmset r key fields = let interlace' [] ls = ls
interlace' ((a, b):rest) ls = interlace' rest (toBS a : toBS b : ls)
interlace ls = interlace' ls []
in withState r (\rs -> sendCommand rs (CMBulk ("HMSET" : toBS key : interlace fields)) >> recv rs)
hmget :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> [s2]
-> IO (Reply s3)
hmget r key fields = withState r (\rs -> sendCommand rs (CMBulk ("HMGET" : toBS key : map toBS fields)) >> recv rs)
hincrby :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> Int
-> IO (Reply Int)
hincrby r key field n = withState r (\rs -> sendCommand rs (CMBulk ["HINCRBY", toBS key, toBS field, toBS n]) >> recv rs)
hexists :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
hexists r key field = withState r (\rs -> sendCommand rs (CMBulk ["HEXISTS", toBS key, toBS field]) >> recv rs)
hlen :: (BS s) =>
Redis
-> s
-> IO (Reply Int)
hlen r key = withState r (\rs -> sendCommand rs (CMBulk ["HLEN", toBS key]) >> recv rs)
hkeys :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
hkeys r key = withState r (\rs -> sendCommand rs (CMBulk ["HKEYS", toBS key]) >> recv rs)
hvals :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
hvals r key = withState r (\rs -> sendCommand rs (CMBulk ["HVALS", toBS key]) >> recv rs)
hgetall :: (BS s1, BS s2) =>
Redis
-> s1
-> IO (Reply s2)
hgetall r key = withState r (\rs -> sendCommand rs (CMBulk ["HGETALL", toBS key]) >> recv rs)
data BS s => SortOptions s = SortOptions { desc :: Bool,
limit :: (Int, Int),
alpha :: Bool,
sort_by :: s,
get_obj :: [s],
store :: s
}
sortDefaults :: SortOptions ByteString
sortDefaults = SortOptions { desc = False,
limit = takeAll,
alpha = False,
sort_by = "",
get_obj = [],
store = "" }
sort :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> SortOptions s2
-> IO (Reply s3)
sort r key opt = let opt_s = buildOptions opt
buildOptions :: BS s => SortOptions s -> [ByteString]
buildOptions opt = let desc_s
| desc opt = ["DESC"]
| otherwise = []
limit_s
| (limit opt) == (0, 0) = []
| otherwise = ["LIMIT", (toBS $ fst $ limit opt), (toBS $ snd $ limit opt)]
alpha_s
| alpha opt = ["ALPHA"]
| otherwise = []
sort_by_s
| B.null $ toBS (sort_by opt) = []
| otherwise = ["BY",(toBS $ sort_by opt)]
get_obj_s
| null $ get_obj opt = []
| otherwise = "GET" : map toBS (get_obj opt)
store_s
| B.null $ toBS (store opt) = []
| otherwise = ["STORE", toBS $ store opt]
in concat [sort_by_s, limit_s, get_obj_s, desc_s, alpha_s, store_s]
in withState r (\rs -> sendCommand rs (CMBulk ("SORT" : toBS key : opt_s)) >> recv rs)
listRelated :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> s2
-> (Int, Int)
-> IO (Reply s3)
listRelated r related key l = let opts = sortDefaults { sort_by = "x",
get_obj = [toBS related],
limit = l }
in sort r key opts
subscribed :: Redis -> IO Int
subscribed r = withState r $ \rs -> return $ isSubscribed rs
recv_ rs ls 0 = return ls
recv_ rs ls n = do l <- recv rs
ll <- recv_ rs ls (n 1)
return $ l:ll
subscribe :: (BS s1, BS s2) =>
Redis
-> [s1]
-> IO [Message s2]
subscribe r classes = inState r $ \rs -> do sendCommand rs (CMBulk ("SUBSCRIBE" : map toBS classes))
res <- recv_ rs [] (length classes) >>= mapM parseMessage
let !(MSubscribe _ n) = last res
return (rs {isSubscribed = n}, res)
unsubscribe :: (BS s1, BS s2) =>
Redis
-> [s1]
-> IO [Message s2]
unsubscribe r [] = inState r $ \rs -> let subs = isSubscribed rs
in if subs == 0
then return (rs, [])
else do sendCommand rs (CInline "UNSUBSCRIBE")
res <- recv_ rs [] subs >>= mapM parseMessage
let !(MUnsubscribe _ n) = last res
return (rs {isSubscribed = n}, res)
unsubscribe r classes = inState r $ \rs -> do sendCommand rs (CMBulk ("UNSUBSCRIBE" : map toBS classes))
res <- recv_ rs [] (length classes) >>= mapM parseMessage
let !(MUnsubscribe _ n) = last res
return (rs {isSubscribed = n}, res)
psubscribe :: (BS s1, BS s2) =>
Redis
-> [s1]
-> IO [Message s2]
psubscribe r patterns = inState r $ \rs -> do sendCommand rs (CMBulk ("PSUBSCRIBE" : map toBS patterns))
res <- recv_ rs [] (length patterns) >>= mapM parseMessage
let !(MPSubscribe _ n) = last res
return (rs {isSubscribed = n}, res)
punsubscribe :: (BS s1, BS s2) =>
Redis
-> [s1]
-> IO [Message s2]
punsubscribe r [] = inState r $ \rs -> let subs = isSubscribed rs
in if subs == 0
then return (rs, [])
else do sendCommand rs (CInline "PUNSUBSCRIBE")
res <- recv_ rs [] subs >>= mapM parseMessage
let !(MPUnsubscribe _ n) = last res
return (rs {isSubscribed = n}, res)
punsubscribe r patterns = inState r $ \rs -> do sendCommand rs (CMBulk ("PUNSUBSCRIBE" : map toBS patterns))
res <- recv_ rs [] (length patterns) >>= mapM parseMessage
let !(MPUnsubscribe _ n) = last res
return (rs {isSubscribed = n}, res)
publish :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
publish r klass msg = withState r $ \rs -> sendCommand rs (CMBulk ["PUBLISH", toBS klass, toBS msg]) >> recv rs
listen :: BS s =>
Redis
-> Int
-> IO (Maybe (Message s))
listen r timeout = withState r $ \rs -> if isSubscribed rs == 0
then return Nothing
else do ready <- wait rs timeout
if ready
then recv rs >>= parseMessage >>= return . Just
else return Nothing
save :: Redis -> IO (Reply ())
save r = withState r (\rs -> sendCommand rs (CInline "SAVE") >> recv rs)
bgsave :: Redis -> IO (Reply ())
bgsave r = withState r (\rs -> sendCommand rs (CInline "BGSAVE") >> recv rs)
lastsave :: Redis -> IO (Reply Int)
lastsave r = withState r (\rs -> sendCommand rs (CInline "LASTSAVE") >> recv rs)
bgrewriteaof :: Redis -> IO (Reply ())
bgrewriteaof r = withState r (\rs -> sendCommand rs (CInline "BGREWRITEAOF") >> recv rs)