diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs --- a/benchmark/Benchmark.hs +++ b/benchmark/Benchmark.hs @@ -19,13 +19,13 @@ ---------------------------------------------------------------------- -- Preparation -- - conn <- connect "localhost" (PortNumber 6379) + conn <- connect defaultConnectInfo runRedis conn $ do + _ <- flushall Right _ <- mset [ ("k1","v1"), ("k2","v2"), ("k3","v3") , ("k4","v4"), ("k5","v5") ] - return () - disconnect conn + return () ---------------------------------------------------------------------- -- Spawn clients @@ -33,7 +33,7 @@ start <- newEmptyMVar done <- newEmptyMVar replicateM_ nClients $ forkIO $ do - c <- connect "localhost" (PortNumber 6379) + c <- connect defaultConnectInfo runRedis c $ forever $ do action <- liftIO $ takeMVar start replicateM_ (nRequests `div` nClients) $ action @@ -64,4 +64,3 @@ let expected = map Just ["v1","v2","v3","v4","v5"] True <- return $ vs == expected return () - diff --git a/hedis.cabal b/hedis.cabal --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.1 +version: 0.2 synopsis: Client library for the Redis datastore: supports full command set, pipelining. @@ -12,10 +12,7 @@ . [Complete Redis 2.4 command set:] All Redis commands () are available as haskell functions. The - exceptions to the rule are a handfull of internal and debugging - commands: MONITOR, DEBUG OBJECT, DEBUG SEGFAULT, SYNC. If needed, these - commands can easily be implemented by the library user with the - 'sendRequest' function. + exceptions to the rule are the MONITOR and SYNC commands. . [Pipelining \"Just Works\":] Commands are pipelined () as much as possible without any @@ -35,8 +32,12 @@ category: Database build-type: Simple cabal-version: >=1.8 +homepage: https://github.com/informatikr/hedis +bug-reports: https://github.com/informatikr/hedis/issues -bug-reports: https://github.com/informatikr/hedis/issues +source-repository head + type: git + location: https://github.com/informatikr/hedis flag benchmark description: Build the benchmark executable. @@ -52,9 +53,11 @@ bytestring == 0.9.*, bytestring-lexing == 0.2.*, mtl == 2.*, - network == 2.* + network == 2.*, + resource-pool == 0.2.0.* - other-modules: Database.Redis.Internal, + other-modules: Database.Redis.Core, + Database.Redis.Connection Database.Redis.PubSub, Database.Redis.Reply, Database.Redis.Request, @@ -64,17 +67,13 @@ executable hedis-benchmark main-is: benchmark/Benchmark.hs - ghc-options: -Wall -rtsopts - ghc-prof-options: -auto-all - if ! flag(benchmark) - buildable: False - else + if flag(benchmark) build-depends: base >= 4, mtl == 2.0.*, hedis, - time >= 1.2 - -source-repository head - type: git - location: https://github.com/informatikr/hedis + time >= 1.2 + else + buildable: False + ghc-options: -Wall -rtsopts + 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,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Database.Redis ( @@ -6,8 +6,9 @@ Redis(), runRedis, -- * Connection - RedisConn, connect, disconnect, - HostName,PortID(..),defaultPort, + Connection, connect, + ConnectInfo(..),defaultConnectInfo, + HostName,PortID(..), -- * Commands module Database.Redis.Commands, @@ -15,22 +16,13 @@ -- * Pub\/Sub module Database.Redis.PubSub, - -- * Low-Level Requests and Replies - sendRequest, - -- |'sendRequest' can be used to implement one of the unimplemented - -- commands, as shown below. - -- - -- @ - -- -- |Redis DEBUG OBJECT command - -- debugObject :: ByteString -> 'Redis' (Either 'Reply' ByteString) - -- debugObject key = 'sendRequest' [\"DEBUG\", \"OBJECT\", 'encode' key] - -- @ - -- - Reply(..),Status(..),RedisResult(..) + -- * Redis Return Types + Reply(..),Status(..) ) where -import Database.Redis.Internal +import Database.Redis.Core +import Database.Redis.Connection import Database.Redis.PubSub import Database.Redis.Reply import Database.Redis.Types 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 @@ -74,6 +74,8 @@ configResetstat, -- |Reset the stats returned by INFO (). configSet, -- |Set a configuration parameter to the given value (). dbsize, -- |Return the number of keys in the selected database (). +debugObject, -- |Get debugging information about a key (). +debugSegfault, -- |Make the server crash (). flushall, -- |Remove all keys from all databases (). flushdb, -- |Remove all keys from the current database (). info, -- |Get information and statistics about the server (). @@ -158,7 +160,7 @@ watch, -- |Watch the given keys to determine execution of the MULTI/EXEC block (). -- * Unimplemented Commands --- |These commands are not implemented, as of now. Library users can implement them with the 'sendRequest' function. +-- |These commands are not implemented, as of now. -- -- * EVAL () -- @@ -166,12 +168,6 @@ -- * MONITOR () -- -- --- * DEBUG OBJECT () --- --- --- * DEBUG SEGFAULT () --- --- -- * SYNC () -- ) where @@ -180,7 +176,7 @@ import Data.ByteString (ByteString) import Database.Redis.ManualCommands import Database.Redis.Types -import Database.Redis.Internal +import Database.Redis.Core import Database.Redis.Reply flushall @@ -464,6 +460,11 @@ -> Redis (Either Reply Status) slaveof host port = sendRequest (["SLAVEOF"] ++ [encode host] ++ [encode port] ) +debugObject + :: ByteString -- ^ key + -> Redis (Either Reply ByteString) +debugObject key = sendRequest (["DEBUG","OBJECT"] ++ [encode key] ) + getset :: ByteString -- ^ key -> ByteString -- ^ value @@ -748,6 +749,10 @@ :: Redis (Either Reply Status) discard = sendRequest (["DISCARD"] ) +debugSegfault + :: Redis (Either Reply Status) +debugSegfault = sendRequest (["DEBUG","SEGFAULT"] ) + srandmember :: ByteString -- ^ key -> Redis (Either Reply ByteString) @@ -760,18 +765,12 @@ -- * Unimplemented Commands --- |These commands are not implemented, as of now. Library users can implement them with the 'sendRequest' function. +-- |These commands are not implemented, as of now. -- -- * EVAL () -- -- -- * MONITOR () --- --- --- * DEBUG OBJECT () --- --- --- * DEBUG SEGFAULT () -- -- -- * SYNC () diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Redis/Connection.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE RecordWildCards #-} + +module Database.Redis.Connection ( + HostName,PortID(..), + ConnectInfo(..),defaultConnectInfo, + Connection(), connect +) where + +import Control.Applicative +import Control.Monad.Reader +import Control.Concurrent +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.IORef +import Data.Pool +import Network (HostName, PortID(..), connectTo) +import System.IO (hClose, hIsOpen, hSetBinaryMode) + +import Database.Redis.Core +import Database.Redis.Commands (auth) +import Database.Redis.Reply + +-- |Information for connnecting to a Redis server. +-- +-- It is recommended to not use the 'ConnInfo' data constructor directly. +-- Instead use 'defaultConnectInfo' and update it with record syntax. For +-- example to connect to a password protected Redis server running on localhost +-- and listening to the default port: +-- +-- @ +-- myConnectInfo :: ConnectInfo +-- myConnectInfo = defaultConnectInfo {connectAuth = Just \"secret\"} +-- @ +-- +data ConnectInfo = ConnInfo + { connectHost :: HostName + , connectPort :: PortID + , connectAuth :: Maybe B.ByteString + } + +-- |Default information for connecting: +-- +-- @ +-- connectHost = \"localhost\" +-- connectPort = PortNumber 6379 -- Redis default port +-- connectAuth = Nothing -- No password +-- @ +-- +defaultConnectInfo :: ConnectInfo +defaultConnectInfo = ConnInfo + { connectHost = "localhost" + , connectPort = PortNumber 6379 + , connectAuth = Nothing + } + +-- |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 + where + create = do + h <- connectTo connectHost connectPort + rs' <- parseReply <$> {-# SCC "LB.hgetContents" #-} LB.hGetContents h + rs <- newIORef rs' + 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) diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs new file mode 100644 --- /dev/null +++ b/src/Database/Redis/Core.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Database.Redis.Core ( + Connection(..), + Redis(),runRedis,runRedisInternal, + send, + recv, + sendRequest +) where + +import Control.Applicative +import Control.Arrow +import Control.Monad.Reader +import Control.Concurrent +import qualified Data.ByteString as B +import Data.IORef +import Data.Pool +import System.IO (Handle, hFlush) + +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. +newtype Connection = Conn (Pool (MVar (Handle, IORef [Reply]))) + +-- |All Redis commands run in the 'Redis' monad. +newtype Redis a = Redis (ReaderT RedisEnv IO a) + deriving (Monad, MonadIO, Functor, Applicative) + +type RedisEnv = (Handle, IORef [Reply]) + +askHandle :: ReaderT RedisEnv IO Handle +askHandle = asks fst + +askReplies :: ReaderT RedisEnv IO (IORef [Reply]) +askReplies = asks snd + +-- |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. +runRedis :: Connection -> Redis a -> IO a +runRedis (Conn pool) redis = + withResource pool $ \conn -> + withMVar conn $ \conn' -> runRedisInternal conn' redis + +-- |Internal version of 'runRedis' that does not depend on the 'Connection' +-- abstraction. Used to run the AUTH command when connecting. +runRedisInternal :: RedisEnv -> Redis a -> IO a +runRedisInternal env (Redis redis) = runReaderT redis env + +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 + +recv :: Redis Reply +recv = Redis $ do + -- head/tail avoids forcing the ':' constructor, enabling automatic + -- pipelining. + rs <- askReplies + liftIO $ atomicModifyIORef rs (tail &&& head) + +sendRequest :: (RedisResult a) => [B.ByteString] -> Redis (Either Reply a) +sendRequest req = decode <$> (send req >> recv) diff --git a/src/Database/Redis/Internal.hs b/src/Database/Redis/Internal.hs deleted file mode 100644 --- a/src/Database/Redis/Internal.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Database.Redis.Internal ( - HostName,PortID(..), defaultPort, - RedisConn(), connect, disconnect, - Redis(),runRedis, - send, - recv, - sendRequest -) where - -import Control.Applicative -import Control.Monad.RWS -import Control.Concurrent -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy.Char8 as LB -import Network (HostName, PortID(..), connectTo) -import System.IO (Handle, hFlush, hClose, hIsOpen) - -import Database.Redis.Reply -import Database.Redis.Request -import Database.Redis.Types - ------------------------------------------------------------------------------- --- Connection --- - --- |Connection to a Redis server. Use the 'connect' function to create one. --- --- A 'RedisConn' can only be used by a single thread at a time. This means that --- calls to 'runRedis' or 'disconnet' may block when the 'RedisConn' is shared --- between multiple threads. -data RedisConn = Conn (MVar (Handle, [Reply])) - -withConn :: RedisConn - -> (Handle -> [Reply] -> IO ([Reply], a)) - -> IO a -withConn (Conn conn) f = do - (h,rs) <- takeMVar conn - (rs',a) <- f h rs - putMVar conn (h,rs') - return a - --- |Opens a connection to a Redis server at the given host and port. -connect :: HostName -> PortID -> IO RedisConn -connect host port = do - h <- connectTo host port - replies <- parseReply <$> LB.hGetContents h - Conn <$> newMVar (h, replies) - --- |Close the given connection. --- --- May block when the given 'RedisConn' is shared between multiple threads. The --- 'RedisConn' can not be re-used. -disconnect :: RedisConn -> IO () -disconnect conn = withConn conn $ \h rs -> do - open <- hIsOpen h - when open (hClose h) - return (rs, ()) - --- | The Redis default port 6379. Equivalent to @'PortNumber' 6379@. -defaultPort :: PortID -defaultPort = PortNumber 6379 - ------------------------------------------------------------------------------- --- The Redis Monad --- -newtype Redis a = Redis (RWST Handle () [Reply] IO a) - deriving (Monad, MonadIO, Functor, Applicative) - --- |Interact with a Redis datastore specified by the given 'RedisConn'. --- --- May block when the given 'RedisConn' is shared between multiple threads. -runRedis :: RedisConn -> Redis a -> IO a -runRedis conn (Redis redis) = withConn conn $ \h rs -> do - open <- hIsOpen h - if open - then do - (a,rs',_) <- runRWST redis h rs - return (rs',a) - else error "Redis: disconnected" - -send :: [B.ByteString] -> Redis () -send req = Redis $ do - h <- ask - liftIO $ do - B.hPut h $ renderRequest req - hFlush h - -recv :: Redis Reply -recv = Redis $ do - -- head/tail avoids forcing the ':' constructor, enabling automatic - -- pipelining. - rs <- get - put (tail rs) - return (head rs) - --- |Sends a request to the Redis server, returning the 'decode'd reply. -sendRequest :: (RedisResult a) => [B.ByteString] -> Redis (Either Reply a) -sendRequest req = decode <$> (send req >> recv) diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -4,7 +4,7 @@ import Prelude hiding (min,max) import Data.ByteString (ByteString) -import Database.Redis.Internal +import Database.Redis.Core import Database.Redis.Reply import Database.Redis.Types 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 @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Database.Redis.PubSub ( publish, pubSub, @@ -13,8 +12,7 @@ import Control.Monad.Writer import Data.ByteString.Char8 (ByteString) import Data.Maybe -import Database.Redis.Internal (Redis) -import qualified Database.Redis.Internal as Internal +import qualified Database.Redis.Core as Core import Database.Redis.Reply import Database.Redis.Types @@ -37,9 +35,9 @@ publish :: ByteString -- ^ channel -> ByteString -- ^ message - -> Redis (Either Reply Integer) + -> Core.Redis (Either Reply Integer) publish channel message = - Internal.sendRequest ["PUBLISH", channel, message] + Core.sendRequest ["PUBLISH", channel, message] -- |Listen for messages published to the given channels -- (). @@ -94,15 +92,15 @@ pubSub :: PubSub -- ^ Initial subscriptions. -> (Message -> IO PubSub) -- ^ Callback function. - -> Redis () + -> Core.Redis () pubSub p callback = send p 0 where send (PubSub cmds) pending = do - mapM_ Internal.send cmds + mapM_ Core.send cmds recv (pending + length cmds) recv pending = do - reply <- Internal.recv + reply <- Core.recv case decodeMsg reply of Left cnt | cnt == 0 && pending == 0 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 @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, - TypeSynonymInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, OverlappingInstances, TypeSynonymInstances, + OverloadedStrings #-} module Database.Redis.Types where @@ -8,8 +8,10 @@ import Data.ByteString.Char8 (ByteString, pack) import Data.ByteString.Lex.Double (readDouble) import Data.Maybe + import Database.Redis.Reply + ------------------------------------------------------------------------------ -- Classes of types Redis understands -- @@ -41,6 +43,7 @@ decode = Right instance RedisResult ByteString where + decode (SingleLine s) = Right s decode (Bulk (Just s)) = Right s decode r = Left r