diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + import System (getArgs) import System.Exit (exitFailure, exitSuccess) import System.Console.GetOpt @@ -18,12 +23,16 @@ -- runWorkers :: Redis -> total loops count -> Worker -> IO time passed runWorkers :: [Redis] -> Int -> Worker -> IO NominalDiffTime -runWorkers rs loops worker = - do mvs <- mapM fork $ zip [0 .. (workers - 1)] rs - t <- getCurrentTime - mapM_ (flip putMVar () . fst) mvs - mapM_ (takeMVar . snd ) mvs - flip diffUTCTime t `fmap` getCurrentTime +runWorkers rs loops worker + | workers > 1 = do mvs <- mapM fork $ zip [0 .. (workers - 1)] rs + t <- getCurrentTime + mapM_ (flip putMVar () . fst) mvs + mapM_ (takeMVar . snd ) mvs + flip diffUTCTime t `fmap` getCurrentTime + | otherwise = do mv <- newMVar () + t <- getCurrentTime + worker (head rs) (prefix 0) loops mv mv + flip diffUTCTime t `fmap` getCurrentTime where fork (n, r) = do lock <- newEmptyMVar unlock <- newEmptyMVar if n < workers - 1 @@ -90,7 +99,10 @@ main :: IO () main = do args <- getArgs - opts <- case getOpt RequireOrder options args of + when (length args == 0) $ do putStrLn $ usageInfo "Usage: " options + exitSuccess + + opts <- case getOpt Permute options args of (o, [], []) -> return $ foldl (flip id) defaultOpts o (_, n, []) -> do putStrLn $ "Unrecognized arguments: " ++ concat n ++ usageInfo "\nUsage: " options exitFailure diff --git a/Database/Redis/ByteStringClass.hs b/Database/Redis/ByteStringClass.hs --- a/Database/Redis/ByteStringClass.hs +++ b/Database/Redis/ByteStringClass.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Database.Redis.ByteStringClass where diff --git a/Database/Redis/Info.hs b/Database/Redis/Info.hs --- a/Database/Redis/Info.hs +++ b/Database/Redis/Info.hs @@ -1,35 +1,35 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Database.Redis.Info ( RedisInfo, parseInfo ) where -import Text.Parsec -import Data.Map - -import Database.Redis.ByteStringClass +import Data.Map (Map(..), fromList) +import Data.Char type RedisInfo = Map String String -parseInfo :: String -> Either ParseError RedisInfo -parseInfo = runParser infoP empty "info" - -infoP :: Parsec String RedisInfo RedisInfo -infoP = do skipMany infoLine - getState +parseInfo :: String -> RedisInfo +parseInfo = fromList . parsePairs . filterComments . filterEmptyLines . lines -infoLine :: Parsec String RedisInfo () -infoLine = emptyLine <|> commentLine <|> keyLine +filterEmptyLines :: [String] -> [String] +filterEmptyLines = filter $ not . all isSpace -emptyLine :: Parsec String RedisInfo () -emptyLine = skipMany (oneOf [' ', '\t', '\r']) >> newline >> return () +startsWith :: Char -> String -> Bool +startsWith c (s:ls) | c == s = True + | isSpace s = startsWith c ls + | otherwise = False +startsWith _ _ = False -commentLine :: Parsec String RedisInfo () -commentLine = char '#' >> skipMany (noneOf ['\n']) >> newline >> return () +trim = takeWhile (not . isSpace) . dropWhile isSpace -keyLine :: Parsec String RedisInfo () -keyLine = do key <- many1 (noneOf [':']) - char ':' - val <- many1 (noneOf [' ', '\t', '\r', '\n']) - skipMany (oneOf [' ', '\t', '\r']) - newline - m <- getState - setState $ insert key val m +filterComments :: [String] -> [String] +filterComments = filter $ not . startsWith '#' + +parsePairs :: [String] -> [(String, String)] +parsePairs = map parsePair + where parsePair ls = let (a, b) = break (== ':') ls + in (a, trim $ tail b) diff --git a/Database/Redis/Internal.hs b/Database/Redis/Internal.hs --- a/Database/Redis/Internal.hs +++ b/Database/Redis/Internal.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + +{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-} module Database.Redis.Internal where import Prelude hiding (putStrLn, putStr, catch) @@ -56,17 +61,17 @@ | CMBulk [ByteString] -- | Redis reply variants -data BS s => Reply s = RTimeout -- ^ Timeout. Currently unused - | RParseError String -- ^ Error converting value from ByteString. It's a client-side error. - | ROk -- ^ \"Ok\" reply - | RPong -- ^ Reply for the ping command - | RQueued -- ^ Used inside multi-exec block - | RError String -- ^ Some kind of server-side error - | RInline s -- ^ Simple oneline reply - | RInt Int -- ^ Integer reply - | RBulk (Maybe s) -- ^ Multiline reply - | RMulti (Maybe [Reply s]) -- ^ Complex reply. It may consists of various type of replys - deriving Eq +data Reply s = RTimeout -- ^ Timeout. Currently unused + | RParseError String -- ^ Error converting value from ByteString. It's a client-side error. + | ROk -- ^ \"Ok\" reply + | RPong -- ^ Reply for the ping command + | RQueued -- ^ Used inside multi-exec block + | RError String -- ^ Some kind of server-side error + | RInline s -- ^ Simple oneline reply + | RInt Int -- ^ Integer reply + | RBulk (Maybe s) -- ^ Multiline reply + | RMulti (Maybe [Reply s]) -- ^ Complex reply. It may consists of various type of replys + deriving Eq showbs :: BS s => s -> String showbs = U.toString . toBS @@ -86,13 +91,13 @@ where join = concat . intersperse ", " . map show show (RMulti Nothing) = "RMulti Nil" -data (BS s) => Message s = MSubscribe s Int -- ^ subscribed - | MUnsubscribe s Int -- ^ unsubscribed - | MPSubscribe s Int -- ^ pattern subscribed - | MPUnsubscribe s Int -- ^ pattern unsubscribed - | MMessage s s -- ^ message recieved - | MPMessage s s s -- ^ message recieved by pattern - deriving (Eq, Show) +data Message s = MSubscribe s Int -- ^ subscribed + | MUnsubscribe s Int -- ^ unsubscribed + | MPSubscribe s Int -- ^ pattern subscribed + | MPUnsubscribe s Int -- ^ pattern unsubscribed + | MMessage s s -- ^ message recieved + | MPMessage s s s -- ^ message recieved by pattern + deriving (Eq, Show) urn = U.fromString "\r\n" uspace = U.fromString " " diff --git a/Database/Redis/Monad.hs b/Database/Redis/Monad.hs --- a/Database/Redis/Monad.hs +++ b/Database/Redis/Monad.hs @@ -1,23 +1,6 @@ {- -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. +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT -} {-# LANGUAGE FlexibleContexts, OverloadedStrings, PackageImports #-} @@ -51,7 +34,7 @@ ping, auth, echo, quit, shutdown, multi, exec, discard, run_multi, watch, unwatch, run_cas, exists, - del, getType, keys, randomKey, rename, + del, del_, getType, keys, randomKey, rename, renameNx, dbsize, expire, expireAt, persist, ttl, select, move, flushDb, flushAll, info, @@ -59,32 +42,32 @@ -- ** Strings set, setNx,setEx, mSet, mSetNx, get, getSet, mGet, - incr, incrBy, decr, + incr, incrBy, incrByFloat, decr, decrBy, append, substr, getrange, setrange, getbit, setbit,strlen, -- ** Lists - rpush, lpush, rpushx, lpushx, + rpush, rpush_, lpush, rpushx, lpushx, llen, lrange, ltrim, lindex, lset, lrem, lpop, rpop, rpoplpush, blpop, brpop, brpoplpush, -- ** Sets - sadd, srem, spop, smove, scard, sismember, + sadd, sadd_, srem, srem_, spop, smove, scard, sismember, smembers, srandmember, sinter, sinterStore, sunion, sunionStore, sdiff, sdiffStore, -- ** Sorted sets - zadd, zrem, zincrBy, zrange, + zadd, zadd_, zrem, zrem_, zincrBy, zrange, zrevrange, zrangebyscore, zrevrangebyscore, zcount, zremrangebyscore, zcard, zscore, zrank, zrevrank, zremrangebyrank, zunion, zinter, zunionStore, zinterStore, -- ** Hashes - hset, hget, hdel, hmset, hmget, - hincrby, hexists, hlen, + hset, hget, hdel, hdel_, hmset, hmget, + hincrBy, hincrByFloat, hexists, hlen, hkeys, hvals, hgetall, -- ** Sorting @@ -195,6 +178,9 @@ del :: (WithRedis m, BS s) => s -> m (R.Reply Int) del key = getRedis >>= liftIO . flip R.del key +del_ :: (WithRedis m, BS s) => [s] -> m (R.Reply Int) +del_ keys = getRedis >>= liftIO . flip R.del_ keys + getType :: (WithRedis m, BS s1) => s1 -> m R.RedisKeyType getType key = getRedis >>= liftIO . flip R.getType key @@ -280,6 +266,10 @@ incrBy key n = do r <- getRedis liftIO $ R.incrBy r key n +incrByFloat :: (WithRedis m, BS s) => s -> Double -> m (R.Reply Double) +incrByFloat key n = do r <- getRedis + liftIO $ R.incrByFloat r key n + decr :: (WithRedis m, BS s) => s -> m (R.Reply Int) decr key = getRedis >>= liftIO . flip R.decr key @@ -318,10 +308,18 @@ rpush key val = do r <- getRedis liftIO $ R.rpush r key val +rpush_ :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> m (R.Reply Int) +rpush_ key vals = do r <- getRedis + liftIO $ R.rpush_ r key vals + lpush :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) lpush key val = do r <- getRedis liftIO $ R.lpush r key val +lpush_ :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> m (R.Reply Int) +lpush_ key vals = do r <- getRedis + liftIO $ R.lpush_ r key vals + rpushx :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) rpushx key val = do r <- getRedis liftIO $ R.rpushx r key val @@ -383,10 +381,18 @@ sadd key val = do r <- getRedis liftIO $ R.sadd r key val +sadd_ :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> m (R.Reply Int) +sadd_ key vals = do r <- getRedis + liftIO $ R.sadd_ r key vals + srem :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) srem key val = do r <- getRedis liftIO $ R.srem r key val +srem_ :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> m (R.Reply Int) +srem_ key vals = do r <- getRedis + liftIO $ R.srem_ r key vals + spop :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2) spop key = getRedis >>= liftIO . flip R.spop key @@ -432,10 +438,18 @@ zadd key score member = do r <- getRedis liftIO $ R.zadd r key score member +zadd_ :: (WithRedis m, BS s1, BS s2) => s1 -> [(Double, s2)] -> m (R.Reply Int) +zadd_ key elements = do r <- getRedis + liftIO $ R.zadd_ r key elements + zrem :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) zrem key member = do r <- getRedis liftIO $ R.zrem r key member +zrem_ :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> m (R.Reply Int) +zrem_ key members = do r <- getRedis + liftIO $ R.zrem_ r key members + zincrBy :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> Double -> s2 -> m (R.Reply s3) zincrBy key score member = do r <- getRedis liftIO $ R.zincrBy r key score member @@ -511,6 +525,10 @@ hdel key field = do r <- getRedis liftIO $ R.hdel r key field +hdel_ :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> m (R.Reply Int) +hdel_ key fields = do r <- getRedis + liftIO $ R.hdel_ r key fields + hmset :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> [(s2, s3)] -> m (R.Reply ()) hmset key fields = do r <- getRedis liftIO $ R.hmset r key fields @@ -519,9 +537,13 @@ hmget key fields = do r <- getRedis liftIO $ R.hmget r key fields -hincrby :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> Int -> m (R.Reply Int) -hincrby key field n = do r <- getRedis - liftIO $ R.hincrby r key field n +hincrBy :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> Int -> m (R.Reply Int) +hincrBy key field n = do r <- getRedis + liftIO $ R.hincrBy r key field n + +hincrByFloat :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> Double -> m (R.Reply Double) +hincrByFloat key field n = do r <- getRedis + liftIO $ R.hincrByFloat r key field n hexists :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) hexists key field = do r <- getRedis diff --git a/Database/Redis/Monad/State.hs b/Database/Redis/Monad/State.hs --- a/Database/Redis/Monad/State.hs +++ b/Database/Redis/Monad/State.hs @@ -1,26 +1,9 @@ {- -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. +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT -} -{-# LANGUAGE PackageImports, TypeSynonymInstances #-} +{-# LANGUAGE PackageImports, TypeSynonymInstances, FlexibleInstances #-} -- | This module is mainly an example of posible 'WithRedis' -- implementation module Database.Redis.Monad.State where diff --git a/Database/Redis/Redis.hs b/Database/Redis/Redis.hs --- a/Database/Redis/Redis.hs +++ b/Database/Redis/Redis.hs @@ -1,27 +1,10 @@ {- -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. +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT -} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, - FlexibleContexts, OverloadedStrings #-} + FlexibleContexts, OverloadedStrings, BangPatterns #-} -- | Main Redis API and protocol implementation module Database.Redis.Redis ( @@ -51,7 +34,7 @@ ping, auth, echo, quit, shutdown, multi, exec, discard, run_multi, watch, unwatch, run_cas, exists, - del, getType, keys, randomKey, rename, + del, del_, getType, keys, randomKey, rename, renameNx, dbsize, expire, expireAt, persist, ttl, select, move, flushDb, flushAll, info, @@ -59,32 +42,32 @@ -- ** Strings set, setNx, setEx, mSet, mSetNx, get, getSet, mGet, - incr, incrBy, decr, + incr, incrBy, incrByFloat, decr, decrBy, append, substr, getrange, setrange, getbit, setbit, strlen, -- ** Lists - rpush, lpush, rpushx, lpushx, + rpush, rpush_, lpush, lpush_, rpushx, lpushx, linsert, llen, lrange, ltrim, lindex, lset, lrem, lpop, rpop, rpoplpush, blpop, brpop, brpoplpush, -- ** Sets - sadd, srem, spop, smove, scard, sismember, + sadd, sadd_, srem, srem_, spop, smove, scard, sismember, smembers, srandmember, sinter, sinterStore, sunion, sunionStore, sdiff, sdiffStore, -- ** Sorted sets - zadd, zrem, zincrBy, zrange, + zadd, zadd_, zrem, zrem_, zincrBy, zrange, zrevrange, zrangebyscore, zrevrangebyscore, zcount, zremrangebyscore, zcard, zscore, zrank, zrevrank, zremrangebyrank, zunion, zinter, zunionStore, zinterStore, -- ** Hashes - hset, hget, hdel, hmset, hmget, - hincrby, hexists, hlen, + hset, hget, hdel, hdel_, hmset, hmget, + hincrBy, hincrByFloat, hexists, hlen, hkeys, hvals, hgetall, -- ** Sorting @@ -319,7 +302,7 @@ -- | Execute queued commands -- --- RMulti returned - replys for all executed commands +-- RMulti returned - replies for all executed commands exec :: BS s => Redis -> IO (Reply s) exec = withState' (\rs -> sendCommand rs (CInline "EXEC") >> recv rs) @@ -331,7 +314,7 @@ -- | Run commands within multi-exec block -- --- RMulti returned - replys for all executed commands +-- RMulti returned - replies for all executed commands run_multi :: (BS s) => Redis -> (Redis -> IO ()) -- ^ IO action to run @@ -403,6 +386,14 @@ -> IO (Reply Int) del r key = withState r (\rs -> sendCommand rs (CMBulk ["DEL", toBS key]) >> recv rs) +-- | Variadic form of DEL +-- +-- RInt returned - number of deleted keys +del_ :: BS s => + Redis + -> [s] -- ^ target keys list + -> IO (Reply Int) +del_ r keys = withState r (\rs -> sendCommand rs (CMBulk ("DEL" : map toBS keys)) >> recv rs) data RedisKeyType = RTNone | RTString | RTList | RTSet | RTZSet | RTHash deriving (Show, Eq) @@ -554,9 +545,7 @@ -- 'RedisInfo' returned 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" + >>= fromRBulk >>= return . parseInfo . fromJust) -- | Set the string value as value of the key -- @@ -637,7 +626,7 @@ -- | Get the values of all specified keys -- --- RMulti filled with RBulk replys returned +-- RMulti filled with RBulk replies returned mGet :: (BS s1, BS s2) => Redis -> [s1] -- ^ target keys @@ -663,6 +652,16 @@ -> IO (Reply Int) incrBy r key n = withState r (\rs -> sendCommand rs (CMBulk ["INCRBY", toBS key, toBS n]) >> recv rs) +-- | Increment the key value by N +-- +-- (RBulk Double) returned with new key value +incrByFloat :: BS s => + Redis + -> s -- ^ target key + -> Double -- ^ increment + -> IO (Reply Double) +incrByFloat r key n = withState r (\rs -> sendCommand rs (CMBulk ["INCRBYFLOAT", toBS key, toBS n]) >> recv rs) + -- | Decrement the key value by one -- -- RInt returned with new key value @@ -780,6 +779,16 @@ -> IO (Reply Int) rpush r key val = withState r (\rs -> sendCommand rs (CMBulk ["RPUSH", toBS key, toBS val]) >> recv rs) +-- | Variadic form of rpush +-- +-- RInt returned +rpush_ :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key + -> [s2] -- ^ values list + -> IO (Reply Int) +rpush_ r key vals = withState r (\rs -> sendCommand rs (CMBulk ("RPUSH" : toBS key : map toBS vals)) >> recv rs) + -- | Add string value to the head of the list-type key. New list -- length returned -- @@ -791,6 +800,15 @@ -> IO (Reply Int) lpush r key val = withState r (\rs -> sendCommand rs (CMBulk ["LPUSH", toBS key, toBS val]) >> recv rs) +-- | Variadic form of LPUSH +-- +-- RInt returned +lpush_ :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key + -> [s2] -- ^ values list + -> IO (Reply Int) +lpush_ r key vals = withState r (\rs -> sendCommand rs (CMBulk ("LPUSH" : toBS key : map toBS vals)) >> recv rs) -- | Add string value to the head of existing list-type key. New list -- length returned. If such a key was not exists, list is not created @@ -993,6 +1011,16 @@ -> IO (Reply Int) sadd r key val = withState r (\rs -> sendCommand rs (CMBulk ["SADD", toBS key, toBS val]) >> recv rs) +-- | Variadic form of SADD +-- +-- RInt returned - number of actualy added elements +sadd_ :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key + -> [s2] -- ^ values list + -> IO (Reply Int) +sadd_ r key vals = withState r (\rs -> sendCommand rs (CMBulk ("SADD" : toBS key : map toBS vals)) >> recv rs) + -- | Remove the specified member from the set value stored at key -- -- (RInt 1) returned if element was removed and (RInt 0) if element @@ -1004,6 +1032,16 @@ -> IO (Reply Int) srem r key val = withState r (\rs -> sendCommand rs (CMBulk ["SREM", toBS key, toBS val]) >> recv rs) +-- | Variadic form of SREM +-- +-- RInt returned - number of removed values +srem_ :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key + -> [s2] -- ^ values list + -> IO (Reply Int) +srem_ r key vals = withState r (\rs -> sendCommand rs (CMBulk ("SREM" : toBS key : map toBS vals)) >> recv rs) + -- | Remove a random element from a Set returning it as return value -- -- RBulk returned @@ -1141,6 +1179,18 @@ -> IO (Reply Int) zadd r key score member = withState r (\rs -> sendCommand rs (CMBulk ["ZADD", toBS key, toBS score, toBS member]) >> recv rs) +-- | Variadic form of zadd +-- +-- RInt returned - the number of elements actually added. Not +-- including elements which scores was just updated. +zadd_ :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key + -> [(Double, s2)] -- ^ list of score-value pairs + -> IO (Reply Int) +zadd_ r key elements = withState r (\rs -> sendCommand rs (CMBulk ("ZADD" : toBS key : concatMap unpair elements)) >> recv rs) + where unpair (score, element) = [toBS score, toBS element] + -- | Remove the specified member from the sorted set -- -- (RInt 1) returned if element was removed and (RInt 0) if element @@ -1152,6 +1202,15 @@ -> IO (Reply Int) zrem r key member = withState r (\rs -> sendCommand rs (CMBulk ["ZREM", toBS key, toBS member]) >> recv rs) +-- | Variadic form of zrem +-- RInt returned - the number of removed elements +zrem_ :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key + -> [s2] -- ^ values list + -> IO (Reply Int) +zrem_ r key members = withState r (\rs -> sendCommand rs (CMBulk ("ZREM" : toBS key : map toBS members)) >> recv rs) + -- | 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 @@ -1457,6 +1516,16 @@ -> IO (Reply Int) hdel r key field = withState r (\rs -> sendCommand rs (CMBulk ["HDEL", toBS key, toBS field]) >> recv rs) +-- | Variadic form of HDEL +-- +-- RInt returned - number of fields deleted +hdel_ :: (BS s1, BS s2) => + Redis + -> s1 -- ^ key + -> [s2] -- ^ field name + -> IO (Reply Int) +hdel_ r key fields = withState r (\rs -> sendCommand rs (CMBulk ("HDEL" : toBS key : map toBS fields)) >> recv rs) + -- | Atomically sets multiple fields within a hash-typed key -- -- ROk returned @@ -1472,7 +1541,7 @@ -- | Get the values of all specified fields from the hash-typed key -- --- RMulti filled with RBulk replys returned +-- RMulti filled with RBulk replies returned hmget :: (BS s1, BS s2, BS s3) => Redis -> s1 -- ^ target key @@ -1483,14 +1552,26 @@ -- | Increment the field value within a hash by N -- -- RInt returned with new key value -hincrby :: (BS s1, BS s2) => +hincrBy :: (BS s1, BS s2) => Redis -> s1 -- ^ target key -> s2 -- ^ field name -> Int -- ^ increment -> IO (Reply Int) -hincrby r key field n = withState r (\rs -> sendCommand rs (CMBulk ["HINCRBY", toBS key, toBS field, toBS n]) >> recv rs) +hincrBy r key field n = withState r (\rs -> sendCommand rs (CMBulk ["HINCRBY", toBS key, toBS field, toBS n]) >> recv rs) +-- | Increment the field value within a hash by N +-- +-- (RBulk Double) returned with new key value +hincrByFloat :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key + -> s2 -- ^ field name + -> Double -- ^ increment + -> IO (Reply Double) +hincrByFloat r key field n = withState r (\rs -> sendCommand rs (CMBulk ["HINCRBYFLOAT", toBS key, toBS field, toBS n]) >> recv rs) + + -- | Test if hash contains the specified field -- -- (RInt 1) returned if fiels exists and (RInt 0) otherwise @@ -1539,13 +1620,13 @@ hgetall r key = withState r (\rs -> sendCommand rs (CMBulk ["HGETALL", toBS key]) >> recv rs) -- | Options data type for the 'sort' command -data BS s => SortOptions s = SortOptions { desc :: Bool, -- ^ sort with descending order - limit :: (Int, Int), -- ^ return (from, to) elements - alpha :: Bool, -- ^ sort alphabetically - sort_by :: s, -- ^ sort by value from this key - get_obj :: [s], -- ^ return this keys values - store :: s -- ^ store result to this key - } +data SortOptions s = SortOptions { desc :: Bool, -- ^ sort with descending order + limit :: (Int, Int), -- ^ return (from, to) elements + alpha :: Bool, -- ^ sort alphabetically + sort_by :: s, -- ^ sort by value from this key + get_obj :: [s], -- ^ return this keys values + store :: s -- ^ store result to this key + } -- | Default options for the 'sort' command sortDefaults :: SortOptions ByteString diff --git a/Database/Redis/Utils/Lock.hs b/Database/Redis/Utils/Lock.hs --- a/Database/Redis/Utils/Lock.hs +++ b/Database/Redis/Utils/Lock.hs @@ -1,23 +1,6 @@ {- -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. +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT -} -- | Emulating locking primitives diff --git a/Database/Redis/Utils/Monad/Lock.hs b/Database/Redis/Utils/Monad/Lock.hs --- a/Database/Redis/Utils/Monad/Lock.hs +++ b/Database/Redis/Utils/Monad/Lock.hs @@ -1,23 +1,6 @@ {- -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. +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT -} -- | Same as "Database.Redis.Utils.Lock" but with monadic wrapped diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2010-2011, 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. diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1,6 +1,16 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + +{-# LANGUAGE CPP #-} module Test where +#if __GLASGOW_HASKELL__ < 702 import System (getArgs) +#else +import System.Environment (getArgs) +#endif import System.Exit (exitFailure, exitSuccess) import System.Environment import System.Console.GetOpt @@ -59,8 +69,10 @@ main :: IO () main = do args <- getArgs + when (length args == 0) $ do putStrLn $ usageInfo "Usage: " options + exitSuccess - (opts, label) <- case getOpt RequireOrder options args of + (opts, label) <- case getOpt Permute options args of (o, l, []) -> let opts = foldl (flip id) defaultOpts o label | null l = Nothing | otherwise = Just $ head l @@ -79,4 +91,4 @@ when (isJust (optBinary opts)) $ startRedis (fromJust $ optBinary opts) (fromJust $ optConfig opts) runTestTT $ toHUnit $ pushParam opts $ mkTests label - when (isJust (optBinary opts)) shutdownRedis + when (isJust (optBinary opts)) $ shutdownRedis (optHost opts) (optPort opts) diff --git a/Test/CASCommands.hs b/Test/CASCommands.hs --- a/Test/CASCommands.hs +++ b/Test/CASCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.CASCommands where import Test.Setup diff --git a/Test/Connection.hs b/Test/Connection.hs --- a/Test/Connection.hs +++ b/Test/Connection.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.Connection where import Test.Setup diff --git a/Test/GenericCommands.hs b/Test/GenericCommands.hs --- a/Test/GenericCommands.hs +++ b/Test/GenericCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.GenericCommands where import Test.Setup @@ -16,7 +21,8 @@ TLabel "ttl and persist" test_ttl_persist, TLabel "move" test_move, TLabel "flushDb" test_flushDb, - TLabel "flushAll" test_flushAll] + TLabel "flushAll" test_flushAll, + TLabel "variadic del" test_variadic_del] test_unwrap_reply = TCase $ const $ let inline = return $ RInline "foo" @@ -160,3 +166,11 @@ dbsize r >>= fromRInt >>= assertEqual "first database was flushed" 0 select r 1 dbsize r >>= fromRInt >>= assertEqual "and the second database too" 0 + + +test_variadic_del = TCase $ testRedis $ + do r <- ask + liftIO $ do mSet r [("a", "a"), ("b", "b"), ("c", "c")] + del_ r ["a", "c"] >>= fromRInt >>= assertEqual "" 2 + Just k <- keys r "*" >>= fromRMultiBulk + assertEqual "" [Just "b"] k diff --git a/Test/HashCommands.hs b/Test/HashCommands.hs --- a/Test/HashCommands.hs +++ b/Test/HashCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + {-# LANGUAGE PackageImports #-} module Test.HashCommands where @@ -13,7 +18,9 @@ TLabel "hlen" test_hlen, TLabel "hexists, hset, hget and hdel" test_hexists_hset_hget_hdel, TLabel "hmset and hmget" test_hmset_hmget, - TLabel "hincrby" test_hincrby] + TLabel "hincrBy" test_hincrBy, + TLabel "variadic hdel" test_variadic_hdel, + TLabel "hincrByFloat" test_hincrByFloat] asHash :: Reply String -> IO (Map String String) asHash r = fromRMultiBulk r >>= return . M.fromList . build . map fromJust . fromJust @@ -85,13 +92,34 @@ h' <- hgetall r "hash" >>= asHash assertEqual "" expected h' -test_hincrby = TCase $ testRedis $ +test_hincrBy = TCase $ testRedis $ do r <- ask addHash liftIO $ do h <- hgetall r "hash" >>= asHash >>= return . M.map read :: IO (Map String Int) - res <- hincrby r "hash" "foo" 2 >>= fromRInt + res <- hincrBy r "hash" "foo" 2 >>= fromRInt assertEqual "" (h ! "foo" + 2) res hget r "hash" "foo" >>= fromRBulk >>= assertEqual "" (Just res) - res <- hincrby r "hash" "foo" (-2) >>= fromRInt + res <- hincrBy r "hash" "foo" (-2) >>= fromRInt + assertEqual "" (h ! "foo") res + hget r "hash" "foo" >>= fromRBulk >>= assertEqual "" (Just res) + +test_variadic_hdel = TCase $ testRedis $ + do r <- ask + addHash + liftIO $ do res <- hdel_ r "hash" ["foo", "bar", "nope"] >>= fromRInt + assertEqual "2 fields deleted" 2 res + res <- hkeys r "hash" >>= fromRMultiBulk >>= return . fromJust + assertEqual "Only baz field remains" [Just "baz"] res + res <- hdel_ r "hash" ([] :: [String]) + assertRError "Empty field list leads to error" res + +test_hincrByFloat = TCase $ testRedis $ + do r <- ask + addHash + liftIO $ do h <- hgetall r "hash" >>= asHash >>= return . M.map read :: IO (Map String Double) + res <- hincrByFloat r "hash" "foo" 0.2 >>= fromRBulk >>= return . fromJust + assertEqual "" (h ! "foo" + 0.2) res + hget r "hash" "foo" >>= fromRBulk >>= assertEqual "" (Just res) + res <- hincrByFloat r "hash" "foo" (-0.2) >>= fromRBulk >>= return . fromJust assertEqual "" (h ! "foo") res hget r "hash" "foo" >>= fromRBulk >>= assertEqual "" (Just res) diff --git a/Test/ListCommands.hs b/Test/ListCommands.hs --- a/Test/ListCommands.hs +++ b/Test/ListCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.ListCommands where import Prelude hiding ((!!)) @@ -16,7 +21,8 @@ TLabel "rpoplpush" test_rpoplpush, TLabel "blpop" test_blpop, TLabel "brpop" test_brpop, - TLabel "brpoplpush" test_brpoplpush] + TLabel "brpoplpush" test_brpoplpush, + TLabel "variadic lpush and rpush" test_variadic_lpush_rpush] test_lrange = TCase $ testRedis $ do r <- ask @@ -183,3 +189,10 @@ exists r1 "zap" >>= fromRInt >>= assertEqual "" 0 (brpoplpush r1 "zap" "list" 1 :: IO (Maybe (Maybe String))) >>= assertEqual "" Nothing + +test_variadic_lpush_rpush = TCase $ testRedis $ + do r <- ask + liftIO $ do lpush_ r "list" ["1", "2"] + rpush_ r "list" ["3", "4"] + Just list <- lrange r "list" takeAll >>= fromRMultiBulk + assertEqual "" [Just "2", Just "1", Just "3", Just "4"] list diff --git a/Test/Lock.hs b/Test/Lock.hs --- a/Test/Lock.hs +++ b/Test/Lock.hs @@ -1,6 +1,10 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.Lock where import Test.Setup - tests = TList [TLabel "acquire and release" test_acquire_release, TLabel "acquire timeout" test_acquire_timeout] diff --git a/Test/Monad/CASCommands.hs b/Test/Monad/CASCommands.hs --- a/Test/Monad/CASCommands.hs +++ b/Test/Monad/CASCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.Monad.CASCommands where import Database.Redis.Monad diff --git a/Test/Monad/MultiCommands.hs b/Test/Monad/MultiCommands.hs --- a/Test/Monad/MultiCommands.hs +++ b/Test/Monad/MultiCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + {-# LANGUAGE ScopedTypeVariables #-} module Test.Monad.MultiCommands where diff --git a/Test/MultiCommands.hs b/Test/MultiCommands.hs --- a/Test/MultiCommands.hs +++ b/Test/MultiCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.MultiCommands where import Test.Setup diff --git a/Test/PubSubCommands.hs b/Test/PubSubCommands.hs --- a/Test/PubSubCommands.hs +++ b/Test/PubSubCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.PubSubCommands where import Test.Setup diff --git a/Test/SetCommands.hs b/Test/SetCommands.hs --- a/Test/SetCommands.hs +++ b/Test/SetCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.SetCommands where import Data.Set @@ -13,7 +18,9 @@ TLabel "srandmember" test_srandmember, TLabel "sinter and sinterStore" test_sinter_sinterstore, TLabel "sunion and sunionStore" test_sunion_sunionstore, - TLabel "sdiff and sdiffStore" test_sdiff_sdiffstore] + TLabel "sdiff and sdiffStore" test_sdiff_sdiffstore, + TLabel "variadic sadd" test_variadic_sadd, + TLabel "variadic srem" test_variadic_srem] asSet :: Reply String -> IO (Set (Maybe String)) asSet r = fromRMultiBulk r >>= return . fromList . fromJust @@ -116,3 +123,17 @@ sdiffStore r "set3" ["set", "set2"] >>= fromRInt >>= assertEqual "" (size s3) smembers r "set3" >>= asSet >>= assertEqual "" s3 sdiffStore r "set3" ["set", "set4"] >>= fromRInt >>= assertEqual "" (size s) + +test_variadic_sadd = TCase $ testRedis $ + do r <- ask + liftIO $ do sadd_ r "set2" ["1", "2", "3"] + s2 <- smembers r "set2" >>= asSet + assertEqual "" (fromList [Just "1", Just "2", Just "3"]) s2 + +test_variadic_srem = TCase $ testRedis $ + do r <- ask + addSet + liftIO $ do res <- srem_ r "set" ["1", "3", "5"] >>= fromRInt + assertEqual "Two elements removed" 2 res + res <- smembers r "set" >>= asSet + assertEqual "" (fromList [Just "2"]) res diff --git a/Test/Setup.hs b/Test/Setup.hs --- a/Test/Setup.hs +++ b/Test/Setup.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + {-# LANGUAGE FlexibleContexts, PackageImports #-} module Test.Setup ( startRedis, @@ -69,9 +74,9 @@ threadDelay $ 10000 return () -shutdownRedis = do r <- connect localhost defaultPort - shutdown r - return () +shutdownRedis host port = do r <- connect host port + shutdown r + return () testRedis :: (ReaderT Redis IO ()) -> Opts -> IO () testRedis t opts = bracket setup teardown $ runReaderT t diff --git a/Test/SortCommands.hs b/Test/SortCommands.hs --- a/Test/SortCommands.hs +++ b/Test/SortCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.SortCommands where import Data.Char (toUpper) diff --git a/Test/StringCommands.hs b/Test/StringCommands.hs --- a/Test/StringCommands.hs +++ b/Test/StringCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + module Test.StringCommands where import Test.Setup @@ -16,7 +21,8 @@ TLabel "setrange" test_setrange, TLabel "getbit" test_getbit, TLabel "setbit" test_setbit, - TLabel "strlen" test_strlen] + TLabel "strlen" test_strlen, + TLabel "incrByFloat" test_incrByFloat] test_set_get = TCase $ testRedis $ do r <- ask @@ -58,7 +64,6 @@ test_incr_decr = TCase $ testRedis $ do r <- ask - addStr liftIO $ do set r "i" (0 :: Int) >>= fromROk incr r "i" >>= fromRInt >>= assertEqual "" 1 (get r "i" :: IO (Reply String)) >>= fromRBulk >>= assertEqual "" (Just "1") @@ -124,3 +129,9 @@ addStr liftIO $ do Just foo <- get r "foo" >>= fromRBulk strlen r "foo" >>= fromRInt >>= assertEqual ("lenght of \"" ++ foo ++ "\"" ) (length foo) + +test_incrByFloat = TCase $ testRedis $ + do r <- ask + liftIO $ do set r "a" (1 :: Int) >>= noError + incrByFloat r "a" 0.2 >>= fromRBulk >>= assertEqual "" (Just (1.0 + 0.2)) + get r "a" >>= fromRBulk >>= assertEqual "" (Just (1.0 + 0.2 :: Double)) diff --git a/Test/Utils.hs b/Test/Utils.hs --- a/Test/Utils.hs +++ b/Test/Utils.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + {-# LANGUAGE CPP #-} module Test.Utils where diff --git a/Test/ZSetCommands.hs b/Test/ZSetCommands.hs --- a/Test/ZSetCommands.hs +++ b/Test/ZSetCommands.hs @@ -1,3 +1,8 @@ +{- +Copyright (c) 2010-2011, Alexander Bogdanov +License: MIT +-} + {-# LANGUAGE PackageImports #-} module Test.ZSetCommands where @@ -17,7 +22,8 @@ TLabel "zrank and zrevrank" test_zrank_zrevrank, TLabel "zremrangebyrank" test_zremrangebyrank, TLabel "zunionStore" test_zunionStore, - TLabel "zinterStore" test_zinterStore] + TLabel "zinterStore" test_zinterStore, + TLabel "variadic zadd and zrem" test_variadic_zadd_zrem] asZSet :: Reply String -> IO [(String, Double)] asZSet r = fromRMultiBulk r >>= return . build . map fromJust . fromJust @@ -189,3 +195,13 @@ assertEqual "" (length expected) res z' <- zrange r "zset3" takeAll True >>= asZSet assertEqual "" expected z' + +test_variadic_zadd_zrem = TCase $ testRedis $ + do r <- ask + liftIO $ do res <- zadd_ r "zset" (zip (map fromIntegral [1..]) ["1", "2", "3", "4"]) >>= fromRInt + assertEqual "Four elements added" 4 res + res <- zrem_ r "zset" ["2", "3", "5"] >>= fromRInt + assertEqual "Two elements removed" 2 res + Just res <- zrange r "zset" takeAll True >>= fromRMultiBulk + assertEqual "" [Just "1", Just "1", Just "4", Just "4"] res + diff --git a/redis.cabal b/redis.cabal --- a/redis.cabal +++ b/redis.cabal @@ -1,5 +1,5 @@ Name: redis -Version: 0.11 +Version: 0.12 License: MIT Maintainer: Alexander Bogdanov Author: Alexander Bogdanov @@ -11,11 +11,11 @@ key-value store. It is often referred as a data structure server since keys can contain different data structures, such as strings, hashes, lists, sets and sorted sets. - . + . This library is a Haskell driver for Redis. It's tested with - current git version and with v2.2.4 of redis server. It also - tested with v2.0.5 and basic functions are works correctly but not - all of them. + current git version and with v2.4.6 of redis server. It also + tested with v2.2 and v2.0 and basic functions are works correctly + but not all of them. . You can use Test module from the source package to run unit tests. Try /runhaskell Test.hs --help/ for usage info. Caution! Do not @@ -28,28 +28,23 @@ . Please let me know if tests or benchmark goes terribly wrong. . - Changes from v0.10: - . - - Simple optimisation of redis protocol replays parsing that leads to - significant speed improvement on get-like commands - . - - New commandline options for test runner (see above) + Changes from v0.11: . - - Simple benchmark included (see above) + - Drop parsec dependency . - - New commands implemented: brpoplpush (blocking rpoplpush), - getrange, setrange, getbit and setbit + - New commands implemented: incrbyfloat and hincrbyfloat . - - getType reply is now parsed into RedisKeyType datatype instead - of just returning Reply. Warning! It's backward incompatible! + - Added variadic versions of del, hdel, lpush, rpush, sadd, srem, + zadd, zrem (named as del_, hdel_ etc.) . - - info reply is now parsed into Map String String. Warning! It's - backward incompatible! + - Fixed compilation with GHC 7.2 (and hopefully with more recent + versions too), thanks Ben Gamari and Sean Hess for reporting. . Stability: beta Build-Type: Simple Cabal-Version: >= 1.4 +License-File: LICENSE Extra-Source-Files: Test.hs, Test/CASCommands.hs, Test/ListCommands.hs, @@ -65,7 +60,7 @@ Library Build-Depends: base < 5, containers, bytestring, utf8-string, - network, mtl, old-time, MonadCatchIO-mtl, parsec + network, mtl, old-time, MonadCatchIO-mtl Exposed-modules: Database.Redis.Redis Database.Redis.Monad Database.Redis.ByteStringClass