redis 0.10.1 → 0.11
raw patch · 27 files changed
+819/−458 lines, 27 filesdep +parsec
Dependencies added: parsec
Files
- Benchmark.hs +121/−0
- Database/Redis/ByteStringClass.hs +3/−1
- Database/Redis/Info.hs +35/−0
- Database/Redis/Internal.hs +14/−6
- Database/Redis/Monad.hs +30/−10
- Database/Redis/Monad/State.hs +2/−2
- Database/Redis/Redis.hs +115/−20
- Test.hs +59/−23
- Test/CASCommands.hs +14/−21
- Test/Connection.hs +12/−19
- Test/GenericCommands.hs +61/−64
- Test/HashCommands.hs +16/−20
- Test/ListCommands.hs +44/−29
- Test/Lock.hs +5/−14
- Test/Monad/CASCommands.hs +5/−12
- Test/Monad/MultiCommands.hs +5/−12
- Test/MultiCommands.hs +8/−15
- Test/PubSubCommands.hs +8/−14
- Test/SetCommands.hs +22/−27
- Test/Setup.hs +76/−23
- Test/SortCommands.hs +12/−17
- Test/StringCommands.hs +59/−25
- Test/ZSetCommands.hs +25/−29
- redis-2.0.conf +18/−0
- redis-2.2.conf +20/−0
- redis.cabal +30/−34
- redis.conf +0/−21
+ Benchmark.hs view
@@ -0,0 +1,121 @@+import System (getArgs)+import System.Exit (exitFailure, exitSuccess)+import System.Console.GetOpt+import Data.Time.Clock+import Database.Redis.Redis+import Control.Concurrent.MVar+import Control.Concurrent+import Control.Monad (when)++makeConnections :: Int -> String -> String -> Int -> IO [Redis]+makeConnections count host port db = mapM mkConn [0 .. (count - 1)]+ where mkConn n = do r <- connect host port+ select r db+ return r++-- Worker :: Redis -> worker prefix -> loop number -> lock -> unlock -> IO ()+type Worker = Redis -> String -> Int -> MVar () -> MVar () -> IO ()++-- 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+ where fork (n, r) = do lock <- newEmptyMVar+ unlock <- newEmptyMVar+ if n < workers - 1+ then forkIO $ worker r (prefix n) count lock unlock+ else forkIO $ worker r (prefix n) (loops - (count * (workers - 1))) lock unlock+ return (lock, unlock)+ count = loops `quot` (workers - 1)+ workers = length rs+ prefix n = (show n) ++ ":"++printResult name loops t = do putStrLn $ name ++ ": " ++ (show t)+ putStrLn $ (show $ (fromIntegral loops) / t) ++ " per second"++worker_set :: Worker+worker_set r x n l u = do takeMVar l+ loop sets+ putMVar u ()+ where sets = zip keys vals+ keys = map ((x ++) . show) [1..n]+ vals = [1..n]+ loop [] = return ()+ loop ((k, v) : s) = set r k v >> loop s++worker_get :: Worker+worker_get r x n l u = do takeMVar l+ loop keys+ putMVar u ()+ where keys = map ((x ++) . show) [1..n]+ loop [] = return ()+ loop (k:s) = (get r k :: IO (Reply ())) >> loop s++worker_lpush :: Worker+worker_lpush r x n l u = do takeMVar l+ loop vals+ putMVar u ()+ where vals = [1..n]+ key = x ++ "lst"+ loop = mapM_ (lpush r key)++worker_lpop :: Worker+worker_lpop r x n l u = do takeMVar l+ loop n+ putMVar u ()+ where key = x ++ "lst"+ loop n = mapM_ (\_ -> lpop r key :: IO (Reply ())) [1..n]++data Opt = Opt { optHost :: String,+ optPort :: String,+ optDatabase :: Int,+ optClients :: Int,+ optRequests :: Int,+ optHelp :: Bool}+ deriving Show++defaultOpts = Opt localhost defaultPort 6 50 100000 False++options :: [OptDescr (Opt -> Opt)]+options = [Option ['h'] ["host"] (OptArg (maybe id (\h o -> o{optHost = h})) "HOSTNAME") ("Server hostname (default " ++ localhost ++ ")"),+ Option ['p'] ["port"] (OptArg (maybe id (\p o -> o{optPort = p})) "PORT") ("Server port (default " ++ defaultPort ++ ")"),+ Option ['d'] ["database"] (OptArg (maybe id (\d o -> o{optDatabase = read d})) "DATABASE") "Database number (default 6)",+ Option ['c'] ["clients"] (OptArg (maybe id (\c o -> o{optClients = read c})) "CLIENTS") "Number of parallel connections (default 50)",+ Option ['n'] ["requests"] (OptArg (maybe id (\n o -> o{optRequests = read n})) "REQUESTS") "Total number of requests (default 100000)",+ Option [] ["help"] (NoArg (\o -> o{optHelp = True})) "Show this usage info"]++main :: IO ()+main = do args <- getArgs+ opts <- case getOpt RequireOrder options args of+ (o, [], []) -> return $ foldl (flip id) defaultOpts o+ (_, n, []) -> do putStrLn $ "Unrecognized arguments: " ++ concat n ++ usageInfo "\nUsage: " options+ exitFailure+ (_, _, es) -> do putStrLn $ concat es ++ usageInfo "\nUsage:" options+ exitFailure++ when (optHelp opts) $ do putStrLn $ usageInfo "Usage:" options+ exitSuccess++ r <- connect (optHost opts) (optPort opts)+ select r $ optDatabase opts+ flushDb r++ rs <- makeConnections (optClients opts) (optHost opts) (optPort opts) (optDatabase opts)++ t <- runWorkers rs (optRequests opts) worker_set+ printResult "set" (optRequests opts) t++ t <- runWorkers rs (optRequests opts) worker_get+ printResult "get" (optRequests opts) t++ t <- runWorkers rs (optRequests opts) worker_lpush+ printResult "lpush" (optRequests opts) t++ t <- runWorkers rs (optRequests opts) worker_lpop+ printResult "lpop" (optRequests opts) t++ putStrLn "Done."
Database/Redis/ByteStringClass.hs view
@@ -3,8 +3,10 @@ import Prelude hiding (concat) import Data.ByteString+import Data.ByteString.Char8 (readInt) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as U+import Data.Maybe (fromJust) -- | Utility class for conversion to and from Strict ByteString class BS a where@@ -29,7 +31,7 @@ instance BS Int where toBS = U.fromString . show- fromBS = read . U.toString+ fromBS = fst . fromJust . readInt instance BS Double where toBS = U.fromString . show
+ Database/Redis/Info.hs view
@@ -0,0 +1,35 @@+module Database.Redis.Info (+ RedisInfo, parseInfo+) where++import Text.Parsec+import Data.Map++import Database.Redis.ByteStringClass++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++infoLine :: Parsec String RedisInfo ()+infoLine = emptyLine <|> commentLine <|> keyLine++emptyLine :: Parsec String RedisInfo ()+emptyLine = skipMany (oneOf [' ', '\t', '\r']) >> newline >> return ()++commentLine :: Parsec String RedisInfo ()+commentLine = char '#' >> skipMany (noneOf ['\n']) >> newline >> return ()++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
Database/Redis/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module Database.Redis.Internal where import Prelude hiding (putStrLn, putStr, catch)@@ -9,17 +9,24 @@ import System.IO.UTF8 (putStrLn, putStr) import qualified Data.ByteString as B import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()+import Data.ByteString.Char8 (readInt) import qualified Data.ByteString.UTF8 as U import Data.Maybe (fromJust, isNothing, isJust) import Data.List (intersperse) import qualified Data.Map as Map import Data.Map (Map(..)) import Control.Monad (when)-import Control.Exception (block, bracket, bracketOnError, catch, SomeException)+import Control.Exception (bracket, bracketOnError, catch, SomeException) import Database.Redis.ByteStringClass +#if __GLASGOW_HASKELL__ < 700+import Control.Exception (block)+#else+import Control.Exception.Base (mask)+block f = mask $ \ _ -> f+#endif+ tracebs = putStrLn . U.toString tracebs' = putStr . U.toString @@ -96,6 +103,7 @@ uasterisk = U.fromString "*" hPutRn h = B.hPut h urn+{-# INLINE hPutRn #-} takeState :: Redis -> IO RedisState takeState r = block $ do lcnt <- takeMVar $ r_lock_cnt r@@ -232,11 +240,11 @@ _ -> safeFromBS RInline rest -- recv_int :: ByteString -> IO Reply- recv_int rest = let reply = read (U.toString rest) :: Int+ recv_int rest = let reply = fst $ fromJust $ readInt rest in return $ RInt reply -- recv_bulk :: ByteString -> IO Reply- recv_bulk rest = let size = read (U.toString rest) :: Int+ recv_bulk rest = let size = fst $ fromJust $ readInt rest in do body <- recv_bulk_body size maybe (return $ RBulk Nothing) (safeFromBS (RBulk . Just)) body @@ -247,7 +255,7 @@ return $ Just reply -- recv_multi :: ByteString -> IO Reply- recv_multi rest = let cnt = read (U.toString rest) :: Int+ recv_multi rest = let cnt = fst $ fromJust $ readInt rest in do bulks <- recv_multi_n cnt return $ RMulti bulks
Database/Redis/Monad.hs view
@@ -20,7 +20,7 @@ THE SOFTWARE. -} -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, PackageImports #-} -- | Monadic wrapper for "Database.Redis.Redis" module Database.Redis.Monad (@@ -34,6 +34,8 @@ R.IsInterval(..), R.SortOptions(..), R.Aggregate(..),+ R.RedisKeyType,+ R.RedisInfo, R.sortDefaults, R.fromRInline, R.fromRBulk, R.fromRMulti, R.fromRMultiBulk,@@ -59,13 +61,14 @@ get, getSet, mGet, incr, incrBy, decr, decrBy, append, substr,- strlen,+ getrange, setrange,+ getbit, setbit,strlen, -- ** Lists rpush, lpush, rpushx, lpushx, llen, lrange, ltrim, lindex, lset, lrem, lpop, rpop,- rpoplpush, blpop, brpop,+ rpoplpush, blpop, brpop, brpoplpush, -- ** Sets sadd, srem, spop, smove, scard, sismember,@@ -97,11 +100,8 @@ ) where -import Control.Monad.Trans-import qualified Control.Monad.State as St-import Control.Monad.State (StateT(..))-import Control.Applicative-import Control.Monad.CatchIO+import "mtl" Control.Monad.Trans+import "MonadCatchIO-mtl" Control.Monad.CatchIO import Data.ByteString (ByteString) import qualified Database.Redis.Redis as R@@ -195,7 +195,7 @@ del :: (WithRedis m, BS s) => s -> m (R.Reply Int) del key = getRedis >>= liftIO . flip R.del key -getType :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)+getType :: (WithRedis m, BS s1) => s1 -> m R.RedisKeyType getType key = getRedis >>= liftIO . flip R.getType key keys :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)@@ -242,7 +242,7 @@ flushAll :: WithRedis m => m (R.Reply ()) flushAll = getRedis >>= liftIO . R.flushAll -info :: (WithRedis m, BS s) => m (R.Reply s)+info :: WithRedis m => m R.RedisInfo info = getRedis >>= liftIO . R.info set :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply ())@@ -295,6 +295,22 @@ substr key range = do r <- getRedis liftIO $ R.substr r key range +getrange :: (WithRedis m, BS s1, BS s2) => s1 -> (Int, Int) -> m (R.Reply s2)+getrange key range = do r <- getRedis+ liftIO $ R.getrange r key range++setrange :: (WithRedis m, BS s1, BS s2) => s1 -> Int -> s2 -> m (R.Reply Int)+setrange key offset val = do r <- getRedis+ liftIO $ R.setrange r key offset val++getbit :: (WithRedis m, BS s) => s -> Int -> m (R.Reply Int)+getbit key offset = do r <- getRedis+ liftIO $ R.getbit r key offset++setbit :: (WithRedis m, BS s) => s -> Int -> Int -> m (R.Reply Int)+setbit key offset bit = do r <- getRedis+ liftIO $ R.setbit r key offset bit+ strlen :: (WithRedis m, BS s) => s -> m (R.Reply Int) strlen key = getRedis >>= liftIO . flip R.strlen key @@ -358,6 +374,10 @@ brpop :: (WithRedis m, BS s1, BS s2) => [s1] -> Int -> m (Maybe (s1, s2)) brpop keys timeout = do r <- getRedis liftIO $ R.brpop r keys timeout++brpoplpush :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> s2 -> Int -> m (Maybe (Maybe s3))+brpoplpush src dst timeout = do r <- getRedis+ liftIO $ R.brpoplpush r src dst timeout sadd :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) sadd key val = do r <- getRedis
Database/Redis/Monad/State.hs view
@@ -20,12 +20,12 @@ THE SOFTWARE. -} -{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE PackageImports, TypeSynonymInstances #-} -- | This module is mainly an example of posible 'WithRedis' -- implementation module Database.Redis.Monad.State where -import Control.Monad.State+import "mtl" Control.Monad.State import Database.Redis.Monad (WithRedis(..), Redis) -- | Trivial WithRedis instance storing Redis descriptor in StateT
Database/Redis/Redis.hs view
@@ -34,6 +34,8 @@ IsInterval(..), SortOptions(..), Aggregate(..),+ RedisKeyType(..),+ RedisInfo, sortDefaults, fromRInline, fromRBulk, fromRBulk', fromRMulti, fromRMultiBulk, fromRMultiBulk', fromRInt,@@ -59,13 +61,14 @@ get, getSet, mGet, incr, incrBy, decr, decrBy, append, substr,- strlen,+ getrange, setrange,+ getbit, setbit, strlen, -- ** Lists rpush, lpush, rpushx, lpushx, linsert, llen, lrange, ltrim, lindex, lset, lrem, lpop, rpop,- rpoplpush, blpop, brpop,+ rpoplpush, blpop, brpop, brpoplpush, -- ** Sets sadd, srem, spop, smove, scard, sismember,@@ -102,6 +105,7 @@ import qualified Network.Socket as S import qualified System.IO as IO import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8 (unpack, pack) import Data.ByteString (ByteString) import Data.Maybe (fromJust, isNothing) import Data.List (intersperse)@@ -110,6 +114,7 @@ import Control.Exception (onException) import Database.Redis.ByteStringClass+import Database.Redis.Info import Database.Redis.Internal -- | default Redis port@@ -340,7 +345,7 @@ -- | Add keys to a watch list for Check-and-Set operation. ----- For more information see <http://code.google.com/p/redis/wiki/MultiExecCommand>+-- For more information see <http://redis.io/topics/transactions> -- -- ROk returned watch :: BS s =>@@ -351,7 +356,7 @@ -- | Force unwatch all watched keys ----- For more information see <http://code.google.com/p/redis/wiki/MultiExecCommand>+-- For more information see <http://redis.io/topics/transactions> -- -- ROk returned unwatch :: Redis -> IO (Reply ())@@ -398,14 +403,28 @@ -> IO (Reply Int) del r key = withState r (\rs -> sendCommand rs (CMBulk ["DEL", toBS key]) >> recv rs) ++data RedisKeyType = RTNone | RTString | RTList | RTSet | RTZSet | RTHash+ deriving (Show, Eq)++parseType :: ByteString -> RedisKeyType+parseType "none" = RTNone+parseType "string" = RTString+parseType "list" = RTList+parseType "set" = RTSet+parseType "zset" = RTZSet+parseType "hash" = RTHash+parseType s = error $ "unknown key type: " ++ (B8.unpack s)+ -- | Return the type of the value stored at key in form of a string ----- RInline with one of "none", "string", "list", "set", "zset", "hash" returned-getType :: (BS s1, BS s2) =>+-- RedisKeyType returned+getType :: BS s => Redis- -> s1 -- ^ target key- -> IO (Reply s2)-getType r key = withState r (\rs -> sendCommand rs (CMBulk ["TYPE", toBS key]) >> recv rs)+ -> s -- ^ target key+ -> IO RedisKeyType+getType r key = withState r (\rs -> sendCommand rs (CMBulk ["TYPE", toBS key]) >> recv rs+ >>= fromRInline >>= return . parseType) -- | Returns all the keys matching the glob-style pattern@@ -452,7 +471,7 @@ -- | Set an expiration timeout in seconds on the specified key. ----- For more information see <http://code.google.com/p/redis/wiki/ExpireCommand>+-- For more information see <http://redis.io/commands/expire> -- -- (RInt 1) returned if timeout was set and (RInt 0) otherwise expire :: BS s =>@@ -464,7 +483,7 @@ -- | Set an expiration time in form of UNIX timestamp on the specified key ----- For more information see <http://code.google.com/p/redis/wiki/ExpireCommand>+-- For more information see <http://redis.io/commands/expireat> -- -- (RInt 1) returned if timeout was set and (RInt 0) otherwise expireAt :: BS s =>@@ -530,11 +549,14 @@ {- UNTESTED -} -- | Returns different information and statistics about the server ----- for more information see <http://code.google.com/p/redis/wiki/InfoCommand>+-- for more information see <http://redis.io/commands/info> ----- RBulk returned-info :: BS s => Redis -> IO (Reply s)-info r = withState r (\rs -> sendCommand rs (CInline "INFO") >> recv rs)+-- '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" -- | Set the string value as value of the key --@@ -683,6 +705,61 @@ -> IO (Reply s2) substr r key (from, to) = withState r (\rs -> sendCommand rs (CMBulk ["SUBSTR", toBS key, toBS from, toBS to]) >> recv rs) +-- | Returns the substring of the string value stored at key,+-- determined by the offsets start and end (both are+-- inclusive). Negative offsets can be used in order to provide an+-- offset starting from the end of the string.+--+-- RBulk returned+getrange :: (BS s1, BS s2) =>+ Redis+ -> s1 -- ^ target key+ -> (Int, Int) -- ^ (start, end)+ -> IO (Reply s2)+getrange r key (from, to) = withState r (\rs -> sendCommand rs (CMBulk ["GETRANGE", toBS key, toBS from, toBS to]) >> recv rs)++-- | Overwrites part of the string stored at key, starting at the+-- specified offset, for the entire length of value. If the offset is+-- larger than the current length of the string at key, the string is+-- padded with zero-bytes to make offset fit. Non-existing keys are+-- considered as empty strings, so this command will make sure it+-- holds a string large enough to be able to set value at offset.+--+-- RInt returned - resulting string length.+setrange :: (BS s1, BS s2) =>+ Redis+ -> s1 -- ^ target key+ -> Int -- ^ offset+ -> s2 -- ^ value+ -> IO (Reply Int)+setrange r key offset val = withState r (\rs -> sendCommand rs (CMBulk ["SETRANGE", toBS key, toBS offset, toBS val]) >> recv rs)++-- | Returns the bit value at offset in the string value stored at+-- key. When offset is beyond the string length, the string is assumed+-- to be a contiguous space with 0 bits. When key does not exist it is+-- assumed to be an empty string, so offset is always out of range and+-- the value is also assumed to be a contiguous space with 0 bits.+--+-- RInt returned+getbit :: (BS s) =>+ Redis+ -> s -- ^ target key+ -> Int -- ^ bit offset+ -> IO (Reply Int)+getbit r key offset = withState r (\rs -> sendCommand rs (CMBulk ["GETBIT", toBS key, toBS offset]) >> recv rs)++-- | Sets or clears the bit at offset in the string value stored at key.+-- For more information see <http://redis.io/commands/setbit>+--+-- RInt returned - the original bit value stored at offset.+setbit :: (BS s) =>+ Redis+ -> s -- ^ target key+ -> Int -- ^ bit offset+ -> Int -- ^ bit value - 0 or 1+ -> IO (Reply Int)+setbit r key offset bit = withState r (\rs -> sendCommand rs (CMBulk ["SETBIT", toBS key, toBS offset, toBS bit]) >> recv rs)+ -- | Returns a length of a string-typed key -- -- RInt returned@@ -857,9 +934,9 @@ -- | Blocking lpop ----- For more information see <http://code.google.com/p/redis/wiki/BlpopCommand>+-- For more information see <http://redis.io/commands/blpop> ----- RMulti returned filled with key name and popped value+-- Return (Just (key, value)) if /value/ was successfully popped from /key/ list or Nothing of timeout exceeded. blpop :: (BS s1, BS s2) => Redis -> [s1] -- ^ keys list@@ -873,9 +950,9 @@ -- | Blocking rpop ----- For more information see <http://code.google.com/p/redis/wiki/BlpopCommand>+-- For more information see <http://redis.io/commands/brpop> ----- RMulti returned filled with key name and popped value+-- Return (Just (key, value)) if /value/ was successfully popped from /key/ list or Nothing of timeout exceeded. brpop :: (BS s1, BS s2) => Redis -> [s1] -- ^ keys list@@ -887,6 +964,24 @@ Nothing -> Nothing Just [Just k, Just v] -> Just (fromBS k, fromBS v) +-- | Blocking rpoplpush+--+-- For more information see <http://redis.io/commands/brpoplpush>+--+-- Return (Just $ Maybe value) if value was successfully popped or Nothing if timeout exceeded.+brpoplpush :: (BS s1, BS s2, BS s3) =>+ Redis+ -> s1 -- ^ source key+ -> s2 -- ^ destination key+ -> Int -- ^ timeout+ -> IO (Maybe (Maybe s3))+brpoplpush r src dst timeout = withState r $ \rs -> do sendCommand rs (CMBulk ["BRPOPLPUSH", toBS src, toBS dst, toBS timeout])+ res <- recv rs+ return $ case res of+ RBulk res' -> Just res'+ RMulti Nothing -> Nothing+ _ -> error $ "wrong reply, RBulk or Nil RMulti expected: " ++ show res+ -- | Add the specified member to the set value stored at key -- -- (RInt 1) returned if element was added and (RInt 0) if element was@@ -1463,7 +1558,7 @@ -- | Sort the elements contained in the List, Set, or Sorted Set ----- for more information see <http://code.google.com/p/redis/wiki/SortCommand>+-- for more information see <http://redis.io/commands/sort> -- -- RMulti filled with RBulk returned sort :: (BS s1, BS s2, BS s3) =>
Test.hs view
@@ -1,7 +1,12 @@ module Test where +import System (getArgs)+import System.Exit (exitFailure, exitSuccess) import System.Environment-import Test.HUnit+import System.Console.GetOpt+import Data.Maybe (isJust, isNothing)+import Control.Monad (when)+ import Test.Setup import qualified Test.Connection as Connection import qualified Test.GenericCommands as GenericCommands@@ -18,29 +23,60 @@ import qualified Test.Monad.CASCommands as M_CASCommands import qualified Test.Lock as Lock -tests = [("connection", TestLabel "Connection" Connection.tests),- ("generic", TestLabel "Generic commands" GenericCommands.tests),- ("string", TestLabel "String commands" StringCommands.tests),- ("list", TestLabel "List commands" ListCommands.tests),- ("set", TestLabel "Set commands" SetCommands.tests),- ("zset", TestLabel "Sorted set commands" ZSetCommands.tests),- ("hash", TestLabel "Hash commands" HashCommands.tests),- ("sort", TestLabel "Sort comands" SortCommands.tests),- ("pubsub", TestLabel "Pub/Sub commands" PubSubCommands.tests),- ("multi", TestLabel "Multi commands" MultiCommands.tests),- ("cas", TestLabel "CAS commands" CASCommands.tests),- ("multi", TestLabel "Multi commands within monad wrapper" M_MultiCommands.tests),- ("cas", TestLabel "CAS commands within monad wrapper" M_CASCommands.tests),- ("lock", TestLabel "Lock" Lock.tests)]+tests = [("connection", TLabel "Connection" Connection.tests),+ ("generic", TLabel "Generic commands" GenericCommands.tests),+ ("string", TLabel "String commands" StringCommands.tests),+ ("list", TLabel "List commands" ListCommands.tests),+ ("set", TLabel "Set commands" SetCommands.tests),+ ("zset", TLabel "Sorted set commands" ZSetCommands.tests),+ ("hash", TLabel "Hash commands" HashCommands.tests),+ ("sort", TLabel "Sort comands" SortCommands.tests),+ ("pubsub", TLabel "Pub/Sub commands" PubSubCommands.tests),+ ("multi", TLabel "Multi commands" MultiCommands.tests),+ ("cas", TLabel "CAS commands" CASCommands.tests),+ ("multi", TLabel "Multi commands within monad wrapper" M_MultiCommands.tests),+ ("cas", TLabel "CAS commands within monad wrapper" M_CASCommands.tests),+ ("lock", TLabel "Lock" Lock.tests)] -mkTests Nothing = TestList $ map snd tests-mkTests (Just label) = TestList $ map snd $ filter ((== label) . fst) tests+mkTests Nothing = TList $ map snd tests+mkTests (Just label) = TList $ map snd $ filter ((== label) . fst) tests +defaultOpts :: Opts+defaultOpts = Opts localhost defaultPort 0 Nothing Nothing False++options :: [OptDescr (Opts -> Opts)]+options = [Option ['h'] ["host"] (OptArg (maybe id (\h o -> o{optHost = h})) "HOSTNAME")+ ("Server hostname (default " ++ localhost ++ ")"),+ Option ['p'] ["port"] (OptArg (maybe id (\p o -> o{optPort = p})) "PORT")+ ("Server port (default " ++ defaultPort ++ ")"),+ Option ['d'] ["database"] (OptArg (maybe id (\d o -> o{optDatabase = read d})) "DATABASE")+ "Database number (default 0)",+ Option ['b'] ["binary"] (OptArg (maybe id (\b o -> o{optBinary = Just b})) "PATH")+ "Redis server binary (start this binary for running tests on it)",+ Option ['c'] ["config"] (OptArg (maybe id (\c o -> o{optConfig = Just c})) "PATH")+ "Config file (used with \"binary\" option)",+ Option [] ["help"] (NoArg (\o -> o{optHelp = True})) "Show this usage info"]+ main :: IO () main = do args <- getArgs- if (length args < 1)- then error "Usage: runhaskell Test.hs <path-to-redis-binary> [label]"- else startRedis $ head args- let label = if length args < 2 then Nothing else (Just $ args !! 1)- runTestTT $ mkTests label- shutdownRedis++ (opts, label) <- case getOpt RequireOrder options args of+ (o, l, []) -> let opts = foldl (flip id) defaultOpts o+ label | null l = Nothing+ | otherwise = Just $ head l+ in return (opts, label)+ (_, _, es) -> do putStrLn $ concat es ++ usageInfo "\nUsage:" options+ exitFailure++ when (optHelp opts) $ do putStrLn $ usageInfo "Usage: " options+ exitSuccess++ when (isJust (optBinary opts) && isNothing (optConfig opts))+ $ do putStrLn "Config file must be specified when used with \"binary\" option"+ putStrLn $ usageInfo "\nUsage: " options+ exitFailure++ when (isJust (optBinary opts)) $ startRedis (fromJust $ optBinary opts) (fromJust $ optConfig opts)++ runTestTT $ toHUnit $ pushParam opts $ mkTests label+ when (isJust (optBinary opts)) shutdownRedis
Test/CASCommands.hs view
@@ -1,25 +1,18 @@ module Test.CASCommands where -import Control.Monad.Reader-import Control.Exception-import Control.Concurrent (threadDelay)-import Control.Concurrent.MVar-import Test.HUnit-import Database.Redis.Redis import Test.Setup-import Test.Utils -tests = TestList [TestLabel "watch/exec successful" test_watch_success,- TestLabel "wath/exec fail" test_watch_fail,- TestLabel "run_cas" test_run_cas,- TestLabel "run_cas that raised an exception" test_run_cas_exception]+tests = TList [TLabel "watch/exec successful" test_watch_success,+ TLabel "wath/exec fail" test_watch_fail,+ TLabel "run_cas" test_run_cas,+ TLabel "run_cas that raised an exception" test_run_cas_exception] -test_watch_success = TestCase $ testRedis $+test_watch_success = TCase $ testRedis $ do r <- ask addStr- liftIO $ do watch r ["foo", "bar"]+ liftIO $ do watch r ["foo", "bar"] >>= noError Just foo <- get r "foo" >>= fromRBulk- multi r+ multi r >>= noError set r "foo" "bar" >>= noError set r "foo_" foo >>= noError exec r :: IO (Reply ())@@ -27,13 +20,13 @@ assertEqual "" (Just foo) foo_ get r "foo" >>= fromRBulk >>= assertEqual "" (Just "bar") -test_watch_fail = TestCase $ testRedis2 $+test_watch_fail = TCase $ testRedis2 $ do r1 <- ask r2 <- ask2 addStr- liftIO $ do watch r1 ["foo", "bar"]+ liftIO $ do watch r1 ["foo", "bar"] >>= noError Just foo <- get r1 "foo" >>= fromRBulk :: IO (Maybe String)- multi r1+ multi r1 >>= noError set r2 "foo" "baz" >>= fromROk set r1 "foo" "bar" >>= noError -- note that this statement will not executed set r1 "foo_" foo >>= noError@@ -42,10 +35,10 @@ assertEqual "" Nothing foo_ get r1 "foo" >>= fromRBulk >>= assertEqual "" (Just "baz") -test_run_cas = TestCase $ testRedis2 $+test_run_cas = TCase $ testRedis2 $ let act :: Redis -> IO String act r = do Just foo <- get r "foo" >>= fromRBulk- multi r+ multi r >>= noError threadDelay 1000 set r "foo" "bar" >>= noError set r "foo_" foo >>= noError@@ -67,9 +60,9 @@ assertEqual "" Nothing foo_ get r1 "foo" >>= fromRBulk >>= assertEqual "" (Just "baz") -test_run_cas_exception = TestCase $ testRedis $+test_run_cas_exception = TCase $ testRedis $ let act :: Redis -> IO ()- act r = do multi r+ act r = do multi r >>= noError set r "foo" "bar" >>= noError set r "bar" "foo" >>= noError error "bang!"
Test/Connection.hs view
@@ -1,28 +1,21 @@ module Test.Connection where -import Control.Monad.Reader-import Test.HUnit-import Database.Redis.Redis- import Test.Setup -tests = TestList [TestLabel "connect" test_connect,- TestLabel "connection state" test_connection_state] -test_connect = TestCase $ do r <- connect localhost defaultPort- connected <- isConnected r- assertBool "Connection failed for some reason" connected- disconnect r- connected <- isConnected r- assertBool "Disconnected but still in 'connected' state" $ not connected+tests = TList [TLabel "connect" test_connect,+ TLabel "connection state" test_connection_state] -test_connection_state = TestCase $ testRedis $+test_connect = TCase $ \opts -> do r <- connect (optHost opts) (optPort opts)+ connected <- isConnected r+ assertBool "Connection failed for some reason" connected+ disconnect r+ connected <- isConnected r+ assertBool "Disconnected but still in 'connected' state" $ not connected++test_connection_state = TCase $ \opts -> flip testRedis opts $ do r <- ask liftIO $ do server <- getServer r- assertEqual "Wrong server in connection state" (localhost, defaultPort) server- select r 0- db <- getDatabase r- assertEqual "Wrond database number in connection state" 0 db- select r 1+ assertEqual "Wrong server in connection state" (optHost opts, optPort opts) server db <- getDatabase r- assertEqual "Wrond database number in connection state" 1 db+ assertEqual "Wrond database number in connection state" (optDatabase opts) db
Test/GenericCommands.hs view
@@ -1,59 +1,52 @@ module Test.GenericCommands where -import Control.Monad.Reader-import Control.Exception-import Test.HUnit-import Data.Maybe-import System.Time-import Database.Redis.Redis-import Database.Redis.ByteStringClass import Test.Setup-import Test.Utils -tests = TestList [TestLabel "from*" test_unwrap_reply,- TestLabel "ping and renamed command" test_ping,- TestLabel "echo" test_echo,- TestLabel "exists and del" test_exists_del,- TestLabel "getType" test_get_type,- TestLabel "keys" test_keys,- TestLabel "randomKey" test_random_key,- TestLabel "rename" test_rename,- TestLabel "renameNx" test_renameNx,- TestLabel "dbsize" test_dbsize,- TestLabel "expire" test_expire,- TestLabel "ttl and persist" test_ttl_persist,- TestLabel "move" test_move,- TestLabel "flushDb" test_flushDb,- TestLabel "flushAll" test_flushAll]+tests = TList [TLabel "from*" test_unwrap_reply,+ TLabel "ping and renamed command" test_ping,+ TLabel "echo" test_echo,+ TLabel "exists and del" test_exists_del,+ TLabel "getType" test_get_type,+ TLabel "keys" test_keys,+ TLabel "randomKey" test_random_key,+ TLabel "rename" test_rename,+ TLabel "renameNx" test_renameNx,+ TLabel "dbsize" test_dbsize,+ TLabel "expire" test_expire,+ TLabel "ttl and persist" test_ttl_persist,+ TLabel "move" test_move,+ TLabel "flushDb" test_flushDb,+ TLabel "flushAll" test_flushAll] -test_unwrap_reply = TestCase $ let inline = return $ RInline "foo"- int = return $ RInt 1 :: IO (Reply String)- bulk = return $ RBulk $ Just "foo" - mbulk = return $ RMulti $ Just [RBulk (Just "foo"), RBulk Nothing]- mbulk' = return $ RMulti Nothing :: IO (Reply String)- err = return $ RError "foo" :: IO (Reply String)- in do inline >>= fromRInline >>= assertEqual "" "foo"- int >>= fromRInt >>= assertEqual "" 1- bulk >>= fromRBulk >>= assertEqual "" (Just "foo")- mbulk >>= fromRMulti >>= assertEqual "" (Just [RBulk (Just "foo"), RBulk Nothing])- mbulk' >>= fromRMulti >>= assertEqual "" Nothing- mbulk >>= fromRMultiBulk >>= assertEqual "" (Just [Just "foo", Nothing])- mbulk' >>= fromRMultiBulk >>= assertEqual "" Nothing- mbulk >>= noError >>= assertEqual "" ()- assertRaises "" (ErrorCall undefined) (err >>= fromRInline)- assertRaises "" (ErrorCall undefined) (inline >>= fromRBulk)+test_unwrap_reply = TCase $ const $+ let inline = return $ RInline "foo"+ int = return $ RInt 1 :: IO (Reply String)+ bulk = return $ RBulk $ Just "foo" + mbulk = return $ RMulti $ Just [RBulk (Just "foo"), RBulk Nothing]+ mbulk' = return $ RMulti Nothing :: IO (Reply String)+ err = return $ RError "foo" :: IO (Reply String)+ in do inline >>= fromRInline >>= assertEqual "" "foo"+ int >>= fromRInt >>= assertEqual "" 1+ bulk >>= fromRBulk >>= assertEqual "" (Just "foo")+ mbulk >>= fromRMulti >>= assertEqual "" (Just [RBulk (Just "foo"), RBulk Nothing])+ mbulk' >>= fromRMulti >>= assertEqual "" Nothing+ mbulk >>= fromRMultiBulk >>= assertEqual "" (Just [Just "foo", Nothing])+ mbulk' >>= fromRMultiBulk >>= assertEqual "" Nothing+ mbulk >>= noError >>= assertEqual "" ()+ assertRaises "" (ErrorCall undefined) (err >>= fromRInline)+ assertRaises "" (ErrorCall undefined) (inline >>= fromRBulk) -test_ping = TestCase $ testRedis $+test_ping = TCase $ testRedis $ do r <- ask liftIO $ do renameCommand r (toBS "PING") (toBS "P") -- also tests "renamed command" feature repl <- ping r assertEqual "" RPong repl -test_echo = TestCase $ testRedis $+test_echo = TCase $ testRedis $ do r <- ask liftIO $ echo r "foobar" >>= fromRBulk >>= assertEqual "" (Just "foobar") -test_exists_del = TestCase $ testRedis $+test_exists_del = TCase $ testRedis $ do r <- ask addStr liftIO $ do e <- exists r "foo" >>= fromRInt@@ -62,20 +55,19 @@ e <- exists r "foo" >>= fromRInt assertEqual "foo was deleted" 0 e -test_get_type = TestCase $ testRedis $+test_get_type = TCase $ testRedis $ do addAll- mapM_ (uncurry checkType) [("foo", "string"),- ("bar", "string"),- ("list", "list"),- ("set", "set"),- ("zset", "zset"),- ("hash", "hash"),- ("no-such-key", "none")]+ mapM_ (uncurry checkType) [("foo", RTString),+ ("bar", RTString),+ ("list", RTList),+ ("set", RTSet),+ ("zset", RTZSet),+ ("hash", RTHash),+ ("no-such-key", RTNone)] where checkType key t = do r <- ask- liftIO $ do t' <- getType r key >>= fromRInline- assertEqual "" t t'+ liftIO $ getType r key >>= assertEqual "" t -test_keys = TestCase $ testRedis $+test_keys = TCase $ testRedis $ do r <- ask addStr addSet@@ -88,13 +80,13 @@ assertEqual "set and zset keys selected" (Just [Just "set", Just "zset"]) res -- that seems randomKey always returns the same sequence of keys-test_random_key = TestCase $ testRedis $+test_random_key = TCase $ testRedis $ do r <- ask addAll liftIO $ do res <- randomKey r >>= fromRBulk >>= return . fromJust assertOneOf "" ["foo", "bar", "list", "set", "zset", "hash"] res -test_rename = TestCase $ testRedis $+test_rename = TCase $ testRedis $ do r <- ask addStr liftIO $ do exists r "zoo" >>= fromRInt >>= assertEqual "there is no zoo here!" 0@@ -104,29 +96,31 @@ exists r "zoo" >>= fromRInt >>= assertEqual "foo was renamed to zoo" 1 get r "zoo" >>= assertEqual "" foo -test_renameNx = TestCase $ testRedis $+test_renameNx = TCase $ testRedis $ do r <- ask addStr liftIO $ do renameNx r "foo" "bar" >>= fromRInt >>= assertEqual "" 0 exists r "foo" >>= fromRInt >>= assertEqual "" 1 -test_dbsize = TestCase $ testRedis $+test_dbsize = TCase $ testRedis $ do r <- ask addStr liftIO $ do res <- dbsize r >>= fromRInt real <- (keys r "*" :: IO (Reply String)) >>= fromRMultiBulk >>= return . length . fromJust assertEqual "" real res -test_expire = TestCase $ testRedis $+test_expire = TCase $ testRedis $ do r <- ask addStr liftIO $ do expire r "foo" 0 >>= fromRInt >>= assertEqual "" 1+ threadDelay 10 exists r "foo" >>= fromRInt >>= assertEqual "foo has to be expired now" 0 TOD now _ <- getClockTime expireAt r "bar" $ fromIntegral now+ threadDelay 10 exists r "bar" >>= fromRInt >>= assertEqual "bar has to be expired now" 0 -test_ttl_persist = TestCase $ testRedis $+test_ttl_persist = TCase $ testRedis $ do r <- ask addStr liftIO $ do ttl r "foo" >>= fromRInt >>= assertEqual "" (-1)@@ -135,16 +129,19 @@ persist r "foo" >>= noError ttl r "foo" >>= fromRInt >>= assertEqual "foo was persisted again" (-1) -test_move = TestCase $ testRedis $+test_move = TCase $ \opts -> flip testRedis opts $ do r <- ask addStr liftIO $ do exists r "foo" >>= fromRInt >>= assertEqual "foo has to be in first database" 1- move r "foo" 1+ move r "foo" $ (optDatabase opts) + 1 exists r "foo" >>= fromRInt >>= assertEqual "now foo is in second database" 0- select r 1+ select r $ (optDatabase opts) + 1 exists r "foo" >>= fromRInt >>= assertEqual "now foo is in second database" 1+ move r "foo" $ optDatabase opts+ select r $ optDatabase opts+ return () -test_flushDb = TestCase $ testRedis $+test_flushDb = TCase $ testRedis $ do r <- ask liftIO $ do select r 1 set r "leave_it_alone" "hooray!"@@ -154,7 +151,7 @@ select r 1 dbsize r >>= fromRInt >>= assertEqual "but not the second one" 1 -test_flushAll = TestCase $ testRedis $+test_flushAll = TCase $ testRedis $ do r <- ask liftIO $ do select r 1 set r "baz" "no way"
Test/HashCommands.hs view
@@ -1,23 +1,19 @@+{-# LANGUAGE PackageImports #-} module Test.HashCommands where -import Test.HUnit-import Control.Monad.Reader-import Data.Maybe import Data.List import Data.Map (Map(..), (!)) import qualified Data.Map as M import qualified Data.Set as S-import Database.Redis.Redis hiding (sort)-import Test.Setup-import Test.Utils+import Test.Setup hiding (sort) -tests = TestList [TestLabel "hgetall" test_hgetall,- TestLabel "hkeys" test_hkeys,- TestLabel "hvals" test_hvals,- TestLabel "hlen" test_hlen,- TestLabel "hexists, hset, hget and hdel" test_hexists_hset_hget_hdel,- TestLabel "hmset and hmget" test_hmset_hmget,- TestLabel "hincrby" test_hincrby]+tests = TList [TLabel "hgetall" test_hgetall,+ TLabel "hkeys" test_hkeys,+ TLabel "hvals" test_hvals,+ 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] asHash :: Reply String -> IO (Map String String) asHash r = fromRMultiBulk r >>= return . M.fromList . build . map fromJust . fromJust@@ -25,7 +21,7 @@ build (a:[]) = error "unpaired element" build [] = [] -test_hgetall = TestCase $ testRedis $+test_hgetall = TCase $ testRedis $ let expected = M.fromList $ zip ["foo", "bar", "baz"] ["1", "2", "3"] in do r <- ask addHash@@ -34,7 +30,7 @@ h <- hgetall r "no-such-key" >>= fromRMultiBulk :: IO (Maybe [Maybe String]) assertEqual "" (Just []) h -test_hkeys = TestCase $ testRedis $+test_hkeys = TCase $ testRedis $ do r <- ask addHash liftIO $ do h <- hgetall r "hash" >>= asHash@@ -44,7 +40,7 @@ k <- hkeys r "no-such-key" >>= fromRMultiBulk :: IO (Maybe [Maybe String]) assertEqual "" (Just []) k -test_hvals = TestCase $ testRedis $+test_hvals = TCase $ testRedis $ do r <- ask addHash liftIO $ do h <- hgetall r "hash" >>= asHash@@ -54,7 +50,7 @@ k <- hkeys r "no-such-key" >>= fromRMultiBulk :: IO (Maybe [Maybe String]) assertEqual "" (Just []) k -test_hlen = TestCase $ testRedis $+test_hlen = TCase $ testRedis $ do r <- ask addHash liftIO $ do h <- hgetall r "hash" >>= asHash@@ -63,7 +59,7 @@ l <- hlen r "no-such-key" >>= fromRInt assertEqual "" 0 l -test_hexists_hset_hget_hdel = TestCase $ testRedis $+test_hexists_hset_hget_hdel = TCase $ testRedis $ do r <- ask addHash liftIO $ do hexists r "hash" "foo" >>= fromRInt >>= assertEqual "" 1@@ -77,7 +73,7 @@ hget r "hash" "foo" >>= fromRBulk >>= assertEqual "" (Just "bar") hget r "hash" "jaz" >>= fromRBulk >>= assertEqual "" (Nothing :: Maybe String) -test_hmset_hmget = TestCase $ testRedis $+test_hmset_hmget = TCase $ testRedis $ do r <- ask addHash liftIO $ do h <- hgetall r "hash" >>= asHash@@ -89,7 +85,7 @@ h' <- hgetall r "hash" >>= asHash assertEqual "" expected h' -test_hincrby = TestCase $ testRedis $+test_hincrby = TCase $ testRedis $ do r <- ask addHash liftIO $ do h <- hgetall r "hash" >>= asHash >>= return . M.map read :: IO (Map String Int)
Test/ListCommands.hs view
@@ -1,28 +1,24 @@ module Test.ListCommands where import Prelude hiding ((!!))-import Control.Monad.Reader import Data.List-import Test.HUnit-import Data.Maybe-import Database.Redis.Redis import Test.Setup-import Test.Utils -tests = TestList [TestLabel "lrange" test_lrange,- TestLabel "llen" test_llen,- TestLabel "lpush and rpush" test_lpush_rpush,- TestLabel "lpushx and rpushx" test_lpushx_rpushx,- TestLabel "linsert" test_linsert,- TestLabel "ltrim" test_ltrim,- TestLabel "lindex and lset" test_lindex_lset,- TestLabel "lrem" test_lrem,- TestLabel "lpop and rpop" test_lpor_rpop,- TestLabel "rpoplpush" test_rpoplpush,- TestLabel "blpop" test_blpop,- TestLabel "brpop" test_brpop]+tests = TList [TLabel "lrange" test_lrange,+ TLabel "llen" test_llen,+ TLabel "lpush and rpush" test_lpush_rpush,+ TLabel "lpushx and rpushx" test_lpushx_rpushx,+ TLabel "linsert" test_linsert,+ TLabel "ltrim" test_ltrim,+ TLabel "lindex and lset" test_lindex_lset,+ TLabel "lrem" test_lrem,+ TLabel "lpop and rpop" test_lpor_rpop,+ TLabel "rpoplpush" test_rpoplpush,+ TLabel "blpop" test_blpop,+ TLabel "brpop" test_brpop,+ TLabel "brpoplpush" test_brpoplpush] -test_lrange = TestCase $ testRedis $+test_lrange = TCase $ testRedis $ do r <- ask addList liftIO $ do list <- lrange r "list" takeAll >>= fromRMultiBulk@@ -30,7 +26,7 @@ list <- lrange r "list" (1, 1) >>= fromRMultiBulk assertEqual "" (Just [Just "2"]) list -test_llen = TestCase $ testRedis $+test_llen = TCase $ testRedis $ do r <- ask addList liftIO $ do len <- llen r "list" >>= fromRInt@@ -39,7 +35,7 @@ len <- llen r "no-such-key" >>= fromRInt assertEqual "not existing key is the same as an empty list" 0 len -test_lpush_rpush = TestCase $ testRedis $+test_lpush_rpush = TCase $ testRedis $ do r <- ask addList liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk@@ -53,7 +49,7 @@ Just list'' <- lrange r "list" takeAll >>= fromRMultiBulk assertEqual "" ((Just "0") : list') list'' -test_lpushx_rpushx = TestCase $ testRedis $+test_lpushx_rpushx = TCase $ testRedis $ do r <- ask addList liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk@@ -72,7 +68,7 @@ rpushx r "no-such-key" "1" >>= fromRInt >>= assertEqual "List was not created" 0 exists r "no-such-key" >>= fromRInt >>= assertEqual "List was not created" 0 -test_linsert = TestCase $ testRedis $+test_linsert = TCase $ testRedis $ do r <- ask addList liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk@@ -90,7 +86,7 @@ in a ++ (head b : Just "bar" : tail b) assertEqual "" excepted list'' -test_ltrim = TestCase $ testRedis $+test_ltrim = TCase $ testRedis $ do r <- ask addList liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk :: (IO (Maybe [Maybe String]))@@ -98,7 +94,7 @@ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk assertEqual "" (take 1 $ drop 1 $ list) list' -test_lindex_lset = TestCase $ testRedis $+test_lindex_lset = TCase $ testRedis $ do r <- ask addList liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk :: (IO (Maybe [Maybe String]))@@ -107,7 +103,7 @@ lset r "list" 1 "4" >>= fromROk lindex r "list" 1 >>= fromRBulk >>= assertEqual "" (Just "4") -test_lrem = TestCase $ testRedis $+test_lrem = TCase $ testRedis $ do r <- ask addList liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk@@ -115,7 +111,7 @@ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk assertEqual "" ((list !! 1) `delete` list) list' -test_lpor_rpop = TestCase $ testRedis $+test_lpor_rpop = TCase $ testRedis $ do r <- ask addList liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])@@ -124,7 +120,7 @@ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk assertEqual "" (init $ tail list) list' -test_rpoplpush = TestCase $ testRedis $+test_rpoplpush = TCase $ testRedis $ do r <- ask addList liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])@@ -135,7 +131,7 @@ Just list'' <- lrange r "list2" takeAll >>= fromRMultiBulk assertEqual "Two elemens was lpushed" (reverse $ take 2 $ reverse list) list'' -test_blpop = TestCase $ testRedis2 $+test_blpop = TCase $ testRedis2 $ do r1 <- ask r2 <- ask2 addList@@ -152,7 +148,7 @@ (blpop r1 ["zap"] 1 :: IO (Maybe (String, String))) >>= assertEqual "" Nothing -test_brpop = TestCase $ testRedis2 $+test_brpop = TCase $ testRedis2 $ do r1 <- ask r2 <- ask2 addList@@ -168,3 +164,22 @@ exists r1 "zap" >>= fromRInt >>= assertEqual "" 0 (brpop r1 ["zap"] 1 :: IO (Maybe (String, String))) >>= assertEqual "" Nothing++test_brpoplpush = TCase $ testRedis2 $+ do r1 <- ask+ r2 <- ask2+ addList+ liftIO $ do Just list <- lrange r1 "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ res <- brpoplpush r1 "list" "bar" 0+ assertEqual "" (Just $ Just $ fromJust $ last list) res+ Just list' <- lrange r1 "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "" (init list) list'+ Just list' <- lrange r1 "bar" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "" ([last list]) list'++ later 500 $ lpush r2 "zap" "1" >>= noError+ res <- brpoplpush r1 "zap" "list" 2+ assertEqual "" (Just $ Just "1") res+ exists r1 "zap" >>= fromRInt >>= assertEqual "" 0++ (brpoplpush r1 "zap" "list" 1 :: IO (Maybe (Maybe String))) >>= assertEqual "" Nothing
Test/Lock.hs view
@@ -1,20 +1,11 @@ module Test.Lock where--import Control.Monad.Reader-import Control.Exception-import Control.Concurrent.MVar-import Test.HUnit-import Data.Maybe-import System.Time-import Database.Redis.Redis-import Database.Redis.Utils.Lock import Test.Setup-import Test.Utils -tests = TestList [TestLabel "acquire and release" test_acquire_release,- TestLabel "acquire timeout" test_acquire_timeout] -test_acquire_release = TestCase $ testRedis2 $+tests = TList [TLabel "acquire and release" test_acquire_release,+ TLabel "acquire timeout" test_acquire_timeout]++test_acquire_release = TCase $ testRedis2 $ do r1 <- ask r2 <- ask2 liftIO $ do acquire r1 "lock" 1000 50 >>= assertBool ""@@ -22,7 +13,7 @@ release r1 "lock" acquire r2 "lock" 1000 50 >>= assertBool "" -test_acquire_timeout = TestCase $ testRedis2 $+test_acquire_timeout = TCase $ testRedis2 $ let act v r = do acquire r "lock" 2000 50 >>= assertBool "" putMVar v "done" in do v <- liftIO newEmptyMVar
Test/Monad/CASCommands.hs view
@@ -1,21 +1,14 @@ module Test.Monad.CASCommands where -import Control.Monad.Reader-import Control.Exception-import Control.Concurrent (threadDelay)-import Control.Concurrent.MVar-import Test.HUnit import Database.Redis.Monad-import Database.Redis.Monad.State-import Test.Setup-import Test.Utils+import Test.Setup hiding (exec, del, get, multi, run_cas, set) -tests = TestList [TestLabel "run_cas" test_run_cas,- TestLabel "run_cas that raised an exception" test_run_cas_exception]+tests = TList [TLabel "run_cas" test_run_cas,+ TLabel "run_cas that raised an exception" test_run_cas_exception] run r = liftIO . runWithRedis r -test_run_cas = TestCase $ testRedis2 $+test_run_cas = TCase $ testRedis2 $ let act :: RedisM String act = do Just foo <- get "foo" >>= fromRBulk multi@@ -42,7 +35,7 @@ liftIO $ assertEqual "" Nothing foo_ get "foo" >>= fromRBulk >>= liftIO . assertEqual "" (Just "baz") -test_run_cas_exception = TestCase $ testRedis $+test_run_cas_exception = TCase $ testRedis $ let act :: RedisM () act = do multi set "foo" "bar" >>= noError
Test/Monad/MultiCommands.hs view
@@ -1,22 +1,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Monad.MultiCommands where -import Control.Monad.Reader-import Control.Exception-import Control.Concurrent (threadDelay)-import Control.Concurrent.MVar-import Test.HUnit import Database.Redis.Monad-import Database.Redis.Monad.State-import Test.Setup-import Test.Utils+import Test.Setup hiding (exec, del, exists, get, multi, run_multi, set) -tests = TestList [TestLabel "run_multi" test_run_multi,- TestLabel "run_multi with exception" test_run_multi_exception]+tests = TList [TLabel "run_multi" test_run_multi,+ TLabel "run_multi with exception" test_run_multi_exception] run r = liftIO . runWithRedis r -test_run_multi = TestCase $ testRedis2 $+test_run_multi = TCase $ testRedis2 $ let act = do set "foo" "cool" >>= liftIO . assertRQueued "" set "baz" "baz" >>= liftIO . assertRQueued "" liftIO $ threadDelay 2000@@ -37,7 +30,7 @@ run r2 $ do get "foo" >>= fromRBulk >>= liftIO . assertEqual "now foo got a new value" (Just "cool") exists "baz" >>= fromRInt >>= liftIO . assertEqual "now baz is exists" 1 -test_run_multi_exception = TestCase $ testRedis2 $+test_run_multi_exception = TCase $ testRedis2 $ let act = do set "foo" "cool" >>= liftIO . assertRQueued "" set "baz" "baz" >>= liftIO . assertRQueued "" liftIO $ threadDelay 2000
Test/MultiCommands.hs view
@@ -1,20 +1,13 @@ module Test.MultiCommands where -import Control.Monad.Reader-import Control.Exception-import Control.Concurrent (threadDelay)-import Control.Concurrent.MVar-import Test.HUnit-import Database.Redis.Redis import Test.Setup-import Test.Utils -tests = TestList [TestLabel "multi and exec" test_multi_exec,- TestLabel "multi and discard" test_multi_discard,- TestLabel "run_multi" test_run_multi,- TestLabel "run_multi with exception" test_run_multi_exception]+tests = TList [TLabel "multi and exec" test_multi_exec,+ TLabel "multi and discard" test_multi_discard,+ TLabel "run_multi" test_run_multi,+ TLabel "run_multi with exception" test_run_multi_exception] -test_multi_exec = TestCase $ testRedis2 $+test_multi_exec = TCase $ testRedis2 $ do r1 <- ask r2 <- ask2 addStr@@ -33,7 +26,7 @@ get r2 "foo" >>= fromRBulk >>= assertEqual "now foo got a new value" (Just "cool") exists r2 "baz" >>= fromRInt >>= assertEqual "now baz is exists" 1 -test_multi_discard = TestCase $ testRedis2 $+test_multi_discard = TCase $ testRedis2 $ do r1 <- ask r2 <- ask2 addStr@@ -52,7 +45,7 @@ get r2 "foo" >>= fromRBulk >>= assertEqual "statements was discarder" foo exists r2 "baz" >>= fromRInt >>= assertEqual "statements was discarded" 0 -test_run_multi = TestCase $ testRedis2 $+test_run_multi = TCase $ testRedis2 $ let act r = do (set r "foo" "cool" :: IO (Reply ())) >>= assertRQueued "" (set r "baz" "baz" :: IO (Reply ())) >>= assertRQueued "" threadDelay 2000@@ -72,7 +65,7 @@ get r2 "foo" >>= fromRBulk >>= assertEqual "now foo got a new value" (Just "cool") exists r2 "baz" >>= fromRInt >>= assertEqual "now baz is exists" 1 -test_run_multi_exception = TestCase $ testRedis2 $+test_run_multi_exception = TCase $ testRedis2 $ let act r = do (set r "foo" "cool" :: IO (Reply ())) >>= assertRQueued "" (set r "baz" "baz" :: IO (Reply ())) >>= assertRQueued "" threadDelay 2000
Test/PubSubCommands.hs view
@@ -1,19 +1,13 @@ module Test.PubSubCommands where -import Control.Monad.Reader-import Control.Exception-import Control.Concurrent.MVar-import Test.HUnit-import Database.Redis.Redis import Test.Setup-import Test.Utils -tests = TestList [TestLabel "subscribe and unsubscribe" test_subscribe_unsubscribe,- TestLabel "psubscribe and punsubscribe" test_psubscribe_punsubscribe,- TestLabel "publish and listen" test_publish_listen,- TestLabel "publish and listen for psubscribe" test_publish_listen_p]+tests = TList [TLabel "subscribe and unsubscribe" test_subscribe_unsubscribe,+ TLabel "psubscribe and punsubscribe" test_psubscribe_punsubscribe,+ TLabel "publish and listen" test_publish_listen,+ TLabel "publish and listen for psubscribe" test_publish_listen_p] -test_subscribe_unsubscribe = TestCase $ testRedis $+test_subscribe_unsubscribe = TCase $ testRedis $ do r <- ask liftIO $ do subscribed r >>= assertEqual "" 0 res <- subscribe r ["foo", "bar"]@@ -33,7 +27,7 @@ res <- unsubscribe r ([] :: [String]) :: IO [Message String] subscribed r >>= assertEqual "" 0 -test_psubscribe_punsubscribe = TestCase $ testRedis $+test_psubscribe_punsubscribe = TCase $ testRedis $ do r <- ask liftIO $ do subscribed r >>= assertEqual "" 0 res <- psubscribe r ["foo*", "bar*"]@@ -53,7 +47,7 @@ res <- punsubscribe r ([] :: [String]) :: IO [Message String] subscribed r >>= assertEqual "" 0 -test_publish_listen = TestCase $ testRedis2 $+test_publish_listen = TCase $ testRedis2 $ do r1 <- ask r2 <- ask2 liftIO $ do subscribed r1 >>= assertEqual "" 0@@ -65,7 +59,7 @@ (listen r1 500 :: IO (Maybe (Message String))) >>= assertEqual "" Nothing -test_publish_listen_p = TestCase $ testRedis2 $+test_publish_listen_p = TCase $ testRedis2 $ do r1 <- ask r2 <- ask2 liftIO $ do subscribed r1 >>= assertEqual "" 0
Test/SetCommands.hs view
@@ -1,42 +1,37 @@ module Test.SetCommands where -import Test.HUnit-import Control.Monad.Reader-import Data.Maybe import Data.Set-import Database.Redis.Redis import Test.Setup-import Test.Utils -tests = TestList [TestLabel "smembers" test_smembers,- TestLabel "sismember" test_sismember,- TestLabel "sadd" test_sadd,- TestLabel "srem" test_srem,- TestLabel "spop" test_spop,- TestLabel "smove" test_smove,- TestLabel "scard" test_scard,- TestLabel "srandmember" test_srandmember,- TestLabel "sinter and sinterStore" test_sinter_sinterstore,- TestLabel "sunion and sunionStore" test_sunion_sunionstore,- TestLabel "sdiff and sdiffStore" test_sdiff_sdiffstore]+tests = TList [TLabel "smembers" test_smembers,+ TLabel "sismember" test_sismember,+ TLabel "sadd" test_sadd,+ TLabel "srem" test_srem,+ TLabel "spop" test_spop,+ TLabel "smove" test_smove,+ TLabel "scard" test_scard,+ 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] asSet :: Reply String -> IO (Set (Maybe String)) asSet r = fromRMultiBulk r >>= return . fromList . fromJust -test_smembers = TestCase $ testRedis $+test_smembers = TCase $ testRedis $ do r <- ask addSet liftIO $ do s <- smembers r "set" >>= asSet assertEqual "" (fromList [Just "1", Just "2", Just "3"]) s -test_sismember = TestCase $ testRedis $+test_sismember = TCase $ testRedis $ do r <- ask addSet liftIO $ do sismember r "set" "1" >>= fromRInt >>= assertEqual "" 1 sismember r "set" "0" >>= fromRInt >>= assertEqual "" 0 sismember r "no-such-key" "1" >>= fromRInt >>= assertEqual "" 0 -test_sadd = TestCase $ testRedis $+test_sadd = TCase $ testRedis $ do r <- ask addSet liftIO $ do s <- smembers r "set" >>= asSet@@ -45,7 +40,7 @@ s' <- smembers r "set" >>= asSet assertEqual "" (insert (Just "4") s) s' -test_srem = TestCase $ testRedis $+test_srem = TCase $ testRedis $ do r <- ask addSet liftIO $ do s <- smembers r "set" >>= asSet@@ -54,7 +49,7 @@ s' <- smembers r "set" >>= asSet assertEqual "" (delete (Just "3") s) s' -test_spop = TestCase $ testRedis $+test_spop = TCase $ testRedis $ do r <- ask addSet liftIO $ do s <- smembers r "set" >>= asSet@@ -63,7 +58,7 @@ s' <- smembers r "set" >>= asSet assertEqual "" (delete el s) s' -test_smove = TestCase $ testRedis $+test_smove = TCase $ testRedis $ do r <- ask addSet liftIO $ do s <- smembers r "set" >>= asSet@@ -73,20 +68,20 @@ s' <- smembers r "set2" >>= asSet assertEqual "" (fromList [Just "3"]) s' -test_scard = TestCase $ testRedis $+test_scard = TCase $ testRedis $ do r <- ask addSet liftIO $ do s <- smembers r "set" >>= asSet scard r "set" >>= fromRInt >>= assertEqual "" (size s) -test_srandmember = TestCase $ testRedis $+test_srandmember = TCase $ testRedis $ do r <- ask addSet liftIO $ do s <- smembers r "set" >>= asSet el <- srandmember r "set" >>= fromRBulk assertBool "" $ member el s -test_sinter_sinterstore = TestCase $ testRedis $+test_sinter_sinterstore = TCase $ testRedis $ do r <- ask addSet liftIO $ do mapM_ (sadd r "set2") ["2", "3", "4"]@@ -98,7 +93,7 @@ smembers r "set3" >>= asSet >>= assertEqual "" s3 sinterStore r "set3" ["set", "set4"] >>= fromRInt >>= assertEqual "" 0 -test_sunion_sunionstore = TestCase $ testRedis $+test_sunion_sunionstore = TCase $ testRedis $ do r <- ask addSet liftIO $ do mapM_ (sadd r "set2") ["3", "4", "5"]@@ -110,7 +105,7 @@ smembers r "set3" >>= asSet >>= assertEqual "" s3 sunionStore r "set3" ["set", "set4"] >>= fromRInt >>= assertEqual "" (size s) -test_sdiff_sdiffstore = TestCase $ testRedis $+test_sdiff_sdiffstore = TCase $ testRedis $ do r <- ask addSet liftIO $ do mapM_ (sadd r "set2") ["3", "4", "5"]
Test/Setup.hs view
@@ -1,41 +1,94 @@-{-# LANGUAGE FlexibleContexts #-}-module Test.Setup where+{-# LANGUAGE FlexibleContexts, PackageImports #-}+module Test.Setup (+ startRedis,+ shutdownRedis,+ testRedis, testRedis2,+ ask2, addStr, addList,+ addSet, addZSet,+ addHash, addAll, -import Control.Exception (bracket)+ RedisM, runWithRedis,++ Opts(..),+ T(..), pushParam, toHUnit,++ module Control.Exception,+ module Control.Concurrent,+ module Control.Monad.Reader,+ module Data.Maybe,+ module Database.Redis.Redis,+ module Database.Redis.ByteStringClass,+ module Database.Redis.Utils.Lock,+ module System.Cmd,+ module System.Directory,+ module System.FilePath,+ module System.Time,+ module Test.HUnit,+ module Test.Utils+ ) where++import Control.Exception hiding (assert, throwTo) import Control.Concurrent-import Control.Monad.Reader-import Test.HUnit+import "mtl" Control.Monad.Reader+import Data.Maybe+import Database.Redis.Monad.State (RedisM, runWithRedis)+import Database.Redis.Redis+import Database.Redis.ByteStringClass+import Database.Redis.Utils.Lock import System.Cmd import System.Directory import System.FilePath-import Database.Redis.Redis+import System.Time+import Test.HUnit+import Test.Utils -startRedis :: FilePath -> IO ()-startRedis path_to_redis = do cwd <- getCurrentDirectory- system $ path_to_redis ++ " " ++ (cwd </> "redis.conf")- threadDelay $ 10000- return ()+data Opts = Opts { optHost :: String,+ optPort :: String,+ optDatabase :: Int,+ optBinary :: Maybe String,+ optConfig :: Maybe String,+ optHelp :: Bool }+ deriving Show +data T a = TCase { runTCase :: a }+ | TLabel String (T a)+ | TList [T a]++pushParam :: a -> T (a -> b) -> T b+pushParam a (TCase f) = TCase $ f a+pushParam a (TLabel l t) = TLabel l $ pushParam a t+pushParam a (TList ts) = TList $ map (pushParam a) ts++toHUnit :: T (IO ()) -> Test+toHUnit (TCase t) = TestCase $ t+toHUnit (TLabel s t) = TestLabel s $ toHUnit t+toHUnit (TList ts) = TestList $ map toHUnit ts++startRedis :: FilePath -> FilePath -> IO ()+startRedis path_to_redis path_to_config = do system $ path_to_redis ++ " " ++ path_to_config+ threadDelay $ 10000+ return ()+ shutdownRedis = do r <- connect localhost defaultPort shutdown r return () -testRedis :: (ReaderT Redis IO ()) -> IO ()-testRedis t = bracket setup teardown $ runReaderT t- where setup = do r <- connect localhost defaultPort- select r 0+testRedis :: (ReaderT Redis IO ()) -> Opts -> IO ()+testRedis t opts = bracket setup teardown $ runReaderT t+ where setup = do r <- connect (optHost opts) (optPort opts)+ select r $ optDatabase opts return r- teardown r = do flushAll r+ teardown r = do flushDb r disconnect r -testRedis2 :: (ReaderT Redis (ReaderT Redis IO) ()) -> IO ()-testRedis2 t = bracket setup teardown $ \(r1, r2) -> runReaderT (runReaderT t r2) r1- where setup = do r1 <- connect localhost defaultPort- select r1 0- r2 <- connect localhost defaultPort- select r2 0+testRedis2 :: (ReaderT Redis (ReaderT Redis IO) ()) -> Opts -> IO ()+testRedis2 t opts = bracket setup teardown $ \(r1, r2) -> runReaderT (runReaderT t r2) r1+ where setup = do r1 <- connect (optHost opts) (optPort opts)+ select r1 $ optDatabase opts+ r2 <- connect (optHost opts) (optPort opts)+ select r2 $ optDatabase opts return (r1, r2)- teardown (r1, r2) = do flushAll r1+ teardown (r1, r2) = do flushDb r1 disconnect r1 disconnect r2
Test/SortCommands.hs view
@@ -1,23 +1,18 @@ module Test.SortCommands where -import Test.HUnit-import Control.Monad.Reader-import Data.Maybe import Data.Char (toUpper) import Data.List hiding (sort) import Data.ByteString.UTF8 (fromString) import qualified Data.List as L import System.Random-import Database.Redis.Redis import Test.Setup-import Test.Utils -tests = TestList [TestLabel "sort asc and desc" test_sort_asc_desc,- TestLabel "sort alpha" test_sort_alpha,- TestLabel "sort_by" test_sort_by,- TestLabel "sort get_obj" test_sort_get,- TestLabel "sort store" test_sort_store,- TestLabel "listRelated" test_listRelated]+tests = TList [TLabel "sort asc and desc" test_sort_asc_desc,+ TLabel "sort alpha" test_sort_alpha,+ TLabel "sort_by" test_sort_by,+ TLabel "sort get_obj" test_sort_get,+ TLabel "sort store" test_sort_store,+ TLabel "listRelated" test_listRelated] addUserList name l = do r <- ask lift $ mapM_ (rpush r name) l@@ -26,7 +21,7 @@ unsortedAlphaList = randomRIOs ('a', 'z') 10 unsortedAlphaList2 = randomRIOs ('а', 'я') 10 -- non-ASCII string -test_sort_asc_desc = TestCase $ testRedis $+test_sort_asc_desc = TCase $ testRedis $ do r <- ask l <- liftIO unsortedList addUserList "l" l@@ -35,7 +30,7 @@ l' <- sort r "l" sortDefaults{desc = True} >>= fromRMultiBulk >>= return . map fromJust . fromJust assertEqual "" (reverse $ L.sort l) l' -test_sort_alpha = TestCase $ testRedis $+test_sort_alpha = TCase $ testRedis $ do r <- ask l1 <- liftIO unsortedAlphaList l2 <- liftIO unsortedAlphaList2@@ -50,7 +45,7 @@ l' <- sort r "l2" sortDefaults{desc = True, alpha = True} >>= fromRMultiBulk >>= return . map fromJust . fromJust assertEqual "" (reverse $ L.sort l2) l' -test_sort_by = TestCase $ testRedis $+test_sort_by = TCase $ testRedis $ do r <- ask l <- liftIO unsortedList addUserList "l" l@@ -62,7 +57,7 @@ l' <- sort r "l" sortDefaults{sort_by = fromString "constant"} >>= fromRMultiBulk >>= return . map fromJust . fromJust assertEqual "" l l' -test_sort_get = TestCase $ testRedis $+test_sort_get = TCase $ testRedis $ do r <- ask l <- liftIO unsortedAlphaList addUserList "l" l@@ -71,7 +66,7 @@ liftIO $ do l' <- sort r "l" sortDefaults{alpha = True, get_obj = [fromString "foo_*", fromString "bar_*"]} >>= fromRMultiBulk >>= return . map fromJust . fromJust assertEqual "" ((++ "x") $ intersperse 'x' $ map toUpper $ L.sort l) l' -test_sort_store = TestCase $ testRedis $+test_sort_store = TCase $ testRedis $ do r <- ask l <- liftIO unsortedAlphaList addUserList "l" l@@ -81,7 +76,7 @@ l'' <- lrange r "l2" takeAll >>= fromRMultiBulk >>= return . map fromJust . fromJust assertEqual "" l' l'' -test_listRelated = TestCase $ testRedis $+test_listRelated = TCase $ testRedis $ do r <- ask addList liftIO $ mapM_ (\x -> set r ("foo_" ++ show x) (x^2)) [(1 :: Int)..3]
Test/StringCommands.hs view
@@ -1,62 +1,62 @@ module Test.StringCommands where -import Test.HUnit-import Control.Monad.Reader-import Data.Maybe-import Database.Redis.Redis import Test.Setup-import Test.Utils+import qualified Data.ByteString as BS -tests = TestList [TestLabel "get and set" test_set_get,- TestLabel "setNx" test_setNx,- TestLabel "setEx" test_setEx,- TestLabel "mSet and mGet" test_m_set_get,- TestLabel "mSetNx" test_mSetNx,- TestLabel "getSet" test_getSet,- TestLabel "incr and incrBy, decr and decrBy" test_incr_decr,- TestLabel "append" test_append,- TestLabel "substr" test_substr,- TestLabel "strlen" test_strlen]+tests = TList [TLabel "get and set" test_set_get,+ TLabel "setNx" test_setNx,+ TLabel "setEx" test_setEx,+ TLabel "mSet and mGet" test_m_set_get,+ TLabel "mSetNx" test_mSetNx,+ TLabel "getSet" test_getSet,+ TLabel "incr and incrBy, decr and decrBy" test_incr_decr,+ TLabel "append" test_append,+ TLabel "substr" test_substr,+ TLabel "getrange" test_getrange,+ TLabel "setrange" test_setrange,+ TLabel "getbit" test_getbit,+ TLabel "setbit" test_setbit,+ TLabel "strlen" test_strlen] -test_set_get = TestCase $ testRedis $+test_set_get = TCase $ testRedis $ do r <- ask addStr liftIO $ do get r "foo" >>= fromRBulk >>= assertEqual "" (Just "foo") set r "foo" "zoo" >>= fromROk get r "foo" >>= fromRBulk >>= assertEqual "foo was set to zoo" (Just "zoo") -test_setNx = TestCase $ testRedis $+test_setNx = TCase $ testRedis $ do r <- ask addStr liftIO $ do setNx r "foo" "zoo" >>= fromRInt >>= assertEqual "setNx doesn't replace key value" 0 get r "foo" >>= fromRBulk >>= assertEqual "" (Just "foo") -test_setEx = TestCase $ testRedis $+test_setEx = TCase $ testRedis $ do r <- ask addStr liftIO $ do setEx r "foo" 30 "zoo" >>= fromROk get r "foo" >>= fromRBulk >>= assertEqual "foo was set to zoo" (Just "zoo") ttl r "foo" >>= fromRInt >>= assertBool "foo TTL must be less then 30 seconds" . (<= 30) -test_m_set_get = TestCase $ testRedis $+test_m_set_get = TCase $ testRedis $ do r <- ask addStr liftIO $ do mSet r [("foo", "zoo"), ("zoo", "foo")] >>= fromROk mGet r ["foo", "zoo", "baz"] >>= fromRMultiBulk >>= assertEqual "" (Just [Just "zoo", Just "foo", Nothing]) -test_mSetNx = TestCase $ testRedis $+test_mSetNx = TCase $ testRedis $ do r <- ask addStr liftIO $ do mSetNx r [("foo", "zoo"), ("zoo", "foo")] >>= fromRInt >>= assertEqual "foo already exists" 0 mGet r ["foo", "zoo"] >>= fromRMultiBulk >>= assertEqual "" (Just [Just "foo", Nothing]) -test_getSet = TestCase $ testRedis $+test_getSet = TCase $ testRedis $ do r <- ask addStr liftIO $ do getSet r "foo" "zoo" >>= fromRBulk >>= assertEqual "" (Just "foo") get r "foo" >>= fromRBulk >>= assertEqual "foo was set to zoo" (Just "zoo") -test_incr_decr = TestCase $ testRedis $+test_incr_decr = TCase $ testRedis $ do r <- ask addStr liftIO $ do set r "i" (0 :: Int) >>= fromROk@@ -69,7 +69,7 @@ decrBy r "i" 2 >>= fromRInt >>= assertEqual "" 0 (get r "i" :: IO (Reply String)) >>= fromRBulk >>= assertEqual "" (Just "0") -test_append = TestCase $ testRedis $+test_append = TCase $ testRedis $ do r <- ask addStr liftIO $ do Just foo <- get r "foo" >>= fromRBulk@@ -78,14 +78,48 @@ assertEqual ("Expected: \"" ++ foo ++ "\" ++ \"foo\"") (foo ++ "foo") foo' assertEqual "" (length foo') newlength -test_substr = TestCase $ testRedis $+test_substr = TCase $ testRedis $ do r <- ask addStr liftIO $ do Just foo <- get r "foo" >>= fromRBulk let s = take 1 . drop 1 $ foo :: String substr r "foo" (1, 1) >>= fromRBulk >>= assertEqual "" (Just s) -test_strlen = TestCase $ testRedis $+test_getrange = TCase $ testRedis $+ do r <- ask+ addStr+ liftIO $ do Just foo <- get r "foo" >>= fromRBulk+ let s = take 1 . drop 1 $ foo :: String+ getrange r "foo" (1, 1) >>= fromRBulk >>= assertEqual "" (Just s)++test_setrange = TCase $ testRedis $+ do r <- ask+ addStr+ liftIO $ do Just foo <- get r "foo" >>= fromRBulk+ let s = (++ "bar") . take 2 $ foo :: String+ setrange r "foo" 2 "bar" >>= fromRInt >>= assertEqual "" (length s)+ get r "foo" >>= fromRBulk >>= assertEqual "" (Just s)++test_getbit = TCase $ testRedis $+ do r <- ask+ liftIO $ do (set r "foo" foo :: IO (Reply ())) >>= fromROk+ getbit r "foo" 0 >>= fromRInt >>= assertEqual "" 0+ getbit r "foo" 4 >>= fromRInt >>= assertEqual "" 1+ getbit r "foo" 6 >>= fromRInt >>= assertEqual "" 1++ where foo = BS.pack [10] -- 0b00001010++test_setbit = TCase $ testRedis $+ do r <- ask+ liftIO $ do getbit r "foo" 0 >>= fromRInt >>= assertEqual "Non existing key" 0+ setbit r "foo" 7 1 >>= fromRInt >>= assertEqual "Old value is 0" 0+ setbit r "foo" 7 0 >>= fromRInt >>= assertEqual "Old value is 1" 1+ setbit r "foo" 4 1 >>= fromRInt+ setbit r "foo" 6 1 >>= fromRInt+ get r "foo" >>= fromRBulk >>= assertEqual "" (Just foo)+ where foo = BS.pack [10] -- 0b00001010++test_strlen = TCase $ testRedis $ do r <- ask addStr liftIO $ do Just foo <- get r "foo" >>= fromRBulk
Test/ZSetCommands.hs view
@@ -1,27 +1,23 @@+{-# LANGUAGE PackageImports #-} module Test.ZSetCommands where -import Test.HUnit-import Control.Monad.Reader-import Data.Maybe import Data.List import Data.Map (Map(..), fromList, toList, unionWith, intersectionWith) import qualified Data.Map as M-import Database.Redis.Redis import Test.Setup-import Test.Utils -tests = TestList [TestLabel "zrange, zrevrange and scard" test_zrange_zrevrange_zcard,- TestLabel "zadd and zrem" test_zadd_zrem,- TestLabel "zscore" test_zscore,- TestLabel "zincrBy" test_zincrBy,- TestLabel "zrangebyscore" test_zrangebyscore,- TestLabel "zrevrangebyscore" test_zrevrangebyscore,- TestLabel "zcount" test_zcount,- TestLabel "zremrangebyscore" test_zremrangebyscore,- TestLabel "zrank and zrevrank" test_zrank_zrevrank,- TestLabel "zremrangebyrank" test_zremrangebyrank,- TestLabel "zunionStore" test_zunionStore,- TestLabel "zinterStore" test_zinterStore]+tests = TList [TLabel "zrange, zrevrange and scard" test_zrange_zrevrange_zcard,+ TLabel "zadd and zrem" test_zadd_zrem,+ TLabel "zscore" test_zscore,+ TLabel "zincrBy" test_zincrBy,+ TLabel "zrangebyscore" test_zrangebyscore,+ TLabel "zrevrangebyscore" test_zrevrangebyscore,+ TLabel "zcount" test_zcount,+ TLabel "zremrangebyscore" test_zremrangebyscore,+ TLabel "zrank and zrevrank" test_zrank_zrevrank,+ TLabel "zremrangebyrank" test_zremrangebyrank,+ TLabel "zunionStore" test_zunionStore,+ TLabel "zinterStore" test_zinterStore] asZSet :: Reply String -> IO [(String, Double)] asZSet r = fromRMultiBulk r >>= return . build . map fromJust . fromJust@@ -32,7 +28,7 @@ zsort :: [(String, Double)] -> [(String, Double)] zsort = sortBy (\(_, a) (_, b) -> compare a b) -test_zrange_zrevrange_zcard = TestCase $ testRedis $+test_zrange_zrevrange_zcard = TCase $ testRedis $ let expected = zsort $ zip ["1", "2", "3", "4", "5"] (reverse [1.0, 2.0, 3.0, 4.0, 5.0]) in do r <- ask addZSet@@ -47,7 +43,7 @@ zrange r "zset" (1,2) False >>= fromRMultiBulk >>= return . map fromJust . fromJust >>= assertEqual "" (map fst $ take 2 $ drop 1 $ expected) zrevrange r "zset" (1,2) False >>= fromRMultiBulk >>= return . map fromJust . fromJust >>= assertEqual "" (map fst $ take 2 $ drop 1 $ reverse expected) -test_zadd_zrem = TestCase $ testRedis $+test_zadd_zrem = TCase $ testRedis $ do r <- ask addZSet liftIO $ do zadd r "zset" 0.5 "6" >>= fromRInt >>= assertEqual "" 1@@ -60,7 +56,7 @@ z <- zrange r "zset" takeAll True >>= asZSet assertEqual "" ("1", 0.6) $ head z -test_zscore = TestCase $ testRedis $+test_zscore = TCase $ testRedis $ let lookupBy _ _ [] = Nothing lookupBy f a (l:ls) = if f l == a then Just l@@ -72,7 +68,7 @@ score <- zscore r "zset" "1" >>= fromRBulk :: IO (Maybe Double) assertEqual "" expected score -test_zincrBy = TestCase $ testRedis $+test_zincrBy = TCase $ testRedis $ do r <- ask addZSet liftIO $ do zincrBy r "zset" 0.5 "5" >>= fromRBulk >>= assertEqual "" (Just (1.5 :: Double))@@ -82,7 +78,7 @@ score <- zscore r "zset" "5" >>= fromRBulk assertEqual "" (Just (1.0 :: Double)) score -test_zrangebyscore = TestCase $ testRedis $+test_zrangebyscore = TCase $ testRedis $ do r <- ask addZSet liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet@@ -93,7 +89,7 @@ let expected = take 2 $ drop 1 $ filter ((\x -> x > 1 && x < 4) . snd) z assertEqual "" expected z' -test_zrevrangebyscore = TestCase $ testRedis $+test_zrevrangebyscore = TCase $ testRedis $ do r <- ask addZSet liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet@@ -104,7 +100,7 @@ let expected = take 2 $ drop 1 $ reverse $ filter ((\x -> x > 1 && x < 4) . snd) z assertEqual "(1, 4)" expected z' -test_zcount = TestCase $ testRedis $+test_zcount = TCase $ testRedis $ do r <- ask addZSet liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet@@ -115,7 +111,7 @@ let expected = filter ((\x -> x > 1 && x < 4) . snd) z assertEqual "" (length expected) z' -test_zremrangebyscore = TestCase $ testRedis $+test_zremrangebyscore = TCase $ testRedis $ do r <- ask addZSet liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet@@ -125,7 +121,7 @@ z' <- zrange r "zset" takeAll True >>= asZSet assertEqual "" left z' -test_zrank_zrevrank = TestCase $ testRedis $+test_zrank_zrevrank = TCase $ testRedis $ let rank e = findIndex (== e) in do r <- ask addZSet@@ -141,7 +137,7 @@ zrank r "zset" "6" >>= fromRInt -} -test_zremrangebyrank = TestCase $ testRedis $+test_zremrangebyrank = TCase $ testRedis $ do r <- ask addZSet liftIO $ do z <- zrange r "zset" takeAll False >>= fromRMultiBulk >>= return . fromJust :: IO [Maybe String]@@ -150,7 +146,7 @@ z' <- zrange r "zset" takeAll False >>= fromRMultiBulk >>= return . fromJust :: IO [Maybe String] assertEqual "" expected z' -test_zunionStore = TestCase $ testRedis $+test_zunionStore = TCase $ testRedis $ let addZSet2 key m = ask >>= \r -> liftIO $ mapM_ (uncurry (flip $ zadd r key)) $ toList m zmap2 = fromList $ zip ["1", "2", "6"] [1.0, 2.0, 3.0] :: Map String Double in do r <- ask@@ -172,7 +168,7 @@ z' <- zrange r "zset3" takeAll True >>= asZSet assertEqual "" expected z' -test_zinterStore = TestCase $ testRedis $+test_zinterStore = TCase $ testRedis $ let addZSet2 key m = ask >>= \r -> liftIO $ mapM_ (uncurry (flip $ zadd r key)) $ toList m zmap2 = fromList $ zip ["1", "2", "6"] [1.0, 2.0, 3.0] :: Map String Double in do r <- ask
+ redis-2.0.conf view
@@ -0,0 +1,18 @@+daemonize yes+timeout 300+loglevel warning+logfile stdout+databases 2++# No snapshots+# save 900 1+# save 300 10+# save 60 10000++dir ./++# requirepass foobared+appendonly no+hash-max-zipmap-entries 64+hash-max-zipmap-value 512+activerehashing yes
+ redis-2.2.conf view
@@ -0,0 +1,20 @@+daemonize yes+timeout 300+loglevel warning+logfile stdout+databases 2++# No snapshots+# save 900 1+# save 300 10+# save 60 10000++dir ./++# requirepass foobared+appendonly no+hash-max-zipmap-entries 64+hash-max-zipmap-value 512+activerehashing yes++rename-command PING "P"
redis.cabal view
@@ -1,5 +1,5 @@ Name: redis-Version: 0.10.1+Version: 0.11 License: MIT Maintainer: Alexander Bogdanov <andorn@gmail.com> Author: Alexander Bogdanov <andorn@gmail.com>@@ -11,46 +11,40 @@ 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. Note that this library- supports the most recent (actually the git one) version of- Redis. Most of the functions will work correctly with stable- version but not all.+ . + 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. .- Changes from v0.9:+ You can use Test module from the source package to run unit+ tests. Try /runhaskell Test.hs --help/ for usage info. Caution! Do not+ run tests on your working database - test database will be+ flushed. .- - New commands implemented: echo, linsert, zrevrangebyscore,- lpushx and rpushx+ There are simple benchmark module included: Benchmark.hs. It shows+ me about two times less requests per second than redis-benchmark+ from server distribution. .- - blpop and brpop has changed their types: it's now IO (Maybe (s1,- s2)) instead of IO (Reply s2). Warning! It's backward- incompatible!+ Please let me know if tests or benchmark goes terribly wrong. .- - New helpers fromRBulk' and fromRMultiBulk' which not only- unwraps RBulk and RMulti replies but also (unsafely) unwraps- /Maybes/ inside it.+ Changes from v0.10: .- - Now it's posible to use Redis renamed commands (config option- /rename-command/). You just have to call /renameCommand/ to make- client configuration the same as the server one.+ - 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) .- - Type of run_multi changed. The second param is now (Redis -> IO- a) action instead of list of IO (Reply ()). Warning! It's- backward incompatible!+ - Simple benchmark included (see above) .- - Type of run_cas changed too. The third param is now (Redis -> IO- a) action instead of IO (Reply ()). Warning! It's backward- incompatible!+ - New commands implemented: brpoplpush (blocking rpoplpush),+ getrange, setrange, getbit and setbit .- - Most of the protocol functions is now covered with tests (and- all tests are passed with the most recent Redis version). You- may run it using something like \"runhaskell Test.hs- \<path-to-your-redis-binary\>\". \*Warning!\* Don't do that if you- have running redis instance on the default port and host! All- data in databases 0 and 1 will be lost!+ - getType reply is now parsed into RedisKeyType datatype instead+ of just returning Reply. Warning! It's backward incompatible! .- - Fixed issues with connection on OSX and missed exports in Redis- module - many thanks to Dan Colish+ - info reply is now parsed into Map String String. Warning! It's+ backward incompatible! . Stability: beta@@ -66,11 +60,12 @@ Test/ZSetCommands.hs, Test/HashCommands.hs, Test/MultiCommands.hs, Test/SortCommands.hs, Test/Monad/CASCommands.hs, Test/Monad/MultiCommands.hs,- redis.conf+ redis-2.0.conf, redis-2.2.conf,+ Benchmark.hs Library Build-Depends: base < 5, containers, bytestring, utf8-string,- network, mtl, old-time, MonadCatchIO-mtl+ network, mtl, old-time, MonadCatchIO-mtl, parsec Exposed-modules: Database.Redis.Redis Database.Redis.Monad Database.Redis.ByteStringClass@@ -78,3 +73,4 @@ Database.Redis.Utils.Lock Database.Redis.Utils.Monad.Lock Other-modules: Database.Redis.Internal+ Database.Redis.Info
− redis.conf
@@ -1,21 +0,0 @@-daemonize yes-unixsocket /tmp/redis.sock-timeout 300-loglevel warning-logfile stdout-databases 2--# No snapshots-# save 900 1-# save 300 10-# save 60 10000--dir ./--# requirepass foobared-appendonly no-hash-max-zipmap-entries 64-hash-max-zipmap-value 512-activerehashing yes--rename-command PING "P"