hedis 0.2 → 0.3

raw patch · 10 files changed

+825/−97 lines, 10 filesdep +HUnitdep ~basedep ~mtldep ~resource-poolnew-component:exe:hedis-testPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit

Dependency ranges changed: base, mtl, resource-pool, time

API changes (from Hackage documentation)

Files

• benchmark/Benchmark.hs +21/−12
• hedis.cabal +45/−11
• src/Database/Redis.hs +45/−2
• src/Database/Redis/Commands.hs +6/−14
• src/Database/Redis/Connection.hs +81/−22
• src/Database/Redis/Core.hs +7/−8
• src/Database/Redis/PubSub.hs +12/−10
• src/Database/Redis/Reply.hs +9/−17
• src/Database/Redis/Types.hs +1/−1
• test/Test.hs +598/−0

@@ -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 ()

@@ -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 -        (<http://redis.io/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+        (<http://redis.io/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         (<http://redis.io/topics/pipelining>) as much as possible without any-        work by the user.+        work by the user. See+        <http://informatikr.com/2012/redis-pipelining.html> for a+        technical explanation of automatic optimal pipelining.     .     [Enforced Pub\/Sub semantics:] When subscribed to the Redis Pub\/Sub server         (<http://redis.io/topics/pubsub>), 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+    

@@ -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 

@@ -160,7 +160,10 @@ watch, -- |Watch the given keys to determine execution of the MULTI/EXEC block (<http://redis.io/commands/watch>).  -- * 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 (<http://redis.io/commands/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 (<http://redis.io/commands/eval>)--------- * MONITOR (<http://redis.io/commands/monitor>)--------- * SYNC (<http://redis.io/commands/sync>)--- 

@@ -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

@@ -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

@@ -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

@@ -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')

@@ -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

@@ -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 ()