module Database.Redis.Redis (
Redis,
Reply(..),
Message(..),
LInsertDirection(..),
Interval(..),
IsInterval(..),
SortOptions(..),
Aggregate(..),
RedisKeyType(..),
RedisInfo,
sortDefaults,
fromRInline, fromRBulk, fromRBulk', fromRMulti,
fromRMultiBulk, fromRMultiBulk', fromRInt,
fromROk, noError, parseMessage, takeAll,
localhost, defaultPort,
connect, disconnect, isConnected,
getServer, getDatabase, renameCommand,
ping, auth, echo, quit, shutdown,
multi, exec, discard, run_multi,
watch, unwatch, run_cas, exists,
del, getType, keys, randomKey, rename,
renameNx, dbsize, expire, expireAt,
persist, ttl, select, move, flushDb,
flushAll, info,
set, setNx, setEx, mSet, mSetNx,
get, getSet, mGet,
incr, incrBy, decr,
decrBy, append, substr,
getrange, setrange,
getbit, setbit, strlen,
rpush, lpush, rpushx, lpushx,
linsert, llen, lrange, ltrim,
lindex, lset, lrem, lpop, rpop,
rpoplpush, blpop, brpop, brpoplpush,
sadd, srem, spop, smove, scard, sismember,
smembers, srandmember, sinter, sinterStore,
sunion, sunionStore, sdiff, sdiffStore,
zadd, zrem, zincrBy, zrange,
zrevrange, zrangebyscore, zrevrangebyscore,
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 qualified Data.ByteString.Char8 as B8 (unpack, pack)
import Data.ByteString (ByteString)
import Data.Maybe (fromJust, isNothing)
import Data.List (intersperse)
import qualified Data.Map as Map
import Control.Monad (when)
import Control.Exception (onException)
import Database.Redis.ByteStringClass
import Database.Redis.Info
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)
fromRBulk' :: (Monad m, BS s) => Reply s -> m s
fromRBulk' reply = fromRBulk reply >>= return . fromJust
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)
fromRMultiBulk' :: (Monad m, BS s) => Reply s -> m [s]
fromRMultiBulk' reply = fromRMultiBulk reply >>= return . fromJust >>= return . (map fromJust)
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 s <- if null port
then socket_unix hostname
else socket_inet hostname port
h <- S.socketToHandle s IO.ReadWriteMode
IO.hSetBuffering h (IO.BlockBuffering Nothing)
newRedis (hostname, port) h
socket_inet :: String -> String -> IO S.Socket
socket_inet hostname port =
do serveraddr <- head `fmap` (S.getAddrInfo
(Just S.defaultHints {S.addrFlags = [S.AI_CANONNAME],
S.addrFamily = S.AF_INET})
(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)
return s
socket_unix :: String -> IO S.Socket
socket_unix path =
do s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
S.setSocketOption s S.KeepAlive 0
S.connect s (S.SockAddrUnix path)
return s
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)
renameCommand :: Redis
-> ByteString
-> ByteString
-> IO ()
renameCommand r c c' = inState_ r $ \rs -> let m = renamedCommands rs
in return $ rs {renamedCommands = Map.insert c c' m}
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)
echo :: BS s =>
Redis
-> s
-> IO (Reply s)
echo r s = withState r (\rs -> sendCommand rs (CMBulk ["ECHO", toBS s]) >> 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
-> (Redis -> IO ())
-> IO (Reply s)
run_multi r cs = withState r (\rs -> do sendCommand rs (CInline "MULTI")
(recv rs :: IO (Reply ())) >>= fromROk
cs r `onException` do sendCommand rs (CInline "DISCARD")
recv rs :: IO (Reply ())
sendCommand rs (CInline "EXEC")
recv rs)
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 =>
Redis
-> [s1]
-> (Redis -> IO a)
-> IO a
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 r `onException` do sendCommand rs (CInline "DISCARD")
recv rs :: IO (Reply ())
sendCommand rs (CInline "UNWATCH")
recv rs :: IO (Reply ())
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)
data RedisKeyType = RTNone | RTString | RTList | RTSet | RTZSet | RTHash
deriving (Show, Eq)
parseType :: ByteString -> RedisKeyType
parseType "none" = RTNone
parseType "string" = RTString
parseType "list" = RTList
parseType "set" = RTSet
parseType "zset" = RTZSet
parseType "hash" = RTHash
parseType s = error $ "unknown key type: " ++ (B8.unpack s)
getType :: BS s =>
Redis
-> s
-> IO RedisKeyType
getType r key = withState r (\rs -> sendCommand rs (CMBulk ["TYPE", toBS key]) >> recv rs
>>= fromRInline >>= return . parseType)
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)
persist :: BS s =>
Redis
-> s
-> IO (Reply Int)
persist r key = withState r (\rs -> sendCommand rs (CMBulk ["PERSIST", toBS key]) >> 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 :: Redis -> IO RedisInfo
info r = withState r (\rs -> sendCommand rs (CInline "INFO") >> recv rs
>>= fromRBulk >>= return . fromRight . parseInfo . fromJust)
where fromRight (Right a) = a
fromRight _ = error "fromRight"
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)
getrange :: (BS s1, BS s2) =>
Redis
-> s1
-> (Int, Int)
-> IO (Reply s2)
getrange r key (from, to) = withState r (\rs -> sendCommand rs (CMBulk ["GETRANGE", toBS key, toBS from, toBS to]) >> recv rs)
setrange :: (BS s1, BS s2) =>
Redis
-> s1
-> Int
-> s2
-> IO (Reply Int)
setrange r key offset val = withState r (\rs -> sendCommand rs (CMBulk ["SETRANGE", toBS key, toBS offset, toBS val]) >> recv rs)
getbit :: (BS s) =>
Redis
-> s
-> Int
-> IO (Reply Int)
getbit r key offset = withState r (\rs -> sendCommand rs (CMBulk ["GETBIT", toBS key, toBS offset]) >> recv rs)
setbit :: (BS s) =>
Redis
-> s
-> Int
-> Int
-> IO (Reply Int)
setbit r key offset bit = withState r (\rs -> sendCommand rs (CMBulk ["SETBIT", toBS key, toBS offset, toBS bit]) >> recv rs)
strlen :: BS s =>
Redis
-> s
-> IO (Reply Int)
strlen r key = withState r (\rs -> sendCommand rs (CMBulk ["STRLEN", toBS key]) >> 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)
lpushx :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
lpushx r key val = withState r (\rs -> sendCommand rs (CMBulk ["LPUSHX", toBS key, toBS val]) >> recv rs)
rpushx :: (BS s1, BS s2) =>
Redis
-> s1
-> s2
-> IO (Reply Int)
rpushx r key val = withState r (\rs -> sendCommand rs (CMBulk ["RPUSHX", toBS key, toBS val]) >> recv rs)
data LInsertDirection = BEFORE | AFTER deriving Show
linsert :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> LInsertDirection
-> s2
-> s3
-> IO (Reply Int)
linsert r key direction anchor value = withState r (\rs -> sendCommand rs (CMBulk ["LINSERT", toBS key, toBS $ show direction, toBS anchor, toBS value]) >> 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 (Maybe (s1, s2))
blpop r keys timeout = withState r $ \rs -> do sendCommand rs (CMBulk (("BLPOP" : map toBS keys) ++ [toBS timeout]))
res <- recv rs >>= fromRMultiBulk
return $ case res of
Nothing -> Nothing
Just [Just k, Just v] -> Just (fromBS k, fromBS v)
brpop :: (BS s1, BS s2) =>
Redis
-> [s1]
-> Int
-> IO (Maybe (s1, s2))
brpop r keys timeout = withState r $ \rs -> do sendCommand rs (CMBulk (("BRPOP" : map toBS keys) ++ [toBS timeout]))
res <- recv rs >>= fromRMultiBulk
return $ case res of
Nothing -> Nothing
Just [Just k, Just v] -> Just (fromBS k, fromBS v)
brpoplpush :: (BS s1, BS s2, BS s3) =>
Redis
-> s1
-> s2
-> Int
-> IO (Maybe (Maybe s3))
brpoplpush r src dst timeout = withState r $ \rs -> do sendCommand rs (CMBulk ["BRPOPLPUSH", toBS src, toBS dst, toBS timeout])
res <- recv rs
return $ case res of
RBulk res' -> Just res'
RMulti Nothing -> Nothing
_ -> error $ "wrong reply, RBulk or Nil RMulti expected: " ++ show res
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
-> Maybe (Int, Int)
-> Bool
-> IO (Reply s2)
zrangebyscore r key i limit withscores = let cmd' = i' `seq` ["ZRANGEBYSCORE", toBS key, toBS (from i'), toBS (to i')]
cmd'' = maybe cmd' (\(a, b) -> cmd' ++ ["LIMIT", toBS a, toBS b]) limit
cmd | withscores = cmd'' ++ ["WITHSCORES"]
| otherwise = cmd''
i' = toInterval i
in cmd `seq` withState r (\rs -> sendCommand rs (CMBulk cmd) >> recv rs)
zrevrangebyscore :: (IsInterval i Double, BS s1, BS s2) =>
Redis
-> s1
-> i
-> Maybe (Int, Int)
-> Bool
-> IO (Reply s2)
zrevrangebyscore r key i limit withscores = let cmd' = i' `seq` ["ZREVRANGEBYSCORE", toBS key, toBS (from i'), toBS (to i')]
cmd'' = maybe cmd' (\(a, b) -> cmd' ++ ["LIMIT", toBS a, toBS b]) limit
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 (("ZINTERSTORE" : 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" : (intersperse "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)