diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -2,8 +2,13 @@ Copyright (c) 2010-2011, Alexander Bogdanov License: MIT -} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 702 import System (getArgs) +#else +import System.Environment (getArgs) +#endif import System.Exit (exitFailure, exitSuccess) import System.Console.GetOpt import Data.Time.Clock @@ -14,7 +19,7 @@ makeConnections :: Int -> String -> String -> Int -> IO [Redis] makeConnections count host port db = mapM mkConn [0 .. (count - 1)] - where mkConn n = do r <- connect host port + where mkConn _ = do r <- connect host port select r db return r @@ -84,10 +89,17 @@ optDatabase :: Int, optClients :: Int, optRequests :: Int, + optWorkers :: Int, optHelp :: Bool} deriving Show -defaultOpts = Opt localhost defaultPort 6 50 100000 False +defaultOpts = Opt { optHost = localhost, + optPort = defaultPort, + optDatabase = 6, + optClients = 50, + optRequests = 100000, + optWorkers = 50, + optHelp = False } options :: [OptDescr (Opt -> Opt)] options = [Option ['h'] ["host"] (OptArg (maybe id (\h o -> o{optHost = h})) "HOSTNAME") ("Server hostname (default " ++ localhost ++ ")"), @@ -95,6 +107,7 @@ Option ['d'] ["database"] (OptArg (maybe id (\d o -> o{optDatabase = read d})) "DATABASE") "Database number (default 6)", Option ['c'] ["clients"] (OptArg (maybe id (\c o -> o{optClients = read c})) "CLIENTS") "Number of parallel connections (default 50)", Option ['n'] ["requests"] (OptArg (maybe id (\n o -> o{optRequests = read n})) "REQUESTS") "Total number of requests (default 100000)", + Option ['w'] ["workers"] (OptArg (maybe id (\n o -> o{optWorkers = read n})) "WORKERS") "Number of worker threads (default 50)", Option [] ["help"] (NoArg (\o -> o{optHelp = True})) "Show this usage info"] main :: IO () @@ -116,7 +129,8 @@ select r $ optDatabase opts flushDb r - rs <- makeConnections (optClients opts) (optHost opts) (optPort opts) (optDatabase opts) + rs' <- makeConnections (optClients opts) (optHost opts) (optPort opts) (optDatabase opts) + let rs = take (optWorkers opts) $ concat $ repeat rs' t <- runWorkers rs (optRequests opts) worker_set printResult "set" (optRequests opts) t diff --git a/Database/Redis/Internal.hs b/Database/Redis/Internal.hs --- a/Database/Redis/Internal.hs +++ b/Database/Redis/Internal.hs @@ -8,7 +8,7 @@ import Prelude hiding (putStrLn, putStr, catch) import Control.Concurrent (ThreadId, myThreadId) -import Control.Concurrent.MVar +import qualified Control.Concurrent.RLock as RLock import Data.IORef import qualified System.IO as IO import System.IO.UTF8 (putStrLn, putStr) @@ -43,16 +43,14 @@ } -- | Redis connection descriptor -data Redis = Redis {r_lock_cnt :: MVar (Maybe (ThreadId, Int)), - r_lock :: MVar (), +data Redis = Redis {r_lock :: RLock.RLock, r_st :: IORef RedisState} deriving Eq newRedis :: (String, String) -> IO.Handle -> IO Redis -newRedis server h = do lcnt <- newMVar Nothing - l <- newMVar () +newRedis server h = do l <- RLock.new st <- newIORef $ RedisState server 0 h 0 Map.empty - return $ Redis lcnt l st + return $ Redis l st -- | Redis command variants data Command = CInline ByteString @@ -111,52 +109,19 @@ {-# INLINE hPutRn #-} takeState :: Redis -> IO RedisState -takeState r = block $ do lcnt <- takeMVar $ r_lock_cnt r - mytid <- myThreadId - case lcnt of - Nothing -> do l <- tryTakeMVar $ r_lock r - when (isNothing l) - $ error "takeState: r_lock_cnt is Nothing BUT r_lock is locked" - take_n_put mytid 1 - Just (tid, cnt) -> if tid == mytid - then let !cnt' = cnt + 1 - in take_n_put tid cnt' - else do putMVar (r_lock_cnt r) lcnt - l <- takeMVar $ r_lock r - lcnt <- takeMVar $ r_lock_cnt r - when (isJust lcnt) - $ error "takeState: r_lock is locked by me BUT r_lock_cnt is not Nothing" - take_n_put mytid 1 - where take_n_put tid cnt = do st <- readIORef $ r_st r - putMVar (r_lock_cnt r) $ Just (tid, cnt) - return st +takeState r = block $ do RLock.acquire $ r_lock r + readIORef $ r_st r putState :: Redis -> RedisState -> IO () -putState r s = block $ do lcnt <- takeMVar $ r_lock_cnt r +putState r s = block $ do lstate <- RLock.state $ r_lock r mytid <- myThreadId - case lcnt of - Nothing -> error "putState: trying put state that was not took" - Just (tid, cnt) -> if tid /= mytid - then error "putState: trying put state that was not took by me" - else do writeIORef (r_st r) s - if cnt > 1 - then let !cnt' = cnt - 1 - in putMVar (r_lock_cnt r) $ Just (tid, cnt') - else do putMVar (r_lock r) () - putMVar (r_lock_cnt r) Nothing + case lstate of + Just (mytid, _) -> do writeIORef (r_st r) s + RLock.release $ r_lock r + otherwise -> error "putState: trying put state that was not took" putStateUnmodified :: Redis -> IO () -putStateUnmodified r = block $ do lcnt <- takeMVar $ r_lock_cnt r - mytid <- myThreadId - case lcnt of - Nothing -> error "putState: trying put state that was not took" - Just (tid, cnt) -> if tid /= mytid - then error "putState: trying put state that was not took by me" - else if cnt > 1 - then let !cnt' = cnt - 1 - in putMVar (r_lock_cnt r) $ Just (tid, cnt') - else do putMVar (r_lock r) () - putMVar (r_lock_cnt r) Nothing +putStateUnmodified r = RLock.release $ r_lock r inState :: Redis -> (RedisState -> IO (RedisState, a)) -> IO a inState r action = bracketOnError (takeState r) (\_ -> putStateUnmodified r) diff --git a/Database/Redis/Monad.hs b/Database/Redis/Monad.hs --- a/Database/Redis/Monad.hs +++ b/Database/Redis/Monad.hs @@ -22,7 +22,8 @@ R.sortDefaults, R.fromRInline, R.fromRBulk, R.fromRMulti, R.fromRMultiBulk, - R.fromRInt, R.fromROk, R.noError, R.parseMessage, R.takeAll, + R.fromRMultiBulk', R.fromRInt, R.fromROk, R.noError, R.parseMessage, + R.takeAll, -- * Database connection R.localhost, R.defaultPort, diff --git a/Database/Redis/Redis.hs b/Database/Redis/Redis.hs --- a/Database/Redis/Redis.hs +++ b/Database/Redis/Redis.hs @@ -3,7 +3,7 @@ License: MIT -} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, +{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, OverloadedStrings, BangPatterns #-} -- | Main Redis API and protocol implementation @@ -229,10 +229,14 @@ socket_unix :: String -> IO S.Socket socket_unix path = +#if CABAL_OS_WINDOWS + error "UNIX Sockets is unsupported on Windows platform" +#else do s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol S.setSocketOption s S.KeepAlive 0 S.connect s (S.SockAddrUnix path) return s +#endif -- | Close connection disconnect :: Redis -> IO () diff --git a/redis-2.0.conf b/redis-2.0.conf deleted file mode 100644 --- a/redis-2.0.conf +++ /dev/null @@ -1,18 +0,0 @@ -daemonize yes -timeout 300 -loglevel warning -logfile stdout -databases 2 - -# No snapshots -# save 900 1 -# save 300 10 -# save 60 10000 - -dir ./ - -# requirepass foobared -appendonly no -hash-max-zipmap-entries 64 -hash-max-zipmap-value 512 -activerehashing yes diff --git a/redis.cabal b/redis.cabal --- a/redis.cabal +++ b/redis.cabal @@ -1,5 +1,5 @@ Name: redis -Version: 0.12 +Version: 0.12.1 License: MIT Maintainer: Alexander Bogdanov Author: Alexander Bogdanov @@ -14,7 +14,7 @@ . This library is a Haskell driver for Redis. It's tested with current git version and with v2.4.6 of redis server. It also - tested with v2.2 and v2.0 and basic functions are works correctly + tested with v2.2 and basic functions are works correctly but not all of them. . You can use Test module from the source package to run unit @@ -40,6 +40,12 @@ - Fixed compilation with GHC 7.2 (and hopefully with more recent versions too), thanks Ben Gamari and Sean Hess for reporting. . + - Using RLock from concurrent-extra fixes multithreading issues, + thanks Dmitry Dzhus for reporting + . + - Hopefully, fix building on Windows (untested), thanks Piotr + Staszewski and Alexander Dorofeev + . Stability: beta Build-Type: Simple @@ -55,12 +61,13 @@ Test/ZSetCommands.hs, Test/HashCommands.hs, Test/MultiCommands.hs, Test/SortCommands.hs, Test/Monad/CASCommands.hs, Test/Monad/MultiCommands.hs, - redis-2.0.conf, redis-2.2.conf, - Benchmark.hs + redis-2.2.conf, + Benchmark.hs Library Build-Depends: base < 5, containers, bytestring, utf8-string, - network, mtl, old-time, MonadCatchIO-mtl + network, mtl, old-time, MonadCatchIO-mtl, + concurrent-extra Exposed-modules: Database.Redis.Redis Database.Redis.Monad Database.Redis.ByteStringClass