redis 0.9 → 0.10
raw patch · 23 files changed
+1880/−115 lines, 23 filesdep +containers
Dependencies added: containers
Files
- Database/Redis/ByteStringClass.hs +4/−0
- Database/Redis/Internal.hs +54/−35
- Database/Redis/Monad.hs +45/−19
- Database/Redis/Redis.hs +156/−49
- Test.hs +46/−0
- Test/CASCommands.hs +82/−0
- Test/Connection.hs +28/−0
- Test/GenericCommands.hs +165/−0
- Test/HashCommands.hs +101/−0
- Test/ListCommands.hs +170/−0
- Test/Lock.hs +36/−0
- Test/Monad/CASCommands.hs +57/−0
- Test/Monad/MultiCommands.hs +60/−0
- Test/MultiCommands.hs +94/−0
- Test/PubSubCommands.hs +83/−0
- Test/SetCommands.hs +123/−0
- Test/Setup.hs +69/−0
- Test/SortCommands.hs +90/−0
- Test/StringCommands.hs +92/−0
- Test/Utils.hs +57/−0
- Test/ZSetCommands.hs +195/−0
- redis.cabal +50/−12
- redis.conf +23/−0
Database/Redis/ByteStringClass.hs view
@@ -19,6 +19,10 @@ toBS = concat . L.toChunks fromBS = L.fromChunks . return +instance BS Char where+ toBS c = U.fromString [c]+ fromBS = Prelude.head . U.toString+ instance BS String where toBS = U.fromString fromBS = U.toString
Database/Redis/Internal.hs view
@@ -13,6 +13,8 @@ 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) @@ -24,7 +26,8 @@ data RedisState = RedisState { server :: (String, String), -- ^ hostname and port pair database :: Int, -- ^ currently selected database handle :: IO.Handle, -- ^ real network connection- isSubscribed :: Int -- ^ currently in PUB/SUB mode+ isSubscribed :: Int, -- ^ currently in PUB/SUB mode+ renamedCommands :: Map ByteString ByteString -- ^ map of the renamed commands } -- | Redis connection descriptor@@ -33,6 +36,12 @@ r_st :: IORef RedisState} deriving Eq +newRedis :: (String, String) -> IO.Handle -> IO Redis+newRedis server h = do lcnt <- newMVar Nothing+ l <- newMVar ()+ st <- newIORef $ RedisState server 0 h 0 Map.empty+ return $ Redis lcnt l st+ -- | Redis command variants data Command = CInline ByteString | CMInline [ByteString]@@ -65,18 +74,18 @@ show (RInline s) = "RInline (" ++ (showbs s) ++ ")" show (RInt a) = "RInt " ++ show a show (RBulk (Just s)) = "RBulk " ++ showbs s- show (RBulk Nothing) = "RBulk Nothing"+ show (RBulk Nothing) = "RBulk Nil" show (RMulti (Just rs)) = "RMulti [" ++ join rs ++ "]" where join = concat . intersperse ", " . map show show (RMulti Nothing) = "RMulti Nil" -data (BS s) => Message s = MSubscribe s Int- | MUnsubscribe s Int- | MPSubscribe s Int- | MPUnsubscribe s Int- | MMessage s s- | MPMessage s s s- deriving Show+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) urn = U.fromString "\r\n" uspace = U.fromString " "@@ -154,34 +163,44 @@ send h [] = return () send h (bs:ls) = B.hPut h bs >> B.hPut h uspace >> send h ls +lookupRenamed :: RedisState -> ByteString -> ByteString+lookupRenamed r c = let c' = Map.findWithDefault c c (renamedCommands r)+ in if B.null c'+ then error $ "Command " ++ (fromBS c :: String) ++ " is disabled"+ else c'+ sendCommand :: RedisState -> Command -> IO () sendCommand r (CInline bs) = let h = handle r- in B.hPut h bs >> hPutRn h >> IO.hFlush h-sendCommand r (CMInline ls) = let h = handle r- in send h ls >> hPutRn h >> IO.hFlush h-sendCommand r (CBulk lcmd bs) = let h = handle r- size = U.fromString $ show $ B.length bs- in do send h lcmd- B.hPut h uspace- B.hPut h size- hPutRn h- B.hPut h bs- hPutRn h- IO.hFlush h-sendCommand r (CMBulk strings) = let h = handle r- sendls [] = return ()- sendls (bs:ls) = let size = U.fromString . show . B.length- in do B.hPut h ubucks- B.hPut h $ size bs- hPutRn h- B.hPut h bs- hPutRn h- sendls ls- in do B.hPut h uasterisk- B.hPut h $ U.fromString $ show $ length strings- hPutRn h- sendls strings- IO.hFlush h+ cmd = lookupRenamed r bs+ in B.hPut h cmd >> hPutRn h >> IO.hFlush h+sendCommand r (CMInline (l:ls)) = let h = handle r+ cmd = lookupRenamed r l+ in send h (cmd:ls) >> hPutRn h >> IO.hFlush h+sendCommand r (CBulk (l:ls) bs) = let h = handle r+ size = U.fromString $ show $ B.length bs+ cmd = lookupRenamed r l+ in do send h (cmd:ls)+ B.hPut h uspace+ B.hPut h size+ hPutRn h+ B.hPut h bs+ hPutRn h+ IO.hFlush h+sendCommand r (CMBulk s@(c:cs)) = let h = handle r+ sendls [] = return ()+ sendls (bs:ls) = let size = U.fromString . show . B.length+ in do B.hPut h ubucks+ B.hPut h $ size bs+ hPutRn h+ B.hPut h bs+ hPutRn h+ sendls ls+ c' = lookupRenamed r c+ in do B.hPut h uasterisk+ B.hPut h $ U.fromString $ show $ length s+ hPutRn h+ sendls (c':cs)+ IO.hFlush h sendCommand' = flip sendCommand
Database/Redis/Monad.hs view
@@ -29,6 +29,7 @@ R.Redis(..), R.Reply(..), R.Message(..),+ R.LInsertDirection(..), R.Interval(..), R.IsInterval(..), R.SortOptions(..),@@ -41,12 +42,13 @@ -- * Database connection R.localhost, R.defaultPort, connect, disconnect, isConnected,- getServer, getDatabase,+ getServer, getDatabase, renameCommand, -- * Redis commands -- ** Generic- ping, auth, quit, shutdown,- multi, exec, discard, run_multi, exists,+ ping, auth, echo, quit, shutdown,+ multi, exec, discard, run_multi,+ watch, unwatch, run_cas, exists, del, getType, keys, randomKey, rename, renameNx, dbsize, expire, expireAt, persist, ttl, select, move, flushDb,@@ -60,7 +62,8 @@ strlen, -- ** Lists- rpush, lpush, llen, lrange, ltrim,+ rpush, lpush, rpushx, lpushx,+ llen, lrange, ltrim, lindex, lset, lrem, lpop, rpop, rpoplpush, blpop, brpop, @@ -71,8 +74,8 @@ -- ** Sorted sets zadd, zrem, zincrBy, zrange,- zrevrange, zrangebyscore, zcount,- zremrangebyscore, zcard, zscore,+ zrevrange, zrangebyscore, zrevrangebyscore,+ zcount, zremrangebyscore, zcard, zscore, zrank, zrevrank, zremrangebyrank, zunion, zinter, zunionStore, zinterStore, @@ -99,6 +102,7 @@ import Control.Monad.State (StateT(..)) import Control.Applicative import Control.Monad.CatchIO+import Data.ByteString (ByteString) import qualified Database.Redis.Redis as R import Database.Redis.Redis (IsInterval)@@ -124,12 +128,19 @@ getDatabase :: WithRedis m => m Int getDatabase = getRedis >>= liftIO . R.getDatabase +renameCommand :: WithRedis m => ByteString -> ByteString -> m ()+renameCommand c c' = do r <- getRedis+ liftIO $ R.renameCommand r c c'+ ping :: WithRedis m => m (R.Reply ()) ping = getRedis >>= liftIO . R.ping auth :: WithRedis m => String -> m (R.Reply ()) auth pwd = getRedis >>= liftIO . flip R.auth pwd +echo :: (WithRedis m, BS s) => s -> m (R.Reply s)+echo s = getRedis >>= liftIO . flip R.echo s+ quit :: WithRedis m => m () quit = getRedis >>= liftIO . R.quit @@ -145,16 +156,15 @@ discard :: WithRedis m => m (R.Reply ()) discard = getRedis >>= liftIO . R.discard -run_multi :: (MonadCatchIO m, WithRedis m, BS s) => [m (R.Reply ())] -> m (R.Reply s)-run_multi cs = let cs' = map (>>= R.noError) cs- in do r <- getRedis- bracket (liftIO $ Internal.takeState r)- (\_ -> liftIO $ Internal.putStateUnmodified r)- (\rs -> do liftIO $ (Internal.sendCommand rs (Internal.CInline "MULTI") >> (Internal.recv rs :: IO (Internal.Reply ())))- sequence_ cs' `onException` (liftIO $ do Internal.sendCommand rs (Internal.CInline "DISCARD")- Internal.recv rs :: IO (Internal.Reply ()))- liftIO $ Internal.sendCommand rs (Internal.CInline "EXEC")- liftIO $ Internal.recv rs)+run_multi :: (MonadCatchIO m, WithRedis m, BS s) => m () -> m (R.Reply s)+run_multi cs = do r <- getRedis+ bracket (liftIO $ Internal.takeState r)+ (\_ -> liftIO $ Internal.putStateUnmodified r)+ (\rs -> do liftIO $ (Internal.sendCommand rs (Internal.CInline "MULTI") >> (Internal.recv rs :: IO (Internal.Reply ())))+ cs `onException` (liftIO $ do Internal.sendCommand rs (Internal.CInline "DISCARD")+ Internal.recv rs :: IO (Internal.Reply ()))+ liftIO $ Internal.sendCommand rs (Internal.CInline "EXEC")+ liftIO $ Internal.recv rs) watch :: (WithRedis m, BS s) => [s] -> m (R.Reply ()) watch cs = getRedis >>= liftIO . flip R.watch cs@@ -162,7 +172,7 @@ unwatch :: WithRedis m => m (R.Reply ()) unwatch = getRedis >>= liftIO . R.unwatch -run_cas :: (MonadCatchIO m, WithRedis m, BS s1, BS s2) => [s1] -> m (R.Reply s2) -> m (R.Reply s2)+run_cas :: (MonadCatchIO m, WithRedis m, BS s1) => [s1] -> m a -> m a run_cas keys cs = let keys' = map toBS keys in do r <- getRedis bracket (liftIO $ Internal.takeState r)@@ -296,6 +306,18 @@ lpush key val = do r <- getRedis liftIO $ R.lpush r key val +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++lpushx :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int)+lpushx key val = do r <- getRedis+ liftIO $ R.lpushx r key val++linsert :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> R.LInsertDirection -> s2 -> s3 -> m (R.Reply Int)+linsert key direction anchor value = do r <- getRedis+ liftIO $ R.linsert r key direction anchor value+ llen :: (WithRedis m, BS s) => s -> m (R.Reply Int) llen key = getRedis >>= liftIO . flip R.llen key @@ -329,11 +351,11 @@ rpoplpush src dst = do r <- getRedis liftIO $ R.rpoplpush r src dst -blpop :: (WithRedis m, BS s1, BS s2) => [s1] -> Int -> m (R.Reply s2)+blpop :: (WithRedis m, BS s1, BS s2) => [s1] -> Int -> m (Maybe (s1, s2)) blpop keys timeout = do r <- getRedis liftIO $ R.blpop r keys timeout -brpop :: (WithRedis m, BS s1, BS s2) => [s1] -> Int -> m (R.Reply s2)+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 @@ -409,6 +431,10 @@ zrangebyscore :: (WithRedis m, IsInterval i Double, BS s1, BS s2) => s1 -> i -> Maybe (Int, Int) -> Bool -> m (R.Reply s2) zrangebyscore key i limit withscores = do r <- getRedis liftIO $ R.zrangebyscore r key i limit withscores++zrevrangebyscore :: (WithRedis m, IsInterval i Double, BS s1, BS s2) => s1 -> i -> Maybe (Int, Int) -> Bool -> m (R.Reply s2)+zrevrangebyscore key i limit withscores = do r <- getRedis+ liftIO $ R.zrevrangebyscore r key i limit withscores zcount :: (WithRedis m, IsInterval i Double, BS s) => s -> i -> m (R.Reply Int) zcount key limit = do r <- getRedis
Database/Redis/Redis.hs view
@@ -29,6 +29,7 @@ Redis, Reply(..), Message(..),+ LInsertDirection(..), Interval(..), IsInterval(..), SortOptions(..),@@ -40,11 +41,11 @@ -- * Database connection localhost, defaultPort, connect, disconnect, isConnected,- getServer, getDatabase,+ getServer, getDatabase, renameCommand, -- * Redis commands -- ** Generic- ping, auth, quit, shutdown,+ ping, auth, echo, quit, shutdown, multi, exec, discard, run_multi, watch, unwatch, run_cas, exists, del, getType, keys, randomKey, rename,@@ -60,7 +61,8 @@ strlen, -- ** Lists- rpush, lpush, llen, lrange, ltrim,+ rpush, lpush, rpushx, lpushx,+ linsert, llen, lrange, ltrim, lindex, lset, lrem, lpop, rpop, rpoplpush, blpop, brpop, @@ -71,8 +73,8 @@ -- ** Sorted sets zadd, zrem, zincrBy, zrange,- zrevrange, zrangebyscore, zcount,- zremrangebyscore, zcard, zscore,+ zrevrange, zrangebyscore, zrevrangebyscore,+ zcount, zremrangebyscore, zcard, zscore, zrank, zrevrank, zremrangebyrank, zunion, zinter, zunionStore, zinterStore, @@ -102,6 +104,7 @@ import Data.ByteString (ByteString) import Data.Maybe (fromJust, isNothing) import Data.List (intersperse)+import qualified Data.Map as Map import Control.Monad (when) import Control.Exception (onException) @@ -139,6 +142,10 @@ RBulk s -> return s _ -> error $ "wrong reply, RBulk expected: " ++ (show reply) +-- | The same as fromRBulk but with fromJust applied+fromRBulk' :: (Monad m, BS s) => Reply s -> m s+fromRBulk' reply = fromRBulk reply >>= return . fromJust+ -- | Unwraps RMulti reply -- -- Throws an exception when called with something different from RMulti@@ -154,6 +161,10 @@ fromRMultiBulk :: (Monad m, BS s) => Reply s -> m (Maybe [Maybe s]) fromRMultiBulk reply = fromRMulti reply >>= return . (>>= sequence . map fromRBulk) +-- | The same as fromRMultiBulk but with fromJust applied+fromRMultiBulk' :: (Monad m, BS s) => Reply s -> m [s]+fromRMultiBulk' reply = fromRMultiBulk reply >>= return . fromJust >>= return . (map fromJust)+ -- | Unwraps RInt reply -- -- Throws an exception when called with something different from RInt@@ -202,7 +213,9 @@ mkpmsg [RBulk (Just p), RBulk (Just c), RBulk (Just msg)] = MPMessage (fromBS p) (fromBS c) (fromBS msg) -- | Conects to Redis server and returns connection descriptor-connect :: String -> String -> IO Redis+connect :: String -- ^ hostname or path to the redis socket+ -> String -- ^ port or null if unix sockets used+ -> IO Redis connect hostname port = do s <- if null port then socket_unix hostname@@ -211,10 +224,7 @@ h <- S.socketToHandle s IO.ReadWriteMode IO.hSetBuffering h (IO.BlockBuffering Nothing) - lcnt <- newMVar Nothing- l <- newMVar ()- st <- newIORef $ RedisState (hostname, port) 0 h 0- return $ Redis lcnt l st+ newRedis (hostname, port) h socket_inet :: String -> String -> IO S.Socket socket_inet hostname port =@@ -248,6 +258,14 @@ getDatabase :: Redis -> IO Int getDatabase = withState' (return . database) +-- | Adds command to renaming map+renameCommand :: Redis+ -> ByteString -- ^ command to rename+ -> ByteString -- ^ new name+ -> IO ()+renameCommand r c c' = inState_ r $ \rs -> let m = renamedCommands rs+ in return $ rs {renamedCommands = Map.insert c c' m}+ {- ============ Just commands ============= -} -- | ping - pong --@@ -255,6 +273,7 @@ ping :: Redis -> IO (Reply ()) ping = withState' (\rs -> sendCommand rs (CInline "PING") >> recv rs) +{- UNTESTED -} -- | Password authentication -- -- ROk returned@@ -264,10 +283,21 @@ -> IO (Reply ()) auth r pwd = withState r (\rs -> sendCommand rs (CMInline ["AUTH", toBS pwd] ) >> recv rs) +-- | Echo the given string+--+-- RBulk returned+echo :: BS s =>+ Redis+ -> s -- ^ what to echo+ -> IO (Reply s)+echo r s = withState r (\rs -> sendCommand rs (CMBulk ["ECHO", toBS s]) >> recv rs)++{- UNTESTED -} -- | Quit and close connection quit :: Redis -> IO () quit r = withState r (sendCommand' (CInline "QUIT")) >> disconnect r +{- UNTESTED -} -- | Stop all the clients, save the DB, then quit the server shutdown :: Redis -> IO () shutdown r = withState r (sendCommand' (CInline "SHUTDOWN")) >> disconnect r@@ -295,15 +325,14 @@ -- RMulti returned - replys for all executed commands run_multi :: (BS s) => Redis- -> [IO (Reply ())] -- ^ IO actions to run+ -> (Redis -> IO ()) -- ^ IO action to run -> IO (Reply s)-run_multi r cs = let cs' = map (>>= noError) cs- in withState r (\rs -> do sendCommand rs (CInline "MULTI")- (recv rs :: IO (Reply ())) >>= fromROk- (sequence_ cs') `onException` do sendCommand rs (CInline "DISCARD")- recv rs :: IO (Reply ())- sendCommand rs (CInline "EXEC")- recv rs)+run_multi r cs = withState r (\rs -> do sendCommand rs (CInline "MULTI")+ (recv rs :: IO (Reply ())) >>= fromROk+ cs r `onException` do sendCommand rs (CInline "DISCARD")+ recv rs :: IO (Reply ())+ sendCommand rs (CInline "EXEC")+ recv rs) -- | Add keys to a watch list for Check-and-Set operation. --@@ -331,18 +360,18 @@ -- terminated with /unwatch/ command even if /exec/ command was sent. -- -- Result of user-defined action returned-run_cas :: (BS s1, BS s2) =>+run_cas :: BS s1 => Redis- -> [s1] -- ^ keys watched- -> IO (Reply s2) -- ^ action to run- -> IO (Reply s2)+ -> [s1] -- ^ keys watched+ -> (Redis -> IO a) -- ^ action to run+ -> IO a run_cas r keys cs = let keys' = map toBS keys in withState r (\rs -> do sendCommand rs (CMBulk ("WATCH" : keys')) (recv rs :: IO (Reply ())) >>= fromROk- res <- cs `onException` do sendCommand rs (CInline "DISCARD")- recv rs :: IO (Reply ())- sendCommand rs (CInline "UNWATCH")- recv rs :: IO (Reply ())+ res <- cs r `onException` do sendCommand rs (CInline "DISCARD")+ recv rs :: IO (Reply ())+ sendCommand rs (CInline "UNWATCH")+ recv rs :: IO (Reply ()) sendCommand rs (CInline "UNWATCH") (recv rs :: IO (Reply ())) >>= fromROk return res)@@ -386,7 +415,7 @@ -- | Return random key name ----- RInline returned+-- RBulk returned randomKey :: BS s => Redis -> IO (Reply s) randomKey r = withState r (\rs -> sendCommand rs (CInline "RANDOMKEY") >> recv rs) @@ -437,7 +466,7 @@ expireAt :: BS s => Redis -> s -- ^ target key- -> Int -- ^ timeout in seconds+ -> Int -- ^ expiration time -> IO (Reply Int) expireAt r key timestamp = withState r (\rs -> sendCommand rs (CMBulk ["EXPIREAT", toBS key, toBS timestamp]) >> recv rs) @@ -494,6 +523,7 @@ flushAll :: Redis -> IO (Reply ()) flushAll r = withState r (\rs -> sendCommand rs (CInline "FLUSHALL") >> recv rs) +{- UNTESTED -} -- | Returns different information and statistics about the server -- -- for more information see <http://code.google.com/p/redis/wiki/InfoCommand>@@ -636,7 +666,10 @@ -> IO (Reply Int) append r key str = withState r (\rs -> sendCommand rs (CMBulk ["APPEND", toBS key, toBS str]) >> recv rs) --- | Get a substring. Indexes are zero-based.+-- | 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 substr :: (BS s1, BS s2) =>@@ -655,7 +688,7 @@ -> IO (Reply Int) strlen r key = withState r (\rs -> sendCommand rs (CMBulk ["STRLEN", toBS key]) >> recv rs) --- | Add string value to the head of the list-type key. New list+-- | Add string value to the tail of the list-type key. New list -- length returned -- -- RInt returned@@ -666,7 +699,7 @@ -> IO (Reply Int) rpush r key val = withState r (\rs -> sendCommand rs (CMBulk ["RPUSH", toBS key, toBS val]) >> recv rs) --- | Add string value to the tail of the list-type key. New list+-- | Add string value to the head of the list-type key. New list -- length returned -- -- RInt returned@@ -677,6 +710,46 @@ -> IO (Reply Int) lpush r key val = withState r (\rs -> sendCommand rs (CMBulk ["LPUSH", toBS key, toBS val]) >> 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+-- and (RInt 0) returned.+--+-- RInt returned+lpushx :: (BS s1, BS s2) =>+ Redis+ -> s1 -- ^ target key+ -> s2 -- ^ value to push+ -> IO (Reply Int)+lpushx r key val = withState r (\rs -> sendCommand rs (CMBulk ["LPUSHX", toBS key, toBS val]) >> recv rs)++-- | Add string value to the tail of existing list-type key. New list+-- length returned. If such a key was not exists, list is not created+-- and (RInt 0) returned.+--+-- RInt returned+rpushx :: (BS s1, BS s2) =>+ Redis+ -> s1 -- ^ target key+ -> s2 -- ^ value to push+ -> IO (Reply Int)+rpushx r key val = withState r (\rs -> sendCommand rs (CMBulk ["RPUSHX", toBS key, toBS val]) >> recv rs)++data LInsertDirection = BEFORE | AFTER deriving Show++-- | Inserts value in the list stored at key either before or after+-- the reference value pivot.+--+-- RInt returned - resulting list length or (RInt -1) if target element was not found.+linsert :: (BS s1, BS s2, BS s3) =>+ Redis+ -> s1 -- ^ target list+ -> LInsertDirection -- ^ where to insert - before or after+ -> s2 -- ^ target element+ -> s3 -- ^ inserted value+ -> IO (Reply Int)+linsert r key direction anchor value = withState r (\rs -> sendCommand rs (CMBulk ["LINSERT", toBS key, toBS $ show direction, toBS anchor, toBS value]) >> recv rs)+ -- | Return lenght of the list. Note that for not-existing keys it -- returns zero length. --@@ -787,8 +860,12 @@ Redis -> [s1] -- ^ keys list -> Int -- ^ timeout- -> IO (Reply s2)-blpop r keys timeout = withState r (\rs -> sendCommand rs (CMBulk (("BLPOP" : map toBS keys) ++ [toBS timeout])) >> recv rs)+ -> IO (Maybe (s1, s2))+blpop r keys timeout = withState r $ \rs -> do sendCommand rs (CMBulk (("BLPOP" : map toBS keys) ++ [toBS timeout]))+ res <- recv rs >>= fromRMultiBulk+ return $ case res of+ Nothing -> Nothing+ Just [Just k, Just v] -> Just (fromBS k, fromBS v) -- | Blocking rpop --@@ -799,8 +876,12 @@ Redis -> [s1] -- ^ keys list -> Int -- ^ timeout- -> IO (Reply s2)-brpop r keys timeout = withState r (\rs -> sendCommand rs (CMBulk (("BRPOP" : map toBS keys) ++ [toBS timeout])) >> recv rs)+ -> IO (Maybe (s1, s2))+brpop r keys timeout = withState r $ \rs -> do sendCommand rs (CMBulk (("BRPOP" : map toBS keys) ++ [toBS timeout]))+ res <- recv rs >>= fromRMultiBulk+ return $ case res of+ Nothing -> Nothing+ Just [Just k, Just v] -> Just (fromBS k, fromBS v) -- | Add the specified member to the set value stored at key --@@ -897,7 +978,7 @@ -- | The same as 'sinter' but instead of being returned the resulting set -- is stored ----- ROk returned+-- RInt returned - resulting set cardinality. sinterStore :: (BS s1, BS s2) => Redis -> s1 -- ^ where to store resulting set@@ -918,7 +999,7 @@ -- | The same as 'sunion' but instead of being returned the resulting set -- is stored ----- ROk returned+-- RInt returned - resulting set cardinality. sunionStore :: (BS s1, BS s2) => Redis -> s1 -- ^ where to store resulting set@@ -939,7 +1020,7 @@ -- | The same as 'sdiff' but instead of being returned the resulting -- set is stored ----- ROk returned+-- RInt returned - resulting set cardinality. sdiffStore :: (BS s1, BS s2) => Redis -> s1 -- ^ where to store resulting set@@ -1083,6 +1164,26 @@ i' = toInterval i in cmd `seq` withState r (\rs -> sendCommand rs (CMBulk cmd) >> recv rs) +-- | Return the all the elements in the sorted set with a score that+-- lays within a given interval. Elements is ordered from greater+-- score to lower. Interval passed into command must be reversed+-- (first value is greater then second)+--+-- RMulti filled with RBulk returned+zrevrangebyscore :: (IsInterval i Double, BS s1, BS s2) =>+ Redis+ -> s1+ -> i+ -> Maybe (Int, Int)+ -> Bool+ -> IO (Reply s2)+zrevrangebyscore r key i limit withscores = let cmd' = i' `seq` ["ZREVRANGEBYSCORE", toBS key, toBS (from i'), toBS (to i')]+ cmd'' = maybe cmd' (\(a, b) -> cmd' ++ ["LIMIT", toBS a, toBS b]) limit+ cmd | withscores = cmd'' ++ ["WITHSCORES"]+ | otherwise = cmd''+ i' = toInterval i+ in cmd `seq` withState r (\rs -> sendCommand rs (CMBulk cmd) >> recv rs)+ -- | Count a number of elements of the sorted set with a score that -- lays within a given interval --@@ -1129,23 +1230,25 @@ -> IO (Reply s3) zscore r key member = withState r (\rs -> sendCommand rs (CMBulk ["ZSCORE", toBS key, toBS member]) >> recv rs) --- | Returns sorted set element sequence number counting from zero+-- | Returns the rank of member in the sorted set stored at key, with+-- the scores ordered from low to high. ----- RInt returned+-- RInt returned or (RBulk Nothing) if value is not found in set. zrank :: (BS s1, BS s2) => Redis- -> s1- -> s2+ -> s1 -- ^ target key+ -> s2 -- ^ value -> IO (Reply Int) zrank r key member = withState r (\rs -> sendCommand rs (CMBulk ["ZRANK", toBS key, toBS member]) >> recv rs) --- | Returns sorted set element sequence number for reversed sort order+-- | Returns the rank of member in the sorted set stored at key, with+-- the scores ordered from high to low. ----- RInt returned+-- RInt returned or (RBulk Nothing) if value is not found in set. zrevrank :: (BS s1, BS s2) => Redis- -> s1- -> s2+ -> s1 -- ^ target key+ -> s2 -- ^ value -> IO (Reply Int) zrevrank r key member = withState r (\rs -> sendCommand rs (CMBulk ["ZREVRANK", toBS key, toBS member]) >> recv rs) @@ -1218,7 +1321,7 @@ aggr_s | aggregate == SUM = [] | otherwise = ["AGGREGATE", toBS (show aggregate)]- in withState r (\rs -> sendCommand rs (CMBulk (("ZINTER" : toBS dst : src_s) ++ weight_s ++ aggr_s)) >> recv rs)+ in withState r (\rs -> sendCommand rs (CMBulk (("ZINTERSTORE" : toBS dst : src_s) ++ weight_s ++ aggr_s)) >> recv rs) {-# DEPRECATED zinter "ZINTER command was renamed to ZINTERSTORE" #-} zinter :: (BS s1, BS s2) => Redis -> s1 -> [s2] -> [Double] -> Aggregate -> IO (Reply Int)@@ -1329,10 +1432,10 @@ -- | Return all the field names and associated values the hash holding -- in form of /[field1, value1, field2, value2...]/ ----- RMulti field with RBulk returned+-- RMulti field with RBulk returned. If key doesn't exists (RMulti []) returned. hgetall :: (BS s1, BS s2) => Redis- -> s1+ -> s1 -- ^ target key -> IO (Reply s2) hgetall r key = withState r (\rs -> sendCommand rs (CMBulk ["HGETALL", toBS key]) >> recv rs) @@ -1504,24 +1607,28 @@ then recv rs >>= parseMessage >>= return . Just else return Nothing +{- UNTESTED -} -- | Save the whole dataset on disk -- -- ROk returned save :: Redis -> IO (Reply ()) save r = withState r (\rs -> sendCommand rs (CInline "SAVE") >> recv rs) +{- UNTESTED -} -- | Save the DB in background -- -- ROk returned bgsave :: Redis -> IO (Reply ()) bgsave r = withState r (\rs -> sendCommand rs (CInline "BGSAVE") >> recv rs) +{- UNTESTED -} -- | Return the UNIX TIME of the last DB save executed with success -- -- RInt returned lastsave :: Redis -> IO (Reply Int) lastsave r = withState r (\rs -> sendCommand rs (CInline "LASTSAVE") >> recv rs) +{- UNTESTED -} -- | Rewrites the Append Only File in background -- -- ROk returned
+ Test.hs view
@@ -0,0 +1,46 @@+module Test where++import System.Environment+import Test.HUnit+import Test.Setup+import qualified Test.Connection as Connection+import qualified Test.GenericCommands as GenericCommands+import qualified Test.StringCommands as StringCommands+import qualified Test.ListCommands as ListCommands+import qualified Test.SetCommands as SetCommands+import qualified Test.ZSetCommands as ZSetCommands+import qualified Test.HashCommands as HashCommands+import qualified Test.SortCommands as SortCommands+import qualified Test.PubSubCommands as PubSubCommands+import qualified Test.MultiCommands as MultiCommands+import qualified Test.CASCommands as CASCommands+import qualified Test.Monad.MultiCommands as M_MultiCommands+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)]++mkTests Nothing = TestList $ map snd tests+mkTests (Just label) = TestList $ map snd $ filter ((== label) . fst) tests++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
+ Test/CASCommands.hs view
@@ -0,0 +1,82 @@+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]++test_watch_success = TestCase $ testRedis $+ do r <- ask+ addStr+ liftIO $ do watch r ["foo", "bar"]+ Just foo <- get r "foo" >>= fromRBulk+ multi r+ set r "foo" "bar" >>= noError+ set r "foo_" foo >>= noError+ exec r :: IO (Reply ())+ foo_ <- get r "foo_" >>= fromRBulk :: IO (Maybe String)+ assertEqual "" (Just foo) foo_+ get r "foo" >>= fromRBulk >>= assertEqual "" (Just "bar")++test_watch_fail = TestCase $ testRedis2 $+ do r1 <- ask+ r2 <- ask2+ addStr+ liftIO $ do watch r1 ["foo", "bar"]+ Just foo <- get r1 "foo" >>= fromRBulk :: IO (Maybe String)+ multi r1+ set r2 "foo" "baz" >>= fromROk+ set r1 "foo" "bar" >>= noError -- note that this statement will not executed+ set r1 "foo_" foo >>= noError+ exec r1 :: IO (Reply ())+ foo_ <- get r1 "foo_" >>= fromRBulk :: IO (Maybe String)+ assertEqual "" Nothing foo_+ get r1 "foo" >>= fromRBulk >>= assertEqual "" (Just "baz")++test_run_cas = TestCase $ testRedis2 $+ let act :: Redis -> IO String+ act r = do Just foo <- get r "foo" >>= fromRBulk+ multi r+ threadDelay 1000+ set r "foo" "bar" >>= noError+ set r "foo_" foo >>= noError+ exec r :: IO (Reply ())+ return foo++ in do r1 <- ask+ r2 <- ask2+ addStr+ liftIO $ do foo <- run_cas r1 ["foo", "bar"] act+ foo_ <- get r1 "foo_" >>= fromRBulk :: IO (Maybe String)+ assertEqual "" (Just foo) foo_+ get r1 "foo" >>= fromRBulk >>= assertEqual "" (Just "bar")++ del r1 "foo_"+ later 500 $ set r2 "foo" "baz"+ run_cas r1 ["foo", "bar"] act+ foo_ <- get r1 "foo_" >>= fromRBulk :: IO (Maybe String)+ assertEqual "" Nothing foo_+ get r1 "foo" >>= fromRBulk >>= assertEqual "" (Just "baz")++test_run_cas_exception = TestCase $ testRedis $+ let act :: Redis -> IO ()+ act r = do multi r+ set r "foo" "bar" >>= noError+ set r "bar" "foo" >>= noError+ error "bang!"+ exec r :: IO (Reply ())+ return ()+ in do r <- ask+ addStr+ liftIO $ do foo <- get r "foo" :: IO (Reply String)+ assertRaises "" (ErrorCall undefined) $ run_cas r ["foo", "bar"] act+ get r "foo" >>= assertEqual "" foo
+ Test/Connection.hs view
@@ -0,0 +1,28 @@+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++test_connection_state = TestCase $ testRedis $+ 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+ db <- getDatabase r+ assertEqual "Wrond database number in connection state" 1 db
+ Test/GenericCommands.hs view
@@ -0,0 +1,165 @@+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]++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_ping = TestCase $ 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 $+ do r <- ask+ liftIO $ echo r "foobar" >>= fromRBulk >>= assertEqual "" (Just "foobar")++test_exists_del = TestCase $ testRedis $+ do r <- ask+ addStr+ liftIO $ do e <- exists r "foo" >>= fromRInt+ assertEqual "foo exists" 1 e+ del r "foo"+ e <- exists r "foo" >>= fromRInt+ assertEqual "foo was deleted" 0 e++test_get_type = TestCase $ testRedis $+ do addAll+ mapM_ (uncurry checkType) [("foo", "string"),+ ("bar", "string"),+ ("list", "list"),+ ("set", "set"),+ ("zset", "zset"),+ ("hash", "hash"),+ ("no-such-key", "none")]+ where checkType key t = do r <- ask+ liftIO $ do t' <- getType r key >>= fromRInline+ assertEqual "" t t'++test_keys = TestCase $ testRedis $+ do r <- ask+ addStr+ addSet+ addZSet+ liftIO $ do res <- keys r "nokey" >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "There's no key named \"nokey\"" (Just []) res+ res <- keys r "foo" >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "One key named \"foo\"" (Just [Just "foo"]) res+ res <- keys r "*set" >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ 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 $+ do r <- ask+ addAll+ liftIO $ do res <- randomKey r >>= fromRBulk >>= return . fromJust+ assertOneOf "" ["foo", "bar", "list", "set", "zset", "hash"] res++test_rename = TestCase $ testRedis $+ do r <- ask+ addStr+ liftIO $ do exists r "zoo" >>= fromRInt >>= assertEqual "there is no zoo here!" 0+ foo <- get r "foo" :: IO (Reply String)+ rename r "foo" "zoo" >>= fromROk+ exists r "foo" >>= fromRInt >>= assertEqual "foo was renamed to zoo" 0+ exists r "zoo" >>= fromRInt >>= assertEqual "foo was renamed to zoo" 1+ get r "zoo" >>= assertEqual "" foo++test_renameNx = TestCase $ testRedis $+ do r <- ask+ addStr+ liftIO $ do renameNx r "foo" "bar" >>= fromRInt >>= assertEqual "" 0+ exists r "foo" >>= fromRInt >>= assertEqual "" 1++test_dbsize = TestCase $ 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 $+ do r <- ask+ addStr+ liftIO $ do expire r "foo" 0 >>= fromRInt >>= assertEqual "" 1+ exists r "foo" >>= fromRInt >>= assertEqual "foo has to be expired now" 0+ TOD now _ <- getClockTime+ expireAt r "bar" $ fromIntegral now+ exists r "bar" >>= fromRInt >>= assertEqual "bar has to be expired now" 0++test_ttl_persist = TestCase $ testRedis $+ do r <- ask+ addStr+ liftIO $ do ttl r "foo" >>= fromRInt >>= assertEqual "" (-1)+ expire r "foo" 30 >>= noError+ ttl r "foo" >>= fromRInt >>= assertBool "TTL is greater then expiration timeout" . (<= 30)+ persist r "foo" >>= noError+ ttl r "foo" >>= fromRInt >>= assertEqual "foo was persisted again" (-1)++test_move = TestCase $ testRedis $+ do r <- ask+ addStr+ liftIO $ do exists r "foo" >>= fromRInt >>= assertEqual "foo has to be in first database" 1+ move r "foo" 1+ exists r "foo" >>= fromRInt >>= assertEqual "now foo is in second database" 0+ select r 1+ exists r "foo" >>= fromRInt >>= assertEqual "now foo is in second database" 1++test_flushDb = TestCase $ testRedis $+ do r <- ask+ liftIO $ do select r 1+ set r "leave_it_alone" "hooray!"+ select r 0+ flushDb r+ dbsize r >>= fromRInt >>= assertEqual "first database was flushed" 0+ select r 1+ dbsize r >>= fromRInt >>= assertEqual "but not the second one" 1++test_flushAll = TestCase $ testRedis $+ do r <- ask+ liftIO $ do select r 1+ set r "baz" "no way"+ select r 0+ flushAll r+ dbsize r >>= fromRInt >>= assertEqual "first database was flushed" 0+ select r 1+ dbsize r >>= fromRInt >>= assertEqual "and the second database too" 0
+ Test/HashCommands.hs view
@@ -0,0 +1,101 @@+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++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]++asHash :: Reply String -> IO (Map String String)+asHash r = fromRMultiBulk r >>= return . M.fromList . build . map fromJust . fromJust+ where build (a:b:z) = (a, b) : build z+ build (a:[]) = error "unpaired element"+ build [] = []++test_hgetall = TestCase $ testRedis $+ let expected = M.fromList $ zip ["foo", "bar", "baz"] ["1", "2", "3"]+ in do r <- ask+ addHash+ liftIO $ do h <- hgetall r "hash" >>= asHash+ assertEqual "" expected h+ h <- hgetall r "no-such-key" >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "" (Just []) h++test_hkeys = TestCase $ testRedis $+ do r <- ask+ addHash+ liftIO $ do h <- hgetall r "hash" >>= asHash+ let expected = M.keys h+ k <- hkeys r "hash" >>= fromRMultiBulk >>= return . sort . map fromJust . fromJust+ assertEqual "" expected k+ k <- hkeys r "no-such-key" >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "" (Just []) k++test_hvals = TestCase $ testRedis $+ do r <- ask+ addHash+ liftIO $ do h <- hgetall r "hash" >>= asHash+ let expected = S.fromList $ M.elems h -- Data.Set for order-independent equality+ vals <- hvals r "hash" >>= fromRMultiBulk >>= return . S.fromList . map fromJust . fromJust+ assertEqual "" expected vals+ k <- hkeys r "no-such-key" >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "" (Just []) k++test_hlen = TestCase $ testRedis $+ do r <- ask+ addHash+ liftIO $ do h <- hgetall r "hash" >>= asHash+ l <- hlen r "hash" >>= fromRInt+ assertEqual "" (M.size h) l+ l <- hlen r "no-such-key" >>= fromRInt+ assertEqual "" 0 l++test_hexists_hset_hget_hdel = TestCase $ testRedis $+ do r <- ask+ addHash+ liftIO $ do hexists r "hash" "foo" >>= fromRInt >>= assertEqual "" 1+ hexists r "hash" "jaz" >>= fromRInt >>= assertEqual "" 0+ hdel r "hash" "foo" >>= fromRInt >>= assertEqual "" 1+ hdel r "hash" "jaz" >>= fromRInt >>= assertEqual "" 0+ hexists r "hash" "foo" >>= fromRInt >>= assertEqual "" 0+ hset r "hash" "foo" "1" >>= fromRInt >>= assertEqual "" 1+ hexists r "hash" "foo" >>= fromRInt >>= assertEqual "" 1+ hset r "hash" "foo" "bar" >>= fromRInt >>= assertEqual "" 0+ hget r "hash" "foo" >>= fromRBulk >>= assertEqual "" (Just "bar")+ hget r "hash" "jaz" >>= fromRBulk >>= assertEqual "" (Nothing :: Maybe String)++test_hmset_hmget = TestCase $ testRedis $+ do r <- ask+ addHash+ liftIO $ do h <- hgetall r "hash" >>= asHash+ h' <- hmget r "hash" ["foo", "bar"] >>= fromRMultiBulk >>= return . map fromJust . fromJust+ let h'' = M.fromList $ zip ["foo", "bar"] h'+ assertEqual "" h (M.union h'' h)+ hmset r "hash" [("foo", "foo"), ("bar", "bar")] >>= noError+ let expected = M.update (const $ Just "foo") "foo" $ M.update (const $ Just "bar") "bar" h+ h' <- hgetall r "hash" >>= asHash+ assertEqual "" expected h'++test_hincrby = TestCase $ 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+ assertEqual "" (h ! "foo" + 2) res+ hget r "hash" "foo" >>= fromRBulk >>= assertEqual "" (Just res)+ res <- hincrby r "hash" "foo" (-2) >>= fromRInt+ assertEqual "" (h ! "foo") res+ hget r "hash" "foo" >>= fromRBulk >>= assertEqual "" (Just res)
+ Test/ListCommands.hs view
@@ -0,0 +1,170 @@+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]++test_lrange = TestCase $ testRedis $+ do r <- ask+ addList+ liftIO $ do list <- lrange r "list" takeAll >>= fromRMultiBulk+ assertEqual "" (Just [Just "1", Just "2", Just "3"]) list+ list <- lrange r "list" (1, 1) >>= fromRMultiBulk+ assertEqual "" (Just [Just "2"]) list++test_llen = TestCase $ testRedis $+ do r <- ask+ addList+ liftIO $ do len <- llen r "list" >>= fromRInt+ Just list <- lrange r "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "equals to real list length" (length list) len+ 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 $+ do r <- ask+ addList+ liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk+ len <- rpush r "list" "4" >>= fromRInt+ assertEqual "list length was increased by 1" (length list + 1) len+ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk+ assertEqual "" (list ++ [(Just "4")]) list'++ len <- lpush r "list" "0" >>= fromRInt+ assertEqual "list length was increased by 1 again" (length list' + 1) len+ Just list'' <- lrange r "list" takeAll >>= fromRMultiBulk+ assertEqual "" ((Just "0") : list') list''++test_lpushx_rpushx = TestCase $ testRedis $+ do r <- ask+ addList+ liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk+ len <- rpushx r "list" "4" >>= fromRInt+ assertEqual "list length was increased by 1" (length list + 1) len+ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk+ assertEqual "" (list ++ [(Just "4")]) list'++ len <- lpushx r "list" "0" >>= fromRInt+ assertEqual "list length was increased by 1 again" (length list' + 1) len+ Just list'' <- lrange r "list" takeAll >>= fromRMultiBulk+ assertEqual "" ((Just "0") : list') list''++ lpushx r "no-such-key" "1" >>= fromRInt >>= assertEqual "List was not created" 0+ exists r "no-such-key" >>= fromRInt >>= assertEqual "List was not created" 0+ 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 $+ do r <- ask+ addList+ liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk+ len <- linsert r "list" BEFORE "2" "foo" >>= fromRInt+ assertEqual "list length was increased by 1" (length list + 1) len+ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk+ let excepted = let (a,b) = span (/= Just "2") list+ in a ++ ((Just "foo") : b)+ assertEqual "" excepted list'++ len <- linsert r "list" AFTER "foo" "bar" >>= fromRInt+ assertEqual "list length was increased by 1" (length list' + 1) len+ Just list'' <- lrange r "list" takeAll >>= fromRMultiBulk+ let excepted = let (a,b) = span (/= Just "foo") list'+ in a ++ (head b : Just "bar" : tail b)+ assertEqual "" excepted list''++test_ltrim = TestCase $ testRedis $+ do r <- ask+ addList+ liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk :: (IO (Maybe [Maybe String]))+ ltrim r "list" (1, 1) >>= fromROk+ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk+ assertEqual "" (take 1 $ drop 1 $ list) list'++test_lindex_lset = TestCase $ testRedis $+ do r <- ask+ addList+ liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk :: (IO (Maybe [Maybe String]))+ el <- lindex r "list" 1 >>= fromRBulk+ assertEqual "" (list !! 1) el+ lset r "list" 1 "4" >>= fromROk+ lindex r "list" 1 >>= fromRBulk >>= assertEqual "" (Just "4")++test_lrem = TestCase $ testRedis $+ do r <- ask+ addList+ liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk+ lrem r "list" 1 (fromJust $ list !! 1) >>= fromRInt >>= assertEqual ("delete only first value equals to " ++ (fromJust $ list !! 1)) 1+ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk+ assertEqual "" ((list !! 1) `delete` list) list'++test_lpor_rpop = TestCase $ testRedis $+ do r <- ask+ addList+ liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ lpop r "list" >>= fromRBulk >>= assertEqual "" (head list)+ rpop r "list" >>= fromRBulk >>= assertEqual "" (last list)+ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk+ assertEqual "" (init $ tail list) list'++test_rpoplpush = TestCase $ testRedis $+ do r <- ask+ addList+ liftIO $ do Just list <- lrange r "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ rpoplpush r "list" "list2" >>= fromRBulk >>= assertEqual "" (last list)+ rpoplpush r "list" "list2" >>= fromRBulk >>= assertEqual "" (last $ init list)+ Just list' <- lrange r "list" takeAll >>= fromRMultiBulk+ assertEqual "Two elemens was rpopped" (init $ init list) list'+ Just list'' <- lrange r "list2" takeAll >>= fromRMultiBulk+ assertEqual "Two elemens was lpushed" (reverse $ take 2 $ reverse list) list''++test_blpop = TestCase $ testRedis2 $+ do r1 <- ask+ r2 <- ask2+ addList+ liftIO $ do Just list <- lrange r1 "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ res <- blpop r1 ["bar", "list"] 1+ assertEqual "" (Just ("list", fromJust $ head list)) res+ Just list' <- lrange r1 "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "" (tail list) list'++ later 500 $ lpush r2 "zap" "1" >>= noError+ res <- blpop r1 ["zap"] 2+ assertEqual "" (Just ("zap", "1")) res+ exists r1 "zap" >>= fromRInt >>= assertEqual "" 0++ (blpop r1 ["zap"] 1 :: IO (Maybe (String, String))) >>= assertEqual "" Nothing++test_brpop = TestCase $ testRedis2 $+ do r1 <- ask+ r2 <- ask2+ addList+ liftIO $ do Just list <- lrange r1 "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ res <- brpop r1 ["bar", "list"] 1+ assertEqual "" (Just ("list", fromJust $ last list)) res+ Just list' <- lrange r1 "list" takeAll >>= fromRMultiBulk :: IO (Maybe [Maybe String])+ assertEqual "" (init list) list'++ later 500 $ lpush r2 "zap" "1" >>= noError+ res <- brpop r1 ["zap"] 2+ assertEqual "" (Just ("zap", "1")) res+ exists r1 "zap" >>= fromRInt >>= assertEqual "" 0++ (brpop r1 ["zap"] 1 :: IO (Maybe (String, String))) >>= assertEqual "" Nothing
+ Test/Lock.hs view
@@ -0,0 +1,36 @@+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 $+ do r1 <- ask+ r2 <- ask2+ liftIO $ do acquire r1 "lock" 1000 50 >>= assertBool ""+ acquire r2 "lock" 1000 50 >>= assertEqual "" False+ release r1 "lock"+ acquire r2 "lock" 1000 50 >>= assertBool ""++test_acquire_timeout = TestCase $ testRedis2 $+ let act v r = do acquire r "lock" 2000 50 >>= assertBool ""+ putMVar v "done"+ in do v <- liftIO newEmptyMVar+ r1 <- ask+ r2 <- ask2+ liftIO $ do acquire r1 "lock" 1000 50 >>= assertBool ""+ v2 <- later 500 $ do res <- tryTakeMVar v+ release r1 "lock"+ return res+ act v r2+ takeMVar v2 >>= assertEqual "" Nothing
+ Test/Monad/CASCommands.hs view
@@ -0,0 +1,57 @@+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++tests = TestList [TestLabel "run_cas" test_run_cas,+ TestLabel "run_cas that raised an exception" test_run_cas_exception]++run r = liftIO . runWithRedis r++test_run_cas = TestCase $ testRedis2 $+ let act :: RedisM String+ act = do Just foo <- get "foo" >>= fromRBulk+ multi+ liftIO $ threadDelay 1000+ set "foo" "bar" >>= noError+ set "foo_" foo >>= noError+ exec :: RedisM (Reply ())+ return foo++ in do r1 <- ask+ r2 <- ask2+ addStr+ run r1 $ do foo <- run_cas ["foo", "bar"] act+ foo_ <- get "foo_" >>= fromRBulk :: RedisM (Maybe String)+ liftIO $ assertEqual "" (Just foo) foo_+ get "foo" >>= fromRBulk >>= liftIO . assertEqual "" (Just "bar")++ del "foo_"++ liftIO $ later 500 $ runWithRedis r2 $ set "foo" "baz"++ run r1 $ do run_cas ["foo", "bar"] act+ foo_ <- get "foo_" >>= fromRBulk :: RedisM (Maybe String)+ liftIO $ assertEqual "" Nothing foo_+ get "foo" >>= fromRBulk >>= liftIO . assertEqual "" (Just "baz")++test_run_cas_exception = TestCase $ testRedis $+ let act :: RedisM ()+ act = do multi+ set "foo" "bar" >>= noError+ set "bar" "foo" >>= noError+ error "bang!"+ exec :: RedisM (Reply ())+ return ()+ in do r <- ask+ addStr+ foo <- run r $ (get "foo" :: RedisM (Reply String))+ liftIO $ assertRaises "" (ErrorCall undefined) $ runWithRedis r $ run_cas ["foo", "bar"] act+ run r $ get "foo" >>= liftIO . assertEqual "" foo
+ Test/Monad/MultiCommands.hs view
@@ -0,0 +1,60 @@+{-# 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++tests = TestList [TestLabel "run_multi" test_run_multi,+ TestLabel "run_multi with exception" test_run_multi_exception]++run r = liftIO . runWithRedis r++test_run_multi = TestCase $ testRedis2 $+ let act = do set "foo" "cool" >>= liftIO . assertRQueued ""+ set "baz" "baz" >>= liftIO . assertRQueued ""+ liftIO $ threadDelay 2000++ in do r1 <- ask+ r2 <- ask2+ addStr+ (foo :: Maybe String) <- run r2 $ do foo <- get "foo" >>= fromRBulk+ exists "baz" >>= fromRInt >>= liftIO . assertEqual "" 0+ return foo++ v <- liftIO $ later 1000 $ runWithRedis r2 $ get "foo" >>= liftIO . fromRBulk++ run r1 $ (run_multi act :: RedisM (Reply ()))++ liftIO $ takeMVar v >>= assertEqual "exec was not called yet" foo++ 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 $+ let act = do set "foo" "cool" >>= liftIO . assertRQueued ""+ set "baz" "baz" >>= liftIO . assertRQueued ""+ liftIO $ threadDelay 2000+ error "bang!"++ in do r1 <- ask+ r2 <- ask2+ addStr+ foo <- run r2 $ do foo <- get "foo" >>= fromRBulk :: RedisM (Maybe String)+ exists "baz" >>= fromRInt >>= liftIO . assertEqual "" 0+ return foo++ v <- liftIO $ later 1000 $ runWithRedis r2 $ get "foo" >>= fromRBulk++ liftIO $ assertRaises "" (ErrorCall undefined) $ runWithRedis r1 $ (run_multi act :: RedisM (Reply ())) >> return ()++ liftIO $ takeMVar v >>= assertEqual "exec was not called yet" foo++ run r2 $ do get "foo" >>= fromRBulk >>= liftIO . assertEqual "exception catched and multi statement was discarder" foo+ exists "baz" >>= fromRInt >>= liftIO . assertEqual "exception catched and multi statement was discarder" 0
+ Test/MultiCommands.hs view
@@ -0,0 +1,94 @@+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]++test_multi_exec = TestCase $ testRedis2 $+ do r1 <- ask+ r2 <- ask2+ addStr+ liftIO $ do foo <- get r2 "foo" >>= fromRBulk :: IO (Maybe String)+ exists r2 "baz" >>= fromRInt >>= assertEqual "" 0++ multi r1+ set r1 "foo" "cool" >>= assertRQueued ""+ set r1 "baz" "baz" >>= assertRQueued ""++ get r2 "foo" >>= fromRBulk >>= assertEqual "exec was not called yet" foo+ exists r2 "baz" >>= fromRInt >>= assertEqual "exec was not called yet" 0++ (exec r1 :: IO (Reply String)) >>= fromRMulti >>= assertEqual "" (Just [ROk, ROk])++ 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 $+ do r1 <- ask+ r2 <- ask2+ addStr+ liftIO $ do foo <- get r2 "foo" >>= fromRBulk :: IO (Maybe String)+ exists r2 "baz" >>= fromRInt >>= assertEqual "" 0++ multi r1+ set r1 "foo" "cool" >>= assertRQueued ""+ set r1 "baz" "baz" >>= assertRQueued ""++ get r2 "foo" >>= fromRBulk >>= assertEqual "exec was not called yet" foo+ exists r2 "baz" >>= fromRInt >>= assertEqual "exec was not called yet" 0++ discard r1 >>= assertEqual "" ROk++ get r2 "foo" >>= fromRBulk >>= assertEqual "statements was discarder" foo+ exists r2 "baz" >>= fromRInt >>= assertEqual "statements was discarded" 0++test_run_multi = TestCase $ testRedis2 $+ let act r = do (set r "foo" "cool" :: IO (Reply ())) >>= assertRQueued ""+ (set r "baz" "baz" :: IO (Reply ())) >>= assertRQueued ""+ threadDelay 2000++ in do r1 <- ask+ r2 <- ask2+ addStr+ liftIO $ do foo <- get r2 "foo" >>= fromRBulk :: IO (Maybe String)+ exists r2 "baz" >>= fromRInt >>= assertEqual "" 0++ v <- later 1000 $ get r2 "foo" >>= fromRBulk++ run_multi r1 act :: IO (Reply ())++ takeMVar v >>= assertEqual "exec was not called yet" foo++ 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 $+ let act r = do (set r "foo" "cool" :: IO (Reply ())) >>= assertRQueued ""+ (set r "baz" "baz" :: IO (Reply ())) >>= assertRQueued ""+ threadDelay 2000+ error "bang!"++ in do r1 <- ask+ r2 <- ask2+ addStr+ liftIO $ do foo <- get r2 "foo" >>= fromRBulk :: IO (Maybe String)+ exists r2 "baz" >>= fromRInt >>= assertEqual "" 0++ v <- later 1000 $ get r2 "foo" >>= fromRBulk++ assertRaises "" (ErrorCall undefined) $ (run_multi r1 act :: IO (Reply ())) >> return ()++ takeMVar v >>= assertEqual "exec was not called yet" foo++ get r2 "foo" >>= fromRBulk >>= assertEqual "exception catched and multi statement was discarder" foo+ exists r2 "baz" >>= fromRInt >>= assertEqual "exception catched and multi statement was discarder" 0
+ Test/PubSubCommands.hs view
@@ -0,0 +1,83 @@+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]++test_subscribe_unsubscribe = TestCase $ testRedis $+ do r <- ask+ liftIO $ do subscribed r >>= assertEqual "" 0+ res <- subscribe r ["foo", "bar"]+ assertEqual "" [MSubscribe "foo" 1, MSubscribe "bar" 2] res+ subscribed r >>= assertEqual "" 2++ res <- subscribe r ["foo", "baz"]+ assertEqual "" [MSubscribe "foo" 2, MSubscribe "baz" 3] res+ subscribed r >>= assertEqual "" 3++ res <- unsubscribe r ["foo"]+ assertEqual "" [MUnsubscribe "foo" 2] res+ subscribed r >>= assertEqual "" 2++ ping r >>= assertRError ""++ res <- unsubscribe r ([] :: [String]) :: IO [Message String]+ subscribed r >>= assertEqual "" 0++test_psubscribe_punsubscribe = TestCase $ testRedis $+ do r <- ask+ liftIO $ do subscribed r >>= assertEqual "" 0+ res <- psubscribe r ["foo*", "bar*"]+ assertEqual "" [MPSubscribe "foo*" 1, MPSubscribe "bar*" 2] res+ subscribed r >>= assertEqual "" 2++ res <- psubscribe r ["foo*", "baz*"]+ assertEqual "" [MPSubscribe "foo*" 2, MPSubscribe "baz*" 3] res+ subscribed r >>= assertEqual "" 3++ res <- punsubscribe r ["foo*"]+ assertEqual "" [MPUnsubscribe "foo*" 2] res+ subscribed r >>= assertEqual "" 2++ ping r >>= assertRError ""++ res <- punsubscribe r ([] :: [String]) :: IO [Message String]+ subscribed r >>= assertEqual "" 0++test_publish_listen = TestCase $ testRedis2 $+ do r1 <- ask+ r2 <- ask2+ liftIO $ do subscribed r1 >>= assertEqual "" 0+ subscribe r1 ["foo"] :: IO [Message ()]+ v <- later 500 $ publish r2 "foo" "bar" >>= fromRInt+ msg <- listen r1 1000+ assertEqual "" (Just $ MMessage "foo" "bar") msg+ takeMVar v >>= assertEqual "" 1++ (listen r1 500 :: IO (Maybe (Message String))) >>= assertEqual "" Nothing++test_publish_listen_p = TestCase $ testRedis2 $+ do r1 <- ask+ r2 <- ask2+ liftIO $ do subscribed r1 >>= assertEqual "" 0+ psubscribe r1 ["foo*", "f*"] :: IO [Message ()]+ v <- later 500 $ publish r2 "fun" "funny" >>= fromRInt+ msg <- listen r1 1000+ assertEqual "" (Just $ MPMessage "f*" "fun" "funny") msg+ takeMVar v >>= assertEqual "" 1+ v <- later 500 $ publish r2 "foot" "football" >>= fromRInt+ msg <- listen r1 1000+ assertEqual "" (Just $ MPMessage "foo*" "foot" "football") msg+ msg <- listen r1 1000+ assertEqual "" (Just $ MPMessage "f*" "foot" "football") msg+ takeMVar v >>= assertEqual "" 2+ (listen r1 500 :: IO (Maybe (Message String))) >>= assertEqual "" Nothing
+ Test/SetCommands.hs view
@@ -0,0 +1,123 @@+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]++asSet :: Reply String -> IO (Set (Maybe String))+asSet r = fromRMultiBulk r >>= return . fromList . fromJust+ +test_smembers = TestCase $ 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 $+ 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 $+ do r <- ask+ addSet+ liftIO $ do s <- smembers r "set" >>= asSet+ sadd r "set" "3" >>= fromRInt >>= assertEqual "element allready exists" 0+ sadd r "set" "4" >>= fromRInt >>= assertEqual "" 1+ s' <- smembers r "set" >>= asSet+ assertEqual "" (insert (Just "4") s) s'++test_srem = TestCase $ testRedis $+ do r <- ask+ addSet+ liftIO $ do s <- smembers r "set" >>= asSet+ srem r "set" "4" >>= fromRInt >>= assertEqual "element is not a member" 0+ srem r "set" "3" >>= fromRInt >>= assertEqual "" 1+ s' <- smembers r "set" >>= asSet+ assertEqual "" (delete (Just "3") s) s'++test_spop = TestCase $ testRedis $+ do r <- ask+ addSet+ liftIO $ do s <- smembers r "set" >>= asSet+ el <- spop r "set" >>= fromRBulk :: IO (Maybe String)+ assertBool "" $ member el s+ s' <- smembers r "set" >>= asSet+ assertEqual "" (delete el s) s'++test_smove = TestCase $ testRedis $+ do r <- ask+ addSet+ liftIO $ do s <- smembers r "set" >>= asSet+ smove r "set" "set2" "3" >>= fromRInt >>= assertEqual "" 1+ s' <- smembers r "set" >>= asSet+ assertEqual "" (delete (Just "3") s) s'+ s' <- smembers r "set2" >>= asSet+ assertEqual "" (fromList [Just "3"]) s'++test_scard = TestCase $ testRedis $+ do r <- ask+ addSet+ liftIO $ do s <- smembers r "set" >>= asSet+ scard r "set" >>= fromRInt >>= assertEqual "" (size s)++test_srandmember = TestCase $ 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 $+ do r <- ask+ addSet+ liftIO $ do mapM_ (sadd r "set2") ["2", "3", "4"]+ s <- smembers r "set" >>= asSet+ s2 <- smembers r "set2" >>= asSet+ s3 <- sinter r ["set", "set2"] >>= asSet+ assertEqual "" (intersection s s2) s3+ sinterStore r "set3" ["set", "set2"] >>= fromRInt >>= assertEqual "" (size s3)+ smembers r "set3" >>= asSet >>= assertEqual "" s3+ sinterStore r "set3" ["set", "set4"] >>= fromRInt >>= assertEqual "" 0++test_sunion_sunionstore = TestCase $ testRedis $+ do r <- ask+ addSet+ liftIO $ do mapM_ (sadd r "set2") ["3", "4", "5"]+ s <- smembers r "set" >>= asSet+ s2 <- smembers r "set2" >>= asSet+ s3 <- sunion r ["set", "set2"] >>= asSet+ assertEqual "" (union s s2) s3+ sunionStore r "set3" ["set", "set2"] >>= fromRInt >>= assertEqual "" (size s3)+ smembers r "set3" >>= asSet >>= assertEqual "" s3+ sunionStore r "set3" ["set", "set4"] >>= fromRInt >>= assertEqual "" (size s)++test_sdiff_sdiffstore = TestCase $ testRedis $+ do r <- ask+ addSet+ liftIO $ do mapM_ (sadd r "set2") ["3", "4", "5"]+ s <- smembers r "set" >>= asSet+ s2 <- smembers r "set2" >>= asSet+ s3 <- sdiff r ["set", "set2"] >>= asSet+ assertEqual "" (difference s s2) s3+ 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/Setup.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE FlexibleContexts #-}+module Test.Setup where++import Control.Exception (bracket)+import Control.Concurrent+import Control.Monad.Reader+import Test.HUnit+import System.Cmd+import System.Directory+import System.FilePath+import Database.Redis.Redis++startRedis :: FilePath -> IO ()+startRedis path_to_redis = do cwd <- getCurrentDirectory+ system $ path_to_redis ++ " " ++ (cwd </> "redis.conf")+ 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+ return r+ teardown r = do flushAll 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+ return (r1, r2)+ teardown (r1, r2) = do flushAll r1+ disconnect r1+ disconnect r2++ask2 :: (MonadReader a m, MonadTrans t) => t m a+ask2 = lift ask++addStr :: (MonadReader Redis m, MonadIO m) => m ()+addStr = do r <- ask+ liftIO $ do set r "foo" "foo"+ set r "bar" "bar"+ return ()++addList :: (MonadReader Redis m, MonadIO m) => m ()+addList = do r <- ask+ liftIO $ mapM_ (rpush r "list") ["1", "2", "3"]+++addSet :: (MonadReader Redis m, MonadIO m) => m ()+addSet = do r <- ask+ liftIO $ mapM_ (sadd r "set") ["1", "2", "3"]++addZSet :: (MonadReader Redis m, MonadIO m) => m ()+addZSet = do r <- ask+ liftIO $ mapM_ (uncurry (zadd r "zset")) $ zip (reverse [1.0, 2.0, 3.0, 4.0, 5.0]) ["1", "2", "3", "4", "5"]++addHash :: (MonadReader Redis m, MonadIO m) => m ()+addHash = do r <- ask+ liftIO $ mapM_ (uncurry (hset r "hash")) $ zip ["foo", "bar", "baz"] ["1", "2", "3"]++addAll :: (MonadReader Redis m, MonadIO m) => m ()+addAll = addStr >> addList >> addSet >> addZSet >> addHash
+ Test/SortCommands.hs view
@@ -0,0 +1,90 @@+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]++addUserList name l = do r <- ask+ lift $ mapM_ (rpush r name) l++unsortedList = randomRIOs ((0 :: Int), 99) 10+unsortedAlphaList = randomRIOs ('a', 'z') 10+unsortedAlphaList2 = randomRIOs ('а', 'я') 10 -- non-ASCII string++test_sort_asc_desc = TestCase $ testRedis $+ do r <- ask+ l <- liftIO unsortedList+ addUserList "l" l+ liftIO $ do l' <- sort r "l" sortDefaults >>= fromRMultiBulk >>= return . map fromJust . fromJust+ assertEqual "" (L.sort l) l'+ l' <- sort r "l" sortDefaults{desc = True} >>= fromRMultiBulk >>= return . map fromJust . fromJust+ assertEqual "" (reverse $ L.sort l) l'++test_sort_alpha = TestCase $ testRedis $+ do r <- ask+ l1 <- liftIO unsortedAlphaList+ l2 <- liftIO unsortedAlphaList2+ addUserList "l1" l1+ addUserList "l2" l2+ liftIO $ do l' <- sort r "l1" sortDefaults{alpha = True} >>= fromRMultiBulk >>= return . map fromJust . fromJust+ assertEqual "" (L.sort l1) l'+ l' <- sort r "l2" sortDefaults{alpha = True} >>= fromRMultiBulk >>= return . map fromJust . fromJust+ assertEqual "" (L.sort l2) l'+ l' <- sort r "l1" sortDefaults{desc = True, alpha = True} >>= fromRMultiBulk >>= return . map fromJust . fromJust+ assertEqual "" (reverse $ L.sort l1) l'+ 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 $+ do r <- ask+ l <- liftIO unsortedList+ addUserList "l" l+ -- set bounch of kes foo_* for sort l in reverse order+ liftIO $ mapM_ (\x -> set r ("foo_" ++ show x) (-x)) [(0 :: Int)..99]++ liftIO $ do l' <- sort r "l" sortDefaults{sort_by = fromString "foo_*"} >>= fromRMultiBulk >>= return . map fromJust . fromJust+ assertEqual "" (reverse $ L.sort l) l'+ l' <- sort r "l" sortDefaults{sort_by = fromString "constant"} >>= fromRMultiBulk >>= return . map fromJust . fromJust+ assertEqual "" l l'++test_sort_get = TestCase $ testRedis $+ do r <- ask+ l <- liftIO unsortedAlphaList+ addUserList "l" l+ liftIO $ mapM_ (\x -> set r ("foo_" ++ [x]) (toUpper x) >> set r ("bar_" ++ [x]) 'x') ['a' .. 'z']++ 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 $+ do r <- ask+ l <- liftIO unsortedAlphaList+ addUserList "l" l+ liftIO $ mapM_ (\x -> set r ("foo_" ++ [x]) (toUpper x) >> set r ("bar_" ++ [x]) 'x') ['a' .. 'z']+ liftIO $ do l' <- sort r "l" sortDefaults{alpha = True, get_obj = [fromString "foo_*"]} >>= fromRMultiBulk >>= return . map fromJust . fromJust :: IO [Char]+ (sort r "l" sortDefaults{alpha = True, get_obj = [fromString "foo_*"], store = fromString "l2"} :: IO (Reply ())) >>= noError+ l'' <- lrange r "l2" takeAll >>= fromRMultiBulk >>= return . map fromJust . fromJust+ assertEqual "" l' l''++test_listRelated = TestCase $ testRedis $+ do r <- ask+ addList+ liftIO $ mapM_ (\x -> set r ("foo_" ++ show x) (x^2)) [(1 :: Int)..3]+ liftIO $ do l <- lrange r "list" takeAll >>= fromRMultiBulk >>= return . map fromJust . fromJust :: IO [Int]+ l' <- listRelated r "foo_*" "list" takeAll >>= fromRMultiBulk >>= return . map fromJust . fromJust+ assertEqual "" (map (^2) l) l'
+ Test/StringCommands.hs view
@@ -0,0 +1,92 @@+module Test.StringCommands where++import Test.HUnit+import Control.Monad.Reader+import Data.Maybe+import Database.Redis.Redis+import Test.Setup+import Test.Utils++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]++test_set_get = TestCase $ 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 $+ 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 $+ 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 $+ 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 $+ 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 $+ 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 $+ 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")+ incrBy r "i" 2 >>= fromRInt >>= assertEqual "" 3+ (get r "i" :: IO (Reply String)) >>= fromRBulk >>= assertEqual "" (Just "3")+ decr r "i" >>= fromRInt >>= assertEqual "" 2+ (get r "i" :: IO (Reply String)) >>= fromRBulk >>= assertEqual "" (Just "2")+ decrBy r "i" 2 >>= fromRInt >>= assertEqual "" 0+ (get r "i" :: IO (Reply String)) >>= fromRBulk >>= assertEqual "" (Just "0")++test_append = TestCase $ testRedis $+ do r <- ask+ addStr+ liftIO $ do Just foo <- get r "foo" >>= fromRBulk+ newlength <- append r "foo" "foo" >>= fromRInt+ Just foo' <- get r "foo" >>= fromRBulk+ assertEqual ("Expected: \"" ++ foo ++ "\" ++ \"foo\"") (foo ++ "foo") foo'+ assertEqual "" (length foo') newlength++test_substr = TestCase $ 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 $+ do r <- ask+ addStr+ liftIO $ do Just foo <- get r "foo" >>= fromRBulk+ strlen r "foo" >>= fromRInt >>= assertEqual ("lenght of \"" ++ foo ++ "\"" ) (length foo)
+ Test/Utils.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+module Test.Utils where++import System.Random+import Control.Monad+import Test.HUnit+import Control.Exception+import Control.Concurrent+import Control.Concurrent.MVar+import Database.Redis.Redis+import Database.Redis.ByteStringClass++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 610+assertRaises :: (Show a, Control.Exception.Exception e, Show e) =>+ String -> e -> IO a -> IO ()+#else+assertRaises :: Show a => String -> Control.Exception.Exception -> IO a -> IO ()+#endif+assertRaises msg selector action =+ let {- thetest e = if e == selector then return ()+ else assertFailure $ msg ++ "\nReceived unexpected exception: "+ ++ (show e) ++ "\ninstead of exception: " ++ (show selector)+ -}+ thetest :: a -> a -> IO ()+ thetest _ e = return ()+ in do r <- Control.Exception.try action+ case r of+ Left e -> thetest selector e+ Right _ -> assertFailure $ msg ++ "\nReceived no exception, but was expecting exception: " ++ (show selector)++assertOneOf :: (Eq a, Show a) => String -> [a] -> a -> Assertion+assertOneOf msg lst a = find lst+ where find [] = assertFailure (msg ++ "\n" ++ show a ++ " not found in " ++ show lst)+ find (x:xs) = if a == x+ then return ()+ else find xs++assertRError :: BS a => String -> Reply a -> Assertion+assertRError msg (RError _) = return ()+assertRError msg r = assertFailure $ msg ++ "\n" ++ show r ++ " is not a RError"++assertRQueued :: BS a => String -> Reply a -> Assertion+assertRQueued msg RQueued = return ()+assertRQueued msg r = assertFailure $ msg ++ "\n" ++ show r ++ " is not a RQueued"++{------------------ Concurrent ------------------}+later :: Int -> IO a -> IO (MVar a)+later t a = do v <- newEmptyMVar+ forkIO $ threadDelay t >> a >>= putMVar v+ return v++{-------------------- Random --------------------}+(.:.) = liftM2 (:)+infixr 5 .:.++randomRIOs _ 0 = return []+randomRIOs range n = randomRIO range .:. randomRIOs range (n-1)
+ Test/ZSetCommands.hs view
@@ -0,0 +1,195 @@+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]++asZSet :: Reply String -> IO [(String, Double)]+asZSet r = fromRMultiBulk r >>= return . build . map fromJust . fromJust+ where build (a:b:z) = (a, read b) : build z+ build (a:[]) = error "unpaired element"+ build [] = []++zsort :: [(String, Double)] -> [(String, Double)]+zsort = sortBy (\(_, a) (_, b) -> compare a b)++test_zrange_zrevrange_zcard = TestCase $ 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+ liftIO $ do zrange r "zset" takeAll True >>= asZSet >>= assertEqual "" expected+ zrevrange r "zset" takeAll True >>= asZSet >>= assertEqual "" (reverse expected)+ zcard r "zset" >>= fromRInt >>= assertEqual "" (length expected)+ zcard r "no-such-key" >>= fromRInt >>= assertEqual "" 0+ zrange r "no-such-key" takeAll True >>= asZSet >>= assertEqual "" []+ zrevrange r "no-such-key" takeAll True >>= asZSet >>= assertEqual "" []+ zrange r "zset" (1,2) True >>= asZSet >>= assertEqual "" (take 2 $ drop 1 $ expected)+ zrevrange r "zset" (1,2) True >>= asZSet >>= assertEqual "" (take 2 $ drop 1 $ reverse expected)+ 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 $+ do r <- ask+ addZSet+ liftIO $ do zadd r "zset" 0.5 "6" >>= fromRInt >>= assertEqual "" 1+ zadd r "zset" 0.6 "1" >>= fromRInt >>= assertEqual "element is allready in set" 0+ z <- zrange r "zset" takeAll True >>= asZSet+ assertEqual "" ("6", 0.5) $ head z+ assertEqual "" ("1", 0.6) $ head $ tail z+ zrem r "zset" "6" >>= fromRInt >>= assertEqual "" 1+ zrem r "zset" "6" >>= fromRInt >>= assertEqual "" 0+ z <- zrange r "zset" takeAll True >>= asZSet+ assertEqual "" ("1", 0.6) $ head z++test_zscore = TestCase $ testRedis $+ let lookupBy _ _ [] = Nothing+ lookupBy f a (l:ls) = if f l == a+ then Just l+ else lookupBy f a ls+ in do r <- ask+ addZSet+ liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet+ let expected = snd `fmap` lookupBy fst "1" z+ score <- zscore r "zset" "1" >>= fromRBulk :: IO (Maybe Double)+ assertEqual "" expected score++test_zincrBy = TestCase $ testRedis $+ do r <- ask+ addZSet+ liftIO $ do zincrBy r "zset" 0.5 "5" >>= fromRBulk >>= assertEqual "" (Just (1.5 :: Double))+ score <- zscore r "zset" "5" >>= fromRBulk+ assertEqual "" (Just (1.5 :: Double)) score+ zincrBy r "zset" (-0.5) "5" >>= fromRBulk >>= assertEqual "" (Just (1.0 :: Double))+ score <- zscore r "zset" "5" >>= fromRBulk+ assertEqual "" (Just (1.0 :: Double)) score++test_zrangebyscore = TestCase $ testRedis $+ do r <- ask+ addZSet+ liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet+ z' <- zrangebyscore r "zset" [1, 4] (Just (1, 2)) True >>= asZSet+ let expected = take 2 $ drop 1 $ filter ((\x -> x >= 1 && x <= 4) . snd) z+ assertEqual "" expected z'+ z' <- zrangebyscore r "zset" (1 :: Double, 4 :: Double) (Just (1, 2)) True >>= asZSet+ let expected = take 2 $ drop 1 $ filter ((\x -> x > 1 && x < 4) . snd) z+ assertEqual "" expected z'++test_zrevrangebyscore = TestCase $ testRedis $+ do r <- ask+ addZSet+ liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet+ z' <- zrevrangebyscore r "zset" [4, 1] (Just (1, 2)) True >>= asZSet+ let expected = take 2 $ drop 1 $ reverse $ filter ((\x -> x >= 1 && x <= 4) . snd) z+ assertEqual "[1, 4]" expected z'+ z' <- zrevrangebyscore r "zset" (4 :: Double, 1 :: Double) (Just (1, 2)) True >>= asZSet+ let expected = take 2 $ drop 1 $ reverse $ filter ((\x -> x > 1 && x < 4) . snd) z+ assertEqual "(1, 4)" expected z'++test_zcount = TestCase $ testRedis $+ do r <- ask+ addZSet+ liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet+ z' <- zcount r "zset" [1, 4] >>= fromRInt+ let expected = filter ((\x -> x >= 1 && x <= 4) . snd) z+ assertEqual "" (length expected) z'+ z' <- zcount r "zset" (1 :: Double, 4 :: Double) >>= fromRInt+ let expected = filter ((\x -> x > 1 && x < 4) . snd) z+ assertEqual "" (length expected) z'++test_zremrangebyscore = TestCase $ testRedis $+ do r <- ask+ addZSet+ liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet+ let removed = filter ((\x -> x >= 1 && x <= 4) . snd) z+ left = filter (not . (\x -> x >= 1 && x <= 4) . snd) z+ zremrangebyscore r "zset" (1, 4) >>= fromRInt >>= assertEqual "" (length removed)+ z' <- zrange r "zset" takeAll True >>= asZSet+ assertEqual "" left z'++test_zrank_zrevrank = TestCase $ testRedis $+ let rank e = findIndex (== e)+ in do r <- ask+ addZSet+ liftIO $ do z <- zrange r "zset" takeAll False >>= fromRMultiBulk >>= return . fromJust+ c <- zrank r "zset" "3" >>= fromRInt+ assertEqual "" (fromJust $ rank (Just "3") z) c+ c <- zrevrank r "zset" "3" >>= fromRInt+ assertEqual "" (fromJust $ rank (Just "3") $ reverse z) c++ {- The next one doesn't works because of zrank returning+ "RBulk Nil" if requested element is not a+ member of set+ zrank r "zset" "6" >>= fromRInt+ -}++test_zremrangebyrank = TestCase $ testRedis $+ do r <- ask+ addZSet+ liftIO $ do z <- zrange r "zset" takeAll False >>= fromRMultiBulk >>= return . fromJust :: IO [Maybe String]+ let expected = (take 1 z) ++ (drop 4 $ z) -- cut elements from 1 to 3+ zremrangebyrank r "zset" (1, 3) >>= fromRInt >>= assertEqual "" (length z - length expected)+ z' <- zrange r "zset" takeAll False >>= fromRMultiBulk >>= return . fromJust :: IO [Maybe String]+ assertEqual "" expected z'++test_zunionStore = TestCase $ 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+ addZSet+ addZSet2 "zset2" zmap2+ liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet+ let zmap = fromList z :: Map String Double+ expected = zsort $ toList $ unionWith (+) zmap zmap2+ res <- zunionStore r "zset3" ["zset", "zset2"] [1, 1] SUM >>= fromRInt+ assertEqual "" (length expected) res+ z' <- zrange r "zset3" takeAll True >>= asZSet+ assertEqual "" expected z'++ let zmap = fromList z :: Map String Double+ -- in Redis weights is applied to maps before aggregation+ expected = zsort $ toList $ unionWith (+) zmap $ M.map (* 0.5) zmap2+ res <- zunionStore r "zset3" ["zset", "zset2"] [1, 0.5] SUM >>= fromRInt+ assertEqual "" (length expected) res+ z' <- zrange r "zset3" takeAll True >>= asZSet+ assertEqual "" expected z'++test_zinterStore = TestCase $ 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+ addZSet+ addZSet2 "zset2" zmap2+ liftIO $ do z <- zrange r "zset" takeAll True >>= asZSet+ let zmap = fromList z :: Map String Double+ expected = zsort $ toList $ intersectionWith (+) zmap zmap2+ res <- zinterStore r "zset3" ["zset", "zset2"] [1, 1] SUM >>= fromRInt+ assertEqual "" (length expected) res+ z' <- zrange r "zset3" takeAll True >>= asZSet+ assertEqual "" expected z'++ let zmap = fromList z :: Map String Double+ -- in Redis weights is applied to maps before aggregation+ expected = zsort $ toList $ intersectionWith (+) zmap $ M.map (* 0.5) zmap2+ res <- zinterStore r "zset3" ["zset", "zset2"] [1, 0.5] SUM >>= fromRInt+ assertEqual "" (length expected) res+ z' <- zrange r "zset3" takeAll True >>= asZSet+ assertEqual "" expected z'
redis.cabal view
@@ -1,5 +1,5 @@ Name: redis-Version: 0.9+Version: 0.10 License: MIT Maintainer: Alexander Bogdanov <andorn@gmail.com> Author: Alexander Bogdanov <andorn@gmail.com>@@ -7,28 +7,66 @@ Category: Database Synopsis: A driver for Redis key-value database Description:- Redis is an advanced key-value store. It is similar to memcached- but the dataset is not volatile. Values can be strings, exactly- like in memcached, but also lists, sets, and ordered sets.+ Redis (<http://redis.io>) is an open source, BSD licensed, advanced+ 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- protocol. Most of the functions will work correctly with stable version- but not all.+ supports the most recent (actually the git one) version of+ Redis. Most of the functions will work correctly with stable+ version but not all. .- Changes from v0.8:+ Changes from v0.9: .- - Now it's able to connect Redis using unix sockets. To do so just- call /connect/ with path to socket as first argument and empty- second argument.+ - New commands implemented: echo, linsert, zrevrangebyscore,+ lpushx and rpushx .+ - blpop and brpop has changed their types: it's now IO (Maybe (s1,+ s2)) instead of IO (Reply s2). Warning! It's backward+ incompatible!+ .+ - New helpers fromRBulk' and fromRMultiBulk' which not only+ unwraps RBulk and RMulti replies but also (unsafely) unwraps+ /Maybes/ inside it.+ .+ - 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.+ .+ - 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!+ .+ - Type of run_cas changed too. The third param is now (Redis -> IO+ a) action instead of IO (Reply ()). Warning! It's backward+ incompatible!+ .+ - 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!+ . Stability: beta Build-Type: Simple Cabal-Version: >= 1.4 +Extra-Source-Files: Test.hs,+ Test/CASCommands.hs, Test/ListCommands.hs,+ Test/PubSubCommands.hs, Test/StringCommands.hs,+ Test/Connection.hs, Test/Lock.hs,+ Test/SetCommands.hs, Test/Utils.hs,+ Test/GenericCommands.hs, Test/Setup.hs,+ Test/ZSetCommands.hs, Test/HashCommands.hs,+ Test/MultiCommands.hs, Test/SortCommands.hs,+ Test/Monad/CASCommands.hs, Test/Monad/MultiCommands.hs,+ redis.conf+ Library- Build-Depends: base < 5, bytestring, utf8-string,+ Build-Depends: base < 5, containers, bytestring, utf8-string, network, mtl, old-time, MonadCatchIO-mtl Exposed-modules: Database.Redis.Redis Database.Redis.Monad
+ redis.conf view
@@ -0,0 +1,23 @@+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+vm-enabled no+glueoutputbuf yes+hash-max-zipmap-entries 64+hash-max-zipmap-value 512+activerehashing yes++rename-command PING "P"