diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs --- a/benchmark/Benchmark.hs +++ b/benchmark/Benchmark.hs @@ -10,7 +10,7 @@ import Text.Printf nRequests, nClients :: Int -nRequests = 10000 +nRequests = 100000 nClients = 50 @@ -33,34 +33,43 @@ start <- newEmptyMVar done <- newEmptyMVar replicateM_ nClients $ forkIO $ do - c <- connect defaultConnectInfo - runRedis c $ forever $ do + runRedis conn $ forever $ do action <- liftIO $ takeMVar start - replicateM_ (nRequests `div` nClients) $ action + action liftIO $ putMVar done () - let timeAction name action = do + let timeAction name nActions action = do startT <- getCurrentTime - replicateM_ nClients $ putMVar start action + -- each clients runs ACTION nRepetitions times + let nRepetitions = nRequests `div` nClients `div` nActions + replicateM_ nClients $ putMVar start (replicateM_ nRepetitions action) replicateM_ nClients $ takeMVar done stopT <- getCurrentTime - let deltaT = realToFrac $ diffUTCTime stopT startT - rqsPerSec = fromIntegral nRequests / deltaT :: Double - putStrLn $ printf "%-10s %.2f Req/s" (name :: String) rqsPerSec + let deltaT = realToFrac $ diffUTCTime stopT startT + -- the real # of reqs send. We might have lost some due to 'div'. + actualReqs = nRepetitions * nActions * nClients + rqsPerSec = fromIntegral actualReqs / deltaT :: Double + putStrLn $ printf "%-20s %10.2f Req/s" (name :: String) rqsPerSec ---------------------------------------------------------------------- -- Benchmarks -- - timeAction "ping" $ do + timeAction "ping" 1 $ do Right Pong <- ping return () - timeAction "get" $ do + timeAction "get" 1 $ do Right Nothing <- get "key" return () - timeAction "mget" $ do + timeAction "mget" 1 $ do Right vs <- mget ["k1","k2","k3","k4","k5"] let expected = map Just ["v1","v2","v3","v4","v5"] True <- return $ vs == expected + return () + + timeAction "ping (pipelined)" 100 $ do + pongs <- replicateM 100 ping + let expected = replicate 100 (Right Pong) + True <- return $ pongs == expected return () diff --git a/hedis.cabal b/hedis.cabal --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.2 +version: 0.3 synopsis: Client library for the Redis datastore: supports full command set, pipelining. @@ -10,19 +10,28 @@ datastore. Compared to other Haskell client libraries it has some advantages: . - [Complete Redis 2.4 command set:] All Redis commands - () are available as haskell functions. The - exceptions to the rule are the MONITOR and SYNC commands. + [Complete Redis 2.4 command set:] All Redis commands + () are available as haskell functions, except + for the MONITOR and SYNC commands. Additionally, a low-level API is + exposed that makes it easy for the library user to implement additional + commands, such as new commands from an experimental Redis version. . - [Pipelining \"Just Works\":] Commands are pipelined + [Automatic Optimal Pipelining:] Commands are pipelined () as much as possible without any - work by the user. + work by the user. See + for a + technical explanation of automatic optimal pipelining. . [Enforced Pub\/Sub semantics:] When subscribed to the Redis Pub\/Sub server (), clients are not allowed to issue commands other than subscribing to or unsubscribing from channels. This library uses the type system to enforce the correct behavior. . + [Connect via TCP or Unix Domain Socket:] TCP sockets are the default way to + connect to a Redis server. For connections to a server on the same + machine, Unix domain sockets offer higher performance than the standard + TCP connection. + . For detailed documentation, see the "Database.Redis" module. license: BSD3 license-file: LICENSE @@ -43,9 +52,16 @@ description: Build the benchmark executable. default: False +flag test + description: Build the test suite. + default: False + library hs-source-dirs: src - ghc-options: -Wall + if flag(test) + ghc-options: -Wall + else + ghc-options: -Wall ghc-prof-options: -auto-all exposed-modules: Database.Redis build-depends: attoparsec == 0.10.*, @@ -54,7 +70,8 @@ bytestring-lexing == 0.2.*, mtl == 2.*, network == 2.*, - resource-pool == 0.2.0.* + resource-pool == 0.2.1.*, + time other-modules: Database.Redis.Core, Database.Redis.Connection @@ -69,11 +86,28 @@ main-is: benchmark/Benchmark.hs if flag(benchmark) build-depends: - base >= 4, - mtl == 2.0.*, + base == 4.*, + mtl == 2.*, hedis, - time >= 1.2 + time >= 1.2 else buildable: False ghc-options: -Wall -rtsopts ghc-prof-options: -auto-all + +executable hedis-test + main-is: test/Test.hs + if flag(test) + build-depends: + base == 4.*, + bytestring == 0.9.*, + hedis, + HUnit == 1.2.*, + mtl == 2.*, + time + else + buildable: False + -- We use -O0 here, since GHC takes *very* long to compile so many constants + ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind + ghc-prof-options: -auto-all + diff --git a/src/Database/Redis.hs b/src/Database/Redis.hs --- a/src/Database/Redis.hs +++ b/src/Database/Redis.hs @@ -1,6 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} module Database.Redis ( + -- * How To Use This Module + -- | + -- Connect to a Redis server: + -- + -- @ + -- -- connects to localhost:6379 + -- conn <- 'connect' 'defaultConnectInfo' + -- @ + -- + -- Send commands to the server: + -- + -- @ + -- 'runRedis' conn $ do + -- 'set' \"hello\" \"hello\" + -- set \"world\" \"world\" + -- hello <- 'get' \"hello\" + -- world <- get \"world\" + -- liftIO $ print (hello,world) + -- @ + + -- ** Error Behavior + -- | + -- [Operations against keys holding the wrong kind of value:] If the Redis + -- server returns an 'Error', command functions will return 'Left' the + -- 'Reply'. The library user can inspect the error message to gain + -- information on what kind of error occured. + -- + -- [Connection to the server lost:] In case of a lost connection, command + -- functions throw a + -- 'ConnectionLostException'. It can only be caught outside of + -- 'runRedis', to make sure the connection pool can properly destroy the + -- connection. -- * The Redis Monad Redis(), runRedis, @@ -16,8 +48,19 @@ -- * Pub\/Sub module Database.Redis.PubSub, - -- * Redis Return Types - Reply(..),Status(..) + -- * Low-Level Command API + sendRequest, + -- |'sendRequest' can be used to implement commands from experimental + -- versions of Redis. An example of how to implement a command is given + -- below. + -- + -- @ + -- -- |Redis DEBUG OBJECT command + -- debugObject :: ByteString -> 'Redis' (Either 'Reply' ByteString) + -- debugObject key = 'sendRequest' [\"DEBUG\", \"OBJECT\", 'encode' key] + -- @ + -- + Reply(..),Status(..),RedisResult(..),ConnectionLostException(..), ) where diff --git a/src/Database/Redis/Commands.hs b/src/Database/Redis/Commands.hs --- a/src/Database/Redis/Commands.hs +++ b/src/Database/Redis/Commands.hs @@ -160,7 +160,10 @@ watch, -- |Watch the given keys to determine execution of the MULTI/EXEC block (). -- * Unimplemented Commands --- |These commands are not implemented, as of now. +-- |These commands are not implemented, as of now. Library +-- users can implement these or other commands from +-- experimental Redis versions by using the 'sendRequest' +-- function. -- -- * EVAL () -- @@ -255,7 +258,7 @@ blpop :: [ByteString] -- ^ key -> Integer -- ^ timeout - -> Redis (Either Reply (ByteString,ByteString)) + -> Redis (Either Reply (Maybe (ByteString,ByteString))) blpop key timeout = sendRequest (["BLPOP"] ++ map encode key ++ [encode timeout] ) sdiffstore @@ -379,7 +382,7 @@ brpop :: [ByteString] -- ^ key -> Integer -- ^ timeout - -> Redis (Either Reply (ByteString,ByteString)) + -> Redis (Either Reply (Maybe (ByteString,ByteString))) brpop key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout] ) hgetall @@ -764,15 +767,4 @@ persist key = sendRequest (["PERSIST"] ++ [encode key] ) --- * Unimplemented Commands --- |These commands are not implemented, as of now. --- --- * EVAL () --- --- --- * MONITOR () --- --- --- * SYNC () --- diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -1,25 +1,37 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} module Database.Redis.Connection ( - HostName,PortID(..), + HostName,PortID(PortNumber,UnixSocket), ConnectInfo(..),defaultConnectInfo, - Connection(), connect + Connection(), connect, + ConnectionLostException(..) ) where +import Prelude hiding (catch) import Control.Applicative import Control.Monad.Reader import Control.Concurrent +import Control.Exception (Exception, throwIO) +import qualified Data.Attoparsec as P import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy.Char8 as LB import Data.IORef import Data.Pool +import Data.Time +import Data.Typeable import Network (HostName, PortID(..), connectTo) -import System.IO (hClose, hIsOpen, hSetBinaryMode) +import System.IO (Handle, hClose, hIsOpen, hSetBinaryMode, hFlush) +import System.IO.Error +import System.IO.Unsafe (unsafeInterleaveIO) import Database.Redis.Core import Database.Redis.Commands (auth) import Database.Redis.Reply +data ConnectionLostException = ConnectionLost + deriving (Show, Typeable) + +instance Exception ConnectionLostException + -- |Information for connnecting to a Redis server. -- -- It is recommended to not use the 'ConnInfo' data constructor directly. @@ -33,44 +45,91 @@ -- @ -- data ConnectInfo = ConnInfo - { connectHost :: HostName - , connectPort :: PortID - , connectAuth :: Maybe B.ByteString + { connectHost :: HostName + , connectPort :: PortID + , connectAuth :: Maybe B.ByteString + -- ^ When the server is protected by a password, set 'connectAuth' to 'Just' + -- the password. Each connection will then authenticate by the 'auth' + -- command. + , connectMaxConnections :: Int + -- ^ Maximum number of connections to keep open. The smallest acceptable + -- value is 1. + , connectMaxIdleTime :: NominalDiffTime + -- ^ Amount of time for which an unused connection is kept open. The + -- smallest acceptable value is 0.5 seconds. } -- |Default information for connecting: -- -- @ --- connectHost = \"localhost\" --- connectPort = PortNumber 6379 -- Redis default port --- connectAuth = Nothing -- No password +-- connectHost = \"localhost\" +-- connectPort = PortNumber 6379 -- Redis default port +-- connectAuth = Nothing -- No password +-- connectMaxConnections = 50 -- Up to 50 connections +-- connectMaxIdleTime = 30 -- Keep open for 30 seconds -- @ -- defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnInfo - { connectHost = "localhost" - , connectPort = PortNumber 6379 - , connectAuth = Nothing + { connectHost = "localhost" + , connectPort = PortNumber 6379 + , connectAuth = Nothing + , connectMaxConnections = 50 + , connectMaxIdleTime = 30 } --- |Opens a connection to a Redis server designated by the given 'ConnectInfo'. +-- |Opens a 'Connection' to a Redis server designated by the given +-- 'ConnectInfo'. connect :: ConnectInfo -> IO Connection -connect ConnInfo{..} = do - let maxIdleTime = 10 - maxConnections = 50 - Conn <$> createPool create destroy 1 maxIdleTime maxConnections +connect ConnInfo{..} = Conn <$> + createPool create destroy 1 connectMaxIdleTime connectMaxConnections where create = do h <- connectTo connectHost connectPort - rs' <- parseReply <$> {-# SCC "LB.hgetContents" #-} LB.hGetContents h - rs <- newIORef rs' + rs <- hGetReplies h >>= newIORef + hSetBinaryMode h True let conn = (h,rs) maybe (return ()) (\pass -> runRedisInternal conn (auth pass) >> return ()) connectAuth - hSetBinaryMode h True newMVar conn destroy conn = withMVar conn $ \(h,_) -> do open <- hIsOpen h when open (hClose h) + +-- |Read all the 'Reply's from the Handle and return them as a lazy list. +-- +-- The actual reading and parsing of each 'Reply' is deferred until the spine +-- of the list is evaluated up to that 'Reply'. Each 'Reply' is cons'd in front +-- of the (unevaluated) list of all remaining replies. +-- +-- 'unsafeInterleaveIO' only evaluates it's result once, making this function +-- thread-safe. 'Handle' as implemented by GHC is also threadsafe, it is safe +-- to call 'hFlush' here. The list constructor '(:)' must be called from +-- /within/ unsafeInterleaveIO, to keep the replies in correct order. +hGetReplies :: Handle -> IO [Reply] +hGetReplies h = lazyRead (Right B.empty) + where + lazyRead rest = unsafeInterleaveIO $ do + parseResult <- either continueParse readAndParse rest + case parseResult of + P.Fail _ _ _ -> error "Hedis: reply parse failed" + P.Partial cont -> lazyRead (Left cont) + P.Done rest' r -> do + rs <- lazyRead (Right rest') + return (r:rs) + + continueParse cont = cont <$> B.hGetSome h maxRead + + readAndParse rest = P.parse reply <$> + if B.null rest + then do + hFlush h -- send any pending requests + s <- B.hGetSome h maxRead `catchIOError` const errConnClosed + when (B.null s) errConnClosed + return s + else return rest + + maxRead = 4*1024 + errConnClosed = throwIO ConnectionLost diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -14,15 +14,14 @@ import qualified Data.ByteString as B import Data.IORef import Data.Pool -import System.IO (Handle, hFlush) +import System.IO (Handle) import Database.Redis.Reply import Database.Redis.Request import Database.Redis.Types --- |Connection to a Redis server. Use the 'connect' function to create one. --- --- A 'Connection' is actually a pool of network connections. +-- |A threadsafe pool of network connections to a Redis server. Use the +-- 'connect' function to create one. newtype Connection = Conn (Pool (MVar (Handle, IORef [Reply]))) -- |All Redis commands run in the 'Redis' monad. @@ -40,7 +39,8 @@ -- |Interact with a Redis datastore specified by the given 'Connection'. -- -- Each call of 'runRedis' takes a network connection from the 'Connection' --- pool and runs the given 'Redis' action. Calls to 'runRedis' may thus block, -- while all connections from the pool are in use. +-- pool and runs the given 'Redis' action. Calls to 'runRedis' may thus block +-- while all connections from the pool are in use. runRedis :: Connection -> Redis a -> IO a runRedis (Conn pool) redis = withResource pool $ \conn -> @@ -54,9 +54,8 @@ send :: [B.ByteString] -> Redis () send req = Redis $ do h <- askHandle - liftIO $ do - {-# SCC "send.hPut" #-} B.hPut h $ renderRequest req - {-# SCC "send.hFlush" #-} hFlush h + -- hFlushing the handle is done while reading replies. + liftIO $ {-# SCC "send.hPut" #-} B.hPut h (renderRequest req) recv :: Redis Reply recv = Redis $ do diff --git a/src/Database/Redis/PubSub.hs b/src/Database/Redis/PubSub.hs --- a/src/Database/Redis/PubSub.hs +++ b/src/Database/Redis/PubSub.hs @@ -13,7 +13,7 @@ import Data.ByteString.Char8 (ByteString) import Data.Maybe import qualified Database.Redis.Core as Core -import Database.Redis.Reply +import Database.Redis.Reply (Reply(..)) import Database.Redis.Types @@ -100,14 +100,13 @@ recv (pending + length cmds) recv pending = do - reply <- Core.recv + reply <- Core.recv case decodeMsg reply of - Left cnt - | cnt == 0 && pending == 0 - -> return () - | otherwise -> send mempty (pending - 1) - Right msg -> do act <- liftIO $ callback msg - send act pending + Left cnt -> let pending' = pending - 1 + in unless (cnt == 0 && pending' == 0) $ + send mempty pending' + Right msg -> do act <- liftIO $ callback msg + send act pending ------------------------------------------------------------------------------ -- Helpers @@ -117,7 +116,7 @@ pubSubAction cmd chans = PubSub [cmd : chans] decodeMsg :: Reply -> Either Integer Message -decodeMsg (MultiBulk (Just (r0:r1:r2:rs))) = either (error "decodeMsg") id $ do +decodeMsg r@(MultiBulk (Just (r0:r1:r2:rs))) = either (errMsg r) id $ do kind <- decode r0 case kind :: ByteString of "message" -> Right <$> decodeMessage @@ -129,4 +128,7 @@ decodePMessage = PMessage <$> decode r1 <*> decode r2 <*> decode (head rs) -decodeMsg r = error $ "not a message: " ++ show r +decodeMsg r = errMsg r + +errMsg :: Reply -> a +errMsg r = error $ "Hedis: expected pub/sub-message but got: " ++ show r diff --git a/src/Database/Redis/Reply.hs b/src/Database/Redis/Reply.hs --- a/src/Database/Redis/Reply.hs +++ b/src/Database/Redis/Reply.hs @@ -1,28 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} -module Database.Redis.Reply (Reply(..), parseReply) where +module Database.Redis.Reply (Reply(..), reply) where import Prelude hiding (error, take) import Control.Applicative import Data.Attoparsec.Char8 -import qualified Data.Attoparsec.Lazy as P -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Attoparsec as P +import Data.ByteString.Char8 -- |Low-level representation of replies from the Redis server. -data Reply = SingleLine S.ByteString - | Error S.ByteString +data Reply = SingleLine ByteString + | Error ByteString | Integer Integer - | Bulk (Maybe S.ByteString) + | Bulk (Maybe ByteString) | MultiBulk (Maybe [Reply]) deriving (Eq, Show) --- |Parse a lazy 'L.ByteString' into a (possibly infinite) list of 'Reply's. -parseReply :: L.ByteString -> [Reply] -parseReply input = - case P.parse reply input of - P.Fail _ _ _ -> [] - P.Done rest r -> r : parseReply rest - ------------------------------------------------------------------------------ -- Reply parsers -- @@ -50,7 +42,7 @@ len <- '*' `prefixing` signed decimal if len < 0 then return Nothing - else Just <$> count len reply + else Just <$> P.count len reply ------------------------------------------------------------------------------ @@ -59,8 +51,8 @@ prefixing :: Char -> Parser a -> Parser a c `prefixing` a = char c *> a <* crlf -crlf :: Parser S.ByteString +crlf :: Parser ByteString crlf = string "\r\n" -line :: Parser S.ByteString +line :: Parser ByteString line = takeTill (=='\r') diff --git a/src/Database/Redis/Types.hs b/src/Database/Redis/Types.hs --- a/src/Database/Redis/Types.hs +++ b/src/Database/Redis/Types.hs @@ -65,7 +65,7 @@ "set" -> Set "zset" -> ZSet "QUEUED" -> Queued - _ -> error $ "unhandled status-code: " ++ show s + _ -> error $ "Hedis: unhandled status-code: " ++ show s decode r = Left r instance RedisResult Bool where diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,598 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +module Main (main) where + +import Control.Applicative +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans +import Data.Monoid (mappend) +import Data.Time +import Data.Time.Clock.POSIX +import qualified Test.HUnit as Test +import Test.HUnit (runTestTT, (~:)) + +import Database.Redis + + +------------------------------------------------------------------------------ +-- Main and helpers +-- +main :: IO () +main = do + c <- connect defaultConnectInfo + runTestTT $ Test.TestList $ map ($c) tests + return () + +type Test = Connection -> Test.Test + +testCase :: String -> Redis () -> Test +testCase name r conn = name ~: + Test.TestCase $ runRedis conn $ flushdb >>=? Ok >> r + +(>>=?) :: (Eq a, Show a) => Redis (Either Reply a) -> a -> Redis () +redis >>=? expected = do + a <- redis + liftIO $ case a of + Left reply -> Test.assertFailure $ "Redis error: " ++ show reply + Right actual -> expected Test.@=? actual + +assert :: Bool -> Redis () +assert = liftIO . Test.assert + +------------------------------------------------------------------------------ +-- Tests +-- +tests :: [Test] +tests = concat + [ testsMisc, testsKeys, testsStrings, testsHashes, testsLists, testsZSets + , [testPubSub], testsConnection, testsServer, [testQuit] + ] + +------------------------------------------------------------------------------ +-- Miscellaneous +-- +testsMisc :: [Test] +testsMisc = [testForceErrorReply, testPipelining] + +testForceErrorReply :: Test +testForceErrorReply = testCase "force error reply" $ do + set "key" "value" + -- key is not a hash -> wrong kind of value + reply <- hkeys "key" + assert $ case reply of + Left (Error _) -> True + _ -> False + +testPipelining :: Test +testPipelining = testCase "pipelining" $ do + let n = 10 + tPipe <- time $ do + pongs <- replicateM n ping + assert $ pongs == replicate n (Right Pong) + + tNoPipe <- time $ replicateM_ n (ping >>=? Pong) + -- pipelining should at least be twice as fast. + assert $ tNoPipe / tPipe > 2 + +time :: Redis () -> Redis NominalDiffTime +time redis = do + start <- liftIO $ getCurrentTime + redis + liftIO $ fmap (`diffUTCTime` start) getCurrentTime + +------------------------------------------------------------------------------ +-- Keys +-- +testsKeys :: [Test] +testsKeys = + [ testDel, testExists, testExpire, testExpireAt, testKeys, testMove + , testPersist, testRandomkey, testRename, testRenamenx, testSort + , testTtl, testGetType, testObject + ] + +testDel :: Test +testDel = testCase "del" $ do + set "key" "value" >>=? Ok + get "key" >>=? Just "value" + del ["key"] >>=? 1 + get "key" >>=? Nothing + +testExists :: Test +testExists = testCase "exists" $ do + exists "key" >>=? False + set "key" "value" >>=? Ok + exists "key" >>=? True + +testExpire :: Test +testExpire = testCase "expire" $ do + set "key" "value" >>=? Ok + expire "key" 1 >>=? True + expire "notAKey" 1 >>=? False + ttl "key" >>=? 1 + +testExpireAt :: Test +testExpireAt = testCase "expireat" $ do + set "key" "value" >>=? Ok + seconds <- floor . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime + let expiry = seconds + 1 + expireat "key" expiry >>=? True + expireat "notAKey" expiry >>=? False + ttl "key" >>=? 1 + +testKeys :: Test +testKeys = testCase "keys" $ do + keys "key*" >>=? [] + set "key1" "value" >>=? Ok + set "key2" "value" >>=? Ok + Right ks <- keys "key*" + assert $ length ks == 2 + assert $ elem "key1" ks + assert $ elem "key2" ks + +testMove :: Test +testMove = testCase "move" $ do + set "key" "value" >>=? Ok + move "key" 13 >>=? True + get "key" >>=? Nothing + select 13 >>=? Ok + get "key" >>=? Just "value" + +testPersist :: Test +testPersist = testCase "persist" $ do + set "key" "value" >>=? Ok + expire "key" 1 >>=? True + ttl "key" >>=? 1 + persist "key" >>=? True + ttl "key" >>=? (-1) + +testRandomkey :: Test +testRandomkey = testCase "randomkey" $ do + set "k1" "value" >>=? Ok + set "k2" "value" >>=? Ok + Right k <- randomkey + assert $ k `elem` ["k1", "k2"] + +testRename :: Test +testRename = testCase "rename" $ do + set "k1" "value" >>=? Ok + rename "k1" "k2" >>=? Ok + get "k1" >>=? Nothing + get "k2" >>=? Just ("value" ) + +testRenamenx :: Test +testRenamenx = testCase "renamenx" $ do + set "k1" "value" >>=? Ok + set "k2" "value" >>=? Ok + renamenx "k1" "k2" >>=? False + renamenx "k1" "k3" >>=? True + +testSort :: Test +testSort = testCase "sort" $ do + lpush "ids" ["1","2","3"] >>=? 3 + sort "ids" defaultSortOpts >>=? ["1","2","3"] + sortStore "ids" "anotherKey" defaultSortOpts >>=? 3 + mset [("weight_1","1") + ,("weight_2","2") + ,("weight_3","3") + ,("object_1","foo") + ,("object_2","bar") + ,("object_3","baz") + ] + let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True + , sortLimit = (1,2) + , sortBy = Just "weight_*" + , sortGet = ["object_*"] } + sort "ids" opts >>=? ["bar","foo"] + + +testTtl :: Test +testTtl = testCase "ttl" $ do + set "key" "value" >>=? Ok + ttl "notAKey" >>=? (-1) + ttl "key" >>=? (-1) + expire "key" 42 >>=? True + ttl "key" >>=? 42 + +testGetType :: Test +testGetType = testCase "getType" $ do + getType "key" >>=? None + forM_ ts $ \(setKey, typ) -> do + setKey + getType "key" >>=? typ + del ["key"] >>=? 1 + where + ts = [ (set "key" "value" >>=? Ok, String) + , (hset "key" "field" "value" >>=? True, Hash) + , (lpush "key" ["value"] >>=? 1, List) + , (sadd "key" ["member"] >>=? 1, Set) + , (zadd "key" [(42,"member"),(12.3,"value")] >>=? 2, ZSet) + ] + +testObject :: Test +testObject = testCase "object" $ do + set "key" "value" >>=? Ok + objectRefcount "key" >>=? 1 + Right _ <- objectEncoding "key" + objectIdletime "key" >>=? 0 + +------------------------------------------------------------------------------ +-- Strings +-- +testsStrings :: [Test] +testsStrings = + [ testAppend, testDecr, testDecrby, testGetbit, testGetrange, testGetset + , testIncr, testIncrby, testMget, testMset, testMsetnx, testSetbit + , testSetex, testSetnx, testSetrange, testStrlen, testSetAndGet + ] + +testAppend :: Test +testAppend = testCase "append" $ do + set "key" "hello" >>=? Ok + append "key" "world" >>=? 10 + get "key" >>=? Just "helloworld" + +testDecr :: Test +testDecr = testCase "decr" $ do + set "key" "42" >>=? Ok + decr "key" >>=? 41 + +testDecrby :: Test +testDecrby = testCase "decrby" $ do + set "key" "42" >>=? Ok + decrby "key" 2 >>=? 40 + +testGetbit :: Test +testGetbit = testCase "getbit" $ getbit "key" 42 >>=? 0 + +testGetrange :: Test +testGetrange = testCase "getrange" $ do + set "key" "value" >>=? Ok + getrange "key" 1 (-2) >>=? "alu" + +testGetset :: Test +testGetset = testCase "getset" $ do + getset "key" "v1" >>=? Nothing + getset "key" "v2" >>=? Just "v1" + +testIncr :: Test +testIncr = testCase "incr" $ do + set "key" "42" >>=? Ok + incr "key" >>=? 43 + +testIncrby :: Test +testIncrby = testCase "incrby" $ do + set "key" "40" >>=? Ok + incrby "key" 2 >>=? 42 + +testMget :: Test +testMget = testCase "mget" $ do + set "k1" "v1" >>=? Ok + set "k2" "v2" >>=? Ok + mget ["k1","k2","notAKey" ] >>=? [Just "v1", Just "v2", Nothing] + +testMset :: Test +testMset = testCase "mset" $ do + mset [("k1","v1"), ("k2","v2")] >>=? Ok + get "k1" >>=? Just "v1" + get "k2" >>=? Just "v2" + +testMsetnx :: Test +testMsetnx = testCase "msetnx" $ do + msetnx [("k1","v1"), ("k2","v2")] >>=? True + msetnx [("k1","v1"), ("k2","v2")] >>=? False + +testSetbit :: Test +testSetbit = testCase "setbit" $ do + setbit "key" 42 "1" >>=? 0 + setbit "key" 42 "0" >>=? 1 + +testSetex :: Test +testSetex = testCase "setex" $ do + setex "key" 1 "value" >>=? Ok + ttl "key" >>=? 1 + +testSetnx :: Test +testSetnx = testCase "setnx" $ do + setnx "key" "v1" >>=? True + setnx "key" "v2" >>=? False + +testSetrange :: Test +testSetrange = testCase "setrange" $ do + set "key" "value" >>=? Ok + setrange "key" 1 "ers" >>=? 5 + get "key" >>=? Just "verse" + +testStrlen :: Test +testStrlen = testCase "strlen" $ do + set "key" "value" >>=? Ok + strlen "key" >>=? 5 + +testSetAndGet :: Test +testSetAndGet = testCase "set/get" $ do + get "key" >>=? Nothing + set "key" "value" >>=? Ok + get "key" >>=? Just "value" + + +------------------------------------------------------------------------------ +-- Hashes +-- +testsHashes :: [Test] +testsHashes = + [ testHdel, testHexists,testHget, testHgetall, testHincrby, testHkeys + , testHlen, testHmget, testHmset, testHset, testHsetnx, testHvals + ] + +testHdel :: Test +testHdel = testCase "hdel" $ do + hdel "key" ["field"] >>=? False + hset "key" "field" "value" >>=? True + hdel "key" ["field"] >>=? True + +testHexists :: Test +testHexists = testCase "hexists" $ do + hexists "key" "field" >>=? False + hset "key" "field" "value" >>=? True + hexists "key" "field" >>=? True + +testHget :: Test +testHget = testCase "hget" $ do + hget "key" "field" >>=? Nothing + hset "key" "field" "value" >>=? True + hget "key" "field" >>=? Just "value" + +testHgetall :: Test +testHgetall = testCase "hgetall" $ do + hgetall "key" >>=? [] + hmset "key" [("f1","v1"),("f2","v2")] >>=? Ok + hgetall "key" >>=? [("f1","v1"), ("f2","v2")] + +testHincrby :: Test +testHincrby = testCase "hincrby" $ do + hset "key" "field" "40" >>=? True + hincrby "key" "field" 2 >>=? 42 + +testHkeys :: Test +testHkeys = testCase "hkeys" $ do + hset "key" "field" "value" >>=? True + hkeys "key" >>=? ["field"] + +testHlen :: Test +testHlen = testCase "hlen" $ do + hlen "key" >>=? 0 + hset "key" "field" "value" >>=? True + hlen "key" >>=? 1 + +testHmget :: Test +testHmget = testCase "hmget" $ do + hmset "key" [("f1","v1"), ("f2","v2")] >>=? Ok + hmget "key" ["f1", "f2", "nofield" ] >>=? [Just "v1", Just "v2", Nothing] + +testHmset :: Test +testHmset = testCase "hmset" $ do + hmset "key" [("f1","v1"), ("f2","v2")] >>=? Ok + +testHset :: Test +testHset = testCase "hset" $ do + hset "key" "field" "value" >>=? True + hset "key" "field" "value" >>=? False + +testHsetnx :: Test +testHsetnx = testCase "hsetnx" $ do + hsetnx "key" "field" "value" >>=? True + hsetnx "key" "field" "value" >>=? False + +testHvals :: Test +testHvals = testCase "hvals" $ do + hset "key" "field" "value" >>=? True + hvals "key" >>=? ["value"] + + +------------------------------------------------------------------------------ +-- Lists +-- +testsLists :: [Test] +testsLists = + [testBlpop, testBrpoplpush, testLpop, testLinsert, testLpushx, testLset] + +testBlpop :: Test +testBlpop = testCase "blpop/brpop" $ do + lpush "key" ["v3","v2","v1"] >>=? 3 + blpop ["notAKey","key"] 1 >>=? Just ("key","v1") + brpop ["notAKey","key"] 1 >>=? Just ("key","v3") + -- run into timeout + blpop ["notAKey"] 1 >>=? Nothing + +testBrpoplpush :: Test +testBrpoplpush = testCase "brpoplpush/rpoplpush" $ do + rpush "k1" ["v1","v2"] >>=? 2 + brpoplpush "k1" "k2" 1 >>=? "v2" + rpoplpush "k1" "k2" >>=? "v1" + llen "k2" >>=? 2 + llen "k1" >>=? 0 + +testLpop :: Test +testLpop = testCase "lpop/rpop" $ do + lpush "key" ["v3","v2","v1"] >>=? 3 + lpop "key" >>=? "v1" + llen "key" >>=? 2 + rpop "key" >>=? "v3" + +testLinsert :: Test +testLinsert = testCase "linsert" $ do + rpush "key" ["v2"] >>=? 1 + linsertBefore "key" "v2" "v1" >>=? 2 + linsertBefore "key" "notAVal" "v3" >>=? (-1) + linsertAfter "key" "v2" "v3" >>=? 3 + linsertAfter "key" "notAVal" "v3" >>=? (-1) + lindex "key" 0 >>=? "v1" + lindex "key" 2 >>=? "v3" + +testLpushx :: Test +testLpushx = testCase "lpushx/rpushx" $ do + lpushx "notAKey" "v1" >>=? 0 + lpush "key" ["v2"] >>=? 1 + lpushx "key" "v1" >>=? 2 + rpushx "key" "v3" >>=? 3 + +testLset :: Test +testLset = testCase "lset/lrem/ltrim" $ do + lpush "key" ["v3","v2","v2","v1","v1"] >>=? 5 + lset "key" 1 "v2" >>=? Ok + lrem "key" 2 "v2" >>=? 2 + llen "key" >>=? 3 + ltrim "key" 0 1 >>=? Ok + lrange "key" 0 1 >>=? ["v1", "v2"] + +------------------------------------------------------------------------------ +-- Sets +-- + +------------------------------------------------------------------------------ +-- Sorted Sets +-- +testsZSets :: [Test] +testsZSets = [testZAdd, testZRank, testZRemRange, testZRange, testZStore] + +testZAdd :: Test +testZAdd = testCase "zadd/zrem/zcard/zscore/zincrby" $ do + zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 3 + zscore "key" "v3" >>=? 40 + zincrby "key" 2 "v3" >>=? 42 + zrem "key" ["v3","notAKey"] >>=? 1 + zcard "key" >>=? 2 + +testZRank :: Test +testZRank = testCase "zrank/zrevrank/zcount" $ do + zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 3 + zrank "key" "v1" >>=? 0 + zrevrank "key" "v1" >>=? 2 + zcount "key" 10 100 >>=? 1 + +testZRemRange :: Test +testZRemRange = testCase "zremrangebyscore/zremrangebyrank" $ do + zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 3 + zremrangebyrank "key" 0 1 >>=? 2 + zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 2 + zremrangebyscore "key" 10 100 >>=? 1 + +testZRange :: Test +testZRange = testCase "zrange/zrevrange/zrangebyscore/zrevrangebyscore" $ do + zadd "key" [(1,"v1"),(2,"v2"),(3,"v3")] >>=? 3 + zrange "key" 0 1 >>=? ["v1","v2"] + zrevrange "key" 0 1 >>=? ["v3","v2"] + zrangeWithscores "key" 0 1 >>=? [("v1",1),("v2",2)] + zrevrangeWithscores "key" 0 1 >>=? [("v3",3),("v2",2)] + zrangebyscore "key" 0.5 1.5 >>=? ["v1"] + zrangebyscoreWithscores "key" 0.5 1.5 >>=? [("v1",1)] + zrangebyscoreLimit "key" 0.5 2.5 0 1 >>=? ["v1"] + zrangebyscoreWithscoresLimit "key" 0.5 2.5 0 1 >>=? [("v1",1)] + zrevrangebyscore "key" 1.5 0.5 >>=? ["v1"] + zrevrangebyscoreWithscores "key" 1.5 0.5 >>=? [("v1",1)] + zrevrangebyscoreLimit "key" 2.5 0.5 0 1 >>=? ["v2"] + zrevrangebyscoreWithscoresLimit "key" 2.5 0.5 0 1 >>=? [("v2",2)] + +testZStore :: Test +testZStore = testCase "zunionstore/zinterstore" $ do + zadd "k1" [(1, "v1"), (2, "v2")] + zadd "k2" [(2, "v2"), (3, "v3")] + zinterstore "newkey" ["k1","k2"] Sum >>=? 1 + zinterstoreWeights "newkey" [("k1",1),("k2",2)] Max >>=? 1 + zunionstore "newkey" ["k1","k2"] Sum >>=? 3 + zunionstoreWeights "newkey" [("k1",1),("k2",2)] Min >>=? 3 + + +------------------------------------------------------------------------------ +-- Pub/Sub +-- +testPubSub :: Test +testPubSub conn = testCase "pubSub" go conn + where + go = do + -- producer + liftIO $ forkIO $ do + runRedis conn $ do + publish "chan1" "hello" >>=? 1 + publish "chan2" "world" >>=? 1 + return () + + -- consumer + pubSub (subscribe ["chan1"]) $ \msg -> do + -- ready for a message + case msg of + Message{..} -> return + (unsubscribe [msgChannel] `mappend` psubscribe ["chan*"]) + PMessage{..} -> return (punsubscribe [msgPattern]) + + +------------------------------------------------------------------------------ +-- Transaction +-- + +------------------------------------------------------------------------------ +-- Connection +-- +testsConnection :: [Test] +testsConnection = [ testEcho, testPing, testSelect ] + +testEcho :: Test +testEcho = testCase "echo" $ + echo ("value" ) >>=? "value" + +testPing :: Test +testPing = testCase "ping" $ ping >>=? Pong + +testQuit :: Test +testQuit = testCase "quit" $ quit >>=? Ok + +testSelect :: Test +testSelect = testCase "select" $ do + select 13 >>=? Ok + select 0 >>=? Ok + + +------------------------------------------------------------------------------ +-- Server +-- +testsServer :: [Test] +testsServer = + [testBgrewriteaof, testFlushall, testInfo, testConfig, testSlowlog + ,testDebugObject] + +testBgrewriteaof :: Test +testBgrewriteaof = testCase "bgrewriteaof/bgsave/save" $ do + save >>=? Ok + -- TODO return types not as documented + -- bgsave >>=? BgSaveStarted + -- bgrewriteaof >>=? BgAOFRewriteStarted + +testConfig :: Test +testConfig = testCase "config/auth" $ do + configSet "requirepass" "pass" >>=? Ok + auth "pass" >>=? Ok + configSet "requirepass" "" >>=? Ok + +testFlushall :: Test +testFlushall = testCase "flushall/flushdb" $ do + flushall >>=? Ok + flushdb >>=? Ok + +testInfo :: Test +testInfo = testCase "info/lastsave/dbsize" $ do + Right _ <- info + Right _ <- lastsave + dbsize >>=? 0 + configResetstat >>=? Ok + +testSlowlog :: Test +testSlowlog = testCase "slowlog" $ do + slowlogGet 5 >>=? MultiBulk (Just []) + slowlogLen >>=? 0 + slowlogReset >>=? Ok + +testDebugObject :: Test +testDebugObject = testCase "debugObject/debugSegfault" $ do + set "key" "value" >>=? Ok + Right _ <- debugObject "key" + -- Right Ok <- debugSegfault + return ()