{-# 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 -- -- (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 -- -- (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 -- -- 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 -- -- 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 -- -- 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 -- -- 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