module Database.Redis.Redis (
Redis(..),
Reply(..),
Interval(..),
IsInterval(..),
SortOptions(..),
sortDefaults,
fromRInline, fromRBulk, fromRMulti, fromRMultiBulk,
fromRInt, fromROk, noError, takeAll,
localhost, defaultPort,
connect, disconnect, isConnected,
ping, auth, quit, shutdown,
multi, exec, discard, run_multi, exists,
del, getType, keys, randomKey, rename,
renameNx, dbsize, expire, expireAt,
ttl, select, move, flushDb,
flushAll, info,
set, setNx, mSet, mSetNx,
get, getSet, mGet,
incr, incrBy, decr,
decrBy, append,
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,
sort, listRelated,
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)
data Redis = Redis { server :: (String, String),
handle :: IO.Handle
}
deriving (Show, Eq)
data Command = CInline String
| CMInline [String]
| CBulk [String] String
| CMBulk [String]
data Reply = RTimeout
| ROk
| RPong
| RQueued
| RError String
| RInline String
| RInt Int
| RBulk (Maybe String)
| RMulti (Maybe [Reply])
deriving (Show, Eq)
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)
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)
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)
fromRMultiBulk :: (Monad m) => Reply -> m (Maybe [Maybe String])
fromRMultiBulk reply = fromRMulti reply >>= return . (>>= sequence . map fromRBulk)
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)
fromROk :: (Monad m) => Reply -> m ()
fromROk reply = case reply of
RError msg -> error msg
ROk -> return ()
_ -> error $ "wrong reply, ROk expected: " ++ (show reply)
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
defaultPort :: String
defaultPort = "6379"
localhost :: String
localhost = "localhost"
takeAll :: (Int, Int)
takeAll = (0, 1)
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
disconnect :: Redis -> IO ()
disconnect = IO.hClose . handle
isConnected :: Redis -> IO Bool
isConnected = IO.hIsOpen . handle
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 (n1)
return $ Just (this : tail)
ping :: Redis -> IO Reply
ping r = sendCommand r (CInline "PING") >> recv r
auth :: Redis
-> String
-> IO Reply
auth r pwd = sendCommand r (CMInline ["AUTH", pwd] ) >> recv r
quit :: Redis -> IO ()
quit r = sendCommand r (CInline "QUIT") >> disconnect r
shutdown :: Redis -> IO Reply
shutdown r = sendCommand r (CInline "SHUTDOWN") >> recv r
multi :: Redis -> IO Reply
multi r = sendCommand r (CInline "MULTI") >> recv r
exec :: Redis -> IO Reply
exec r = sendCommand r (CInline "EXEC") >> recv r
discard :: Redis -> IO Reply
discard r = sendCommand r (CInline "DISCARD") >> recv r
run_multi :: Redis
-> [IO Reply]
-> IO Reply
run_multi r cs = let cs' = map (>>= noError) cs
in do multi r
sequence_ cs'
exec r
exists :: Redis
-> String
-> IO Reply
exists r key = sendCommand r (CMBulk ["EXISTS", key]) >> recv r
del :: Redis
-> String
-> IO Reply
del r key = sendCommand r (CMBulk ["DEL", key]) >> recv r
getType :: Redis
-> String
-> IO Reply
getType r key = sendCommand r (CMBulk ["TYPE", key]) >> recv r
keys :: Redis
-> String
-> IO Reply
keys r pattern = sendCommand r (CMInline ["KEYS", pattern]) >> recv r
randomKey :: Redis -> IO Reply
randomKey r = sendCommand r (CInline "RANDOMKEY") >> recv r
rename :: Redis
-> String
-> String
-> IO Reply
rename r from to = sendCommand r (CMBulk ["RENAME", from, to]) >> recv r
renameNx :: Redis
-> String
-> String
-> IO Reply
renameNx r from to = sendCommand r (CMBulk ["RENAMENX", from, to]) >> recv r
dbsize :: Redis -> IO Reply
dbsize r = sendCommand r (CInline "DBSIZE") >> recv r
expire :: Redis
-> String
-> Int
-> IO Reply
expire r key seconds = sendCommand r (CMBulk ["EXPIRE", key, show seconds]) >> recv r
expireAt :: Redis
-> String
-> Int
-> IO Reply
expireAt r key timestamp = sendCommand r (CMBulk ["EXPIRE", key, show timestamp]) >> recv r
ttl :: Redis
-> String
-> IO Reply
ttl r key = sendCommand r (CMBulk ["TTL", key]) >> recv r
select :: Redis
-> Int
-> IO Reply
select r db = sendCommand r (CMInline ["SELECT", show db]) >> recv r
move :: Redis
-> String
-> Int
-> IO Reply
move r key db = sendCommand r (CMBulk ["MOVE", key, show db]) >> recv r
flushDb :: Redis -> IO Reply
flushDb r = sendCommand r (CInline "FLUSHDB") >> recv r
flushAll :: Redis -> IO Reply
flushAll r = sendCommand r (CInline "FLUSHALL") >> recv r
info :: Redis -> IO Reply
info r = sendCommand r (CInline "INFO") >> recv r
set :: Redis
-> String
-> String
-> IO Reply
set r key val = sendCommand r (CMBulk ["SET", key, val]) >> recv r
setNx :: Redis
-> String
-> String
-> IO Reply
setNx r key val = sendCommand r (CMBulk ["SETNX", key, val]) >> recv r
mSet :: Redis
-> [(String, String)]
-> 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
mSetNx :: Redis
-> [(String, String)]
-> 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 :: Redis
-> String
-> IO Reply
get r key = sendCommand r (CMBulk ["GET", key]) >> recv r
getSet :: Redis
-> String
-> String
-> IO Reply
getSet r key val = sendCommand r (CMBulk ["GETSET", key, val]) >> recv r
mGet :: Redis
-> [String]
-> IO Reply
mGet r keys = sendCommand r (CMBulk ("MGET" : keys)) >> recv r
incr :: Redis
-> String
-> IO Reply
incr r key = sendCommand r (CMBulk ["INCR", key]) >> recv r
incrBy :: Redis
-> String
-> Int
-> IO Reply
incrBy r key n = sendCommand r (CMBulk ["INCRBY", key, show n]) >> recv r
decr :: Redis
-> String
-> IO Reply
decr r key = sendCommand r (CMBulk ["DECR", key]) >> recv r
decrBy :: Redis
-> String
-> Int
-> IO Reply
decrBy r key n = sendCommand r (CMBulk ["DECRBY", key, show n]) >> recv r
append :: Redis
-> String
-> String
-> IO Reply
append r key str = sendCommand r (CMBulk ["APPEND", key, str]) >> recv r
rpush :: Redis
-> String
-> String
-> IO Reply
rpush r key val = sendCommand r (CMBulk ["RPUSH", key, val]) >> recv r
lpush :: Redis
-> String
-> String
-> IO Reply
lpush r key val = sendCommand r (CMBulk ["LPUSH", key, val]) >> recv r
llen :: Redis
-> String
-> IO Reply
llen r key = sendCommand r (CMBulk ["LLEN", key]) >> recv r
lrange :: Redis
-> String
-> (Int, Int)
-> IO Reply
lrange r key (from, to) = sendCommand r (CMBulk ["LRANGE", key, show from, show to]) >> recv r
ltrim :: Redis
-> String
-> (Int, Int)
-> IO Reply
ltrim r key (from, to) = sendCommand r (CMBulk ["LTRIM", key, show from, show to]) >> recv r
lindex :: Redis
-> String
-> Int
-> IO Reply
lindex r key index = sendCommand r (CMBulk ["LINDEX", key, show index]) >> recv r
lset :: Redis -> String -> Int -> String -> IO Reply
lset r key index val = sendCommand r (CMBulk ["LSET", key, show index, val]) >> recv r
lrem :: Redis
-> String
-> Int
-> String
-> IO Reply
lrem r key count value = sendCommand r (CMBulk ["LREM", key, show count, value]) >> recv r
lpop :: Redis
-> String
-> IO Reply
lpop r key = sendCommand r (CMBulk ["LPOP", key]) >> recv r
rpop :: Redis
-> String
-> IO Reply
rpop r key = sendCommand r (CMBulk ["RPOP", key]) >> recv r
rpoplpush :: Redis
-> String
-> String
-> IO Reply
rpoplpush r src dst = sendCommand r (CMBulk ["RPOPLPUSH", src, dst]) >> recv r
blpop :: Redis
-> [String]
-> Int
-> IO Reply
blpop r keys timeout = sendCommand r (CMBulk (("BLPOP" : keys) ++ [show timeout])) >> recv r
brpop :: Redis
-> [String]
-> Int
-> IO Reply
brpop r keys timeout = sendCommand r (CMBulk (("BRPOP" : keys) ++ [show timeout])) >> recv r
sadd :: Redis
-> String
-> String
-> IO Reply
sadd r key val = sendCommand r (CMBulk ["SADD", key, val]) >> recv r
srem :: Redis
-> String
-> String
-> IO Reply
srem r key val = sendCommand r (CMBulk ["SREM", key, val]) >> recv r
spop :: Redis
-> String
-> IO Reply
spop r key = sendCommand r (CMBulk ["SPOP", key]) >> recv r
smove :: Redis
-> String
-> String
-> String
-> IO Reply
smove r src dst member = sendCommand r (CMBulk ["SMOVE", src, dst, member]) >> recv r
scard :: Redis
-> String
-> IO Reply
scard r key = sendCommand r (CMBulk ["SCARD", key]) >> recv r
sismember :: Redis
-> String
-> IO Reply
sismember r key = sendCommand r (CMBulk ["SISMEMBER", key]) >> recv r
smembers :: Redis
-> String
-> IO Reply
smembers r key = sendCommand r (CMBulk ["SMEMBERS", key]) >> recv r
srandmember :: Redis
-> String
-> IO Reply
srandmember r key = sendCommand r (CMBulk ["SRANDMEMBER", key]) >> recv r
sinter :: Redis
-> [String]
-> IO Reply
sinter r keys = sendCommand r (CMBulk ("SINTER" : keys)) >> recv r
sinterStore :: Redis
-> String
-> [String]
-> IO Reply
sinterStore r dst keys = sendCommand r (CMBulk ("SINTERSTORE" : dst : keys)) >> recv r
sunion :: Redis
-> [String]
-> IO Reply
sunion r keys = sendCommand r (CMBulk ("SUNION" : keys)) >> recv r
sunionStore :: Redis
-> String
-> [String]
-> IO Reply
sunionStore r dst keys = sendCommand r (CMBulk ("SUNIONSTORE" : dst : keys)) >> recv r
sdiff :: Redis
-> [String]
-> IO Reply
sdiff r keys = sendCommand r (CMBulk ("SDIFF" : keys)) >> recv r
sdiffStore :: Redis
-> String
-> [String]
-> IO Reply
sdiffStore r dst keys = sendCommand r (CMBulk ("SDIFFSTORE" : dst : keys)) >> recv r
zadd :: Redis
-> String
-> Double
-> String
-> IO Reply
zadd r key score member = sendCommand r (CMBulk ["ZADD", key, show score, member]) >> recv r
zrem :: Redis
-> String
-> String
-> IO Reply
zrem r key member = sendCommand r (CMBulk ["ZREM", key, member]) >> recv r
zincrBy :: Redis
-> String
-> Double
-> String
-> IO Reply
zincrBy r key increment member = sendCommand r (CMBulk ["ZINCRBY", key, show increment, member]) >> recv r
zrange :: Redis
-> String
-> (Int, Int)
-> Bool
-> 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
zrevrange :: Redis
-> String
-> (Int, Int)
-> Bool
-> 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
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 =>
Redis
-> String
-> i
-> Bool
-> 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
zcount :: IsInterval i Double =>
Redis
-> String
-> i
-> 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
zremrangebyscore :: Redis
-> String
-> (Double, Double)
-> IO Reply
zremrangebyscore r key (from, to) = sendCommand r (CMBulk ["ZREMRANGEBYSCORE", key, show from, show to]) >> recv r
zcard :: Redis
-> String
-> IO Reply
zcard r key = sendCommand r (CMBulk ["ZCARD", key]) >> recv r
zscore :: Redis
-> String
-> String
-> IO Reply
zscore r key member = sendCommand r (CMBulk ["ZSCORE", key, member]) >> recv r
data SortOptions = SortOptions { desc :: Bool,
limit :: (Int, Int),
alpha :: Bool,
sort_by :: String,
get_obj :: [String],
store :: String
}
sortDefaults :: SortOptions
sortDefaults = SortOptions { desc = False,
limit = takeAll,
alpha = False,
sort_by = "",
get_obj = [],
store = "" }
sort :: Redis
-> String
-> SortOptions
-> 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
listRelated :: Redis
-> String
-> String
-> (Int, Int)
-> IO Reply
listRelated r related key l = let opts = sortDefaults { sort_by = "x",
get_obj = [related],
limit = l }
in sort r key opts
save :: Redis -> IO Reply
save r = sendCommand r (CInline "SAVE") >> recv r
bgsave :: Redis -> IO Reply
bgsave r = sendCommand r (CInline "BGSAVE") >> recv r
lastsave :: Redis -> IO Reply
lastsave r = sendCommand r (CInline "LASTSAVE") >> recv r
bgrewriteaof :: Redis -> IO Reply
bgrewriteaof r = sendCommand r (CInline "BGREWRITEAOF") >> recv r