{- Copyright (c) 2010 Alexander Bogdanov Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -} {-# 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, discard, 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 -- | Discard queued commands without execution -- -- ROk returned discard :: Redis -> IO Reply discard r = sendCommand r (CInline "DISCARD") >> 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 -- -- RMulti filled with RBulk returned keys :: Redis -> String -- ^ target keys pattern -> 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