diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +0.4.1 +----------------------------------------------------------------------------- +- Support `monad-control` 1.* diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# redis-io + +[![Build Status](https://travis-ci.org/twittner/redis-io.svg?branch=develop)](https://travis-ci.org/twittner/redis-io) + +*Yet another Redis client.* + +A redis client library interpreting [redis-resp][1] commands. + +[1]: https://github.com/twittner/redis-resp diff --git a/redis-io.cabal b/redis-io.cabal --- a/redis-io.cabal +++ b/redis-io.cabal @@ -1,17 +1,18 @@ name: redis-io -version: 0.3.1 +version: 0.4.1 synopsis: Yet another redis client. license: OtherLicense license-file: LICENSE author: Toralf Wittner maintainer: Toralf Wittner -copyright: (c) 2014 Toralf Wittner +copyright: (c) 2014-2015 Toralf Wittner homepage: https://github.com/twittner/redis-io/ bug-reports: https://github.com/twittner/redis-io/issues stability: experimental category: Database build-type: Simple cabal-version: >= 1.10 +extra-source-files: README.md, CHANGELOG.md description: Yet another redis client. @@ -37,20 +38,22 @@ Database.Redis.IO.Types build-depends: - attoparsec >= 0.12.1.2 && < 1.0 - , auto-update >= 0.1 && < 0.2 - , base >= 4.5 && < 5.0 - , bytestring >= 0.9 && < 1.0 - , containers >= 0.5 && < 1.0 - , exceptions >= 0.6 && < 1.0 - , mtl >= 2.1 && < 3.0 - , network >= 2.5 && < 3.0 - , operational == 0.2.* - , redis-resp >= 0.2 && < 0.4 - , resource-pool >= 0.2 && < 0.3 - , time >= 1.4 && < 2.0 - , transformers >= 0.3 && < 0.5 - , tinylog == 0.10.* + attoparsec >= 0.12.1.2 && < 1.0 + , auto-update >= 0.1 && < 0.2 + , base >= 4.5 && < 5.0 + , bytestring >= 0.9 && < 1.0 + , containers >= 0.5 && < 1.0 + , exceptions >= 0.6 && < 1.0 + , monad-control >= 0.3 && < 2.0 + , mtl >= 2.1 && < 3.0 + , network >= 2.5 && < 3.0 + , operational == 0.2.* + , redis-resp >= 0.2 && < 0.4 + , resource-pool >= 0.2 && < 0.3 + , time >= 1.4 && < 2.0 + , transformers >= 0.3 && < 0.5 + , transformers-base >= 0.4 && < 1.0 + , tinylog >= 0.10 && < 0.15 test-suite redis-io-tests type: exitcode-stdio-1.0 @@ -63,15 +66,15 @@ CommandTests build-depends: - async == 2.0.* + async == 2.0.* , base , bytestring - , bytestring-conversion == 0.2.* + , bytestring-conversion >= 0.2 , containers , redis-io , redis-resp - , tasty >= 0.10 - , tasty-hunit >= 0.9 + , tasty >= 0.10 + , tasty-hunit >= 0.9 , tinylog , transformers diff --git a/src/Database/Redis/IO.hs b/src/Database/Redis/IO.hs --- a/src/Database/Redis/IO.hs +++ b/src/Database/Redis/IO.hs @@ -5,6 +5,7 @@ module Database.Redis.IO ( -- * Redis client Client + , MonadClient (..) , runRedis , stepwise , pipelined @@ -22,7 +23,6 @@ , setPort , setIdleTimeout , setMaxConnections - , setMaxWaitQueue , setPoolStripes , setConnectTimeout , setSendRecvTimeout diff --git a/src/Database/Redis/IO/Client.hs b/src/Database/Redis/IO/Client.hs --- a/src/Database/Redis/IO/Client.hs +++ b/src/Database/Redis/IO/Client.hs @@ -2,23 +2,33 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at http://mozilla.org/MPL/2.0/. +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Database.Redis.IO.Client where import Control.Applicative import Control.Exception (throw, throwIO) +import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch +import Control.Monad.IO.Class import Control.Monad.Operational -import Control.Monad.Reader +import Control.Monad.Reader (ReaderT (..), runReaderT, MonadReader, ask, asks) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Control (MonadBaseControl (..)) +#if MIN_VERSION_transformers(0,4,0) +import Control.Monad.Trans.Except +#endif import Data.ByteString.Lazy (ByteString) import Data.Int import Data.IORef import Data.Redis -import Data.Word import Data.Pool hiding (Pool) import Database.Redis.IO.Connection (Connection) import Database.Redis.IO.Settings @@ -28,6 +38,8 @@ import System.Logger.Class hiding (Settings, settings, eval) import System.IO.Unsafe (unsafeInterleaveIO) +import qualified Control.Monad.State.Strict as S +import qualified Control.Monad.State.Lazy as L import qualified Data.Pool as P import qualified Database.Redis.IO.Connection as C import qualified System.Logger as Logger @@ -35,11 +47,10 @@ -- | Connection pool. data Pool = Pool - { settings :: Settings - , connPool :: P.Pool Connection - , logger :: Logger.Logger - , failures :: IORef Word64 - , timeouts :: TimeoutManager + { settings :: !Settings + , connPool :: !(P.Pool Connection) + , logger :: !Logger.Logger + , timeouts :: !TimeoutManager } -- | Redis client monad. @@ -53,11 +64,51 @@ , MonadMask , MonadCatch , MonadReader Pool + , MonadBase IO ) instance MonadLogger Client where log l m = asks logger >>= \g -> Logger.log g l m +#if MIN_VERSION_monad_control(1,0,0) +instance MonadBaseControl IO Client where + type StM Client a = StM (ReaderT Pool IO) a + liftBaseWith f = Client . liftBaseWith $ \run -> f (run . client) + restoreM = Client . restoreM +#else +instance MonadBaseControl IO Client where + newtype StM Client a = ClientStM + { unClientStM :: StM (ReaderT Pool IO) a } + + liftBaseWith f = + Client . liftBaseWith $ \run -> f (fmap ClientStM . run . client) + + restoreM = Client . restoreM . unClientStM +#endif + +-- | Monads in which 'Client' actions may be embedded. +class (Functor m, Applicative m, Monad m, MonadIO m, MonadCatch m) => MonadClient m + where + -- | Lift a computation to the 'Client' monad. + liftClient :: Client a -> m a + +instance MonadClient Client where + liftClient = id + +instance MonadClient m => MonadClient (ReaderT r m) where + liftClient = lift . liftClient + +instance MonadClient m => MonadClient (S.StateT s m) where + liftClient = lift . liftClient + +instance MonadClient m => MonadClient (L.StateT s m) where + liftClient = lift . liftClient + +#if MIN_VERSION_transformers(0,4,0) +instance MonadClient m => MonadClient (ExceptT e m) where + liftClient = lift . liftClient +#endif + mkPool :: MonadIO m => Logger -> Settings -> m Pool mkPool g s = liftIO $ do t <- TM.create 250 @@ -68,7 +119,6 @@ (sIdleTimeout s) (sMaxConnections s) <*> pure g - <*> newIORef 0 <*> pure t where connOpen t a = do @@ -91,8 +141,8 @@ -- the next command. A failing command which produces a 'RedisError' will -- interrupt the command sequence and the error will be thrown as an -- exception. -stepwise :: Redis IO a -> Client a -stepwise a = withConnection (flip (eval getEager) a) +stepwise :: MonadClient m => Redis IO a -> m a +stepwise a = liftClient $ withConnection (flip (eval getEager) a) -- | Execute the given redis commands pipelined. I.e. commands are send in -- batches to the server and the responses are fetched and parsed after @@ -100,14 +150,14 @@ -- a 'RedisError' will /not/ prevent subsequent commands from being -- executed by the redis server. However the first error will be thrown as -- an exception. -pipelined :: Redis IO a -> Client a -pipelined a = withConnection (flip (eval getLazy) a) +pipelined :: MonadClient m => Redis IO a -> m a +pipelined a = liftClient $ withConnection (flip (eval getLazy) a) -- | Execute the given publish\/subscribe commands. The first parameter is -- the callback function which will be invoked with channel and message -- once messages arrive. -pubSub :: (ByteString -> ByteString -> PubSub IO ()) -> PubSub IO () -> Client () -pubSub f a = withConnection (loop a) +pubSub :: MonadClient m => (ByteString -> ByteString -> PubSub IO ()) -> PubSub IO () -> m () +pubSub f a = liftClient $ withConnection (loop a) where loop :: PubSub IO () -> Connection -> IO ((), [IO ()]) loop p h = do @@ -305,20 +355,8 @@ withConnection f = do p <- ask let c = connPool p - s = settings p - liftIO $ case sMaxWaitQueue s of - Nothing -> withResource c $ \h -> f h >>= \(a, i) -> sequence_ i >> return a - Just q -> tryWithResource c (go p) >>= maybe (retry q c p) return - where - go p h = do - atomicModifyIORef' (failures p) $ \n -> (if n > 0 then n - 1 else 0, ()) - f h >>= \(a, i) -> sequence_ i >> return a - - retry q c p = do - k <- atomicModifyIORef' (failures p) $ \n -> (n + 1, n) - unless (k < q) $ - throwIO ConnectionsBusy - withResource c (go p) + x <- liftIO $ tryWithResource c $ \h -> f h >>= \(a, i) -> sequence_ i >> return a + maybe (throwM ConnectionsBusy) return x getLazy :: Connection -> Resp -> (Resp -> Result a) -> IO (a, IO ()) getLazy h x g = do diff --git a/src/Database/Redis/IO/Connection.hs b/src/Database/Redis/IO/Connection.hs --- a/src/Database/Redis/IO/Connection.hs +++ b/src/Database/Redis/IO/Connection.hs @@ -46,8 +46,8 @@ , logger :: !Logger , timeouts :: !TimeoutManager , sock :: !Socket - , leftover :: IORef ByteString - , buffer :: IORef (Seq (Resp, IORef Resp)) + , leftover :: !(IORef ByteString) + , buffer :: !(IORef (Seq (Resp, IORef Resp))) } instance Show Connection where diff --git a/src/Database/Redis/IO/Settings.hs b/src/Database/Redis/IO/Settings.hs --- a/src/Database/Redis/IO/Settings.hs +++ b/src/Database/Redis/IO/Settings.hs @@ -11,14 +11,13 @@ import Database.Redis.IO.Types (Milliseconds (..)) data Settings = Settings - { sHost :: String - , sPort :: Word16 - , sIdleTimeout :: NominalDiffTime - , sMaxConnections :: Int - , sPoolStripes :: Int - , sMaxWaitQueue :: Maybe Word64 - , sConnectTimeout :: Milliseconds - , sSendRecvTimeout :: Milliseconds + { sHost :: !String + , sPort :: !Word16 + , sIdleTimeout :: !NominalDiffTime + , sMaxConnections :: !Int + , sPoolStripes :: !Int + , sConnectTimeout :: !Milliseconds + , sSendRecvTimeout :: !Milliseconds } -- | Default settings. @@ -28,17 +27,15 @@ -- * idle timeout = 60s -- * stripes = 2 -- * connections per stripe = 25 --- * max. wait queue = unbounded -- * connect timeout = 5s -- * send-receive timeout = 10s defSettings :: Settings defSettings = Settings "localhost" 6379 - 60 -- idle timeout - 25 -- max connections per stripe - 2 -- max stripes - Nothing -- max wait queue - 5000 -- connect timeout - 10000 -- send and recv timeout (sum) + 60 -- idle timeout + 50 -- max connections per stripe + 2 -- max stripes + 5000 -- connect timeout + 10000 -- send and recv timeout (sum) setHost :: String -> Settings -> Settings setHost v s = s { sHost = v } @@ -52,13 +49,6 @@ -- | Maximum connections per pool stripe. setMaxConnections :: Int -> Settings -> Settings setMaxConnections v s = s { sMaxConnections = v } - --- | Maximum length of the wait queue, i.e. the queue where attempts to --- acquire a connection from the pool build up if all connections are in --- use. If the maximum length has been reached, attempting to acquire --- a connection will cause a 'ConnectionsBusy' 'ConnectionError'. -setMaxWaitQueue :: Word64 -> Settings -> Settings -setMaxWaitQueue v s = s { sMaxWaitQueue = Just v } setPoolStripes :: Int -> Settings -> Settings setPoolStripes v s diff --git a/src/Database/Redis/IO/Timeouts.hs b/src/Database/Redis/IO/Timeouts.hs --- a/src/Database/Redis/IO/Timeouts.hs +++ b/src/Database/Redis/IO/Timeouts.hs @@ -22,12 +22,12 @@ data TimeoutManager = TimeoutManager { roundtrip :: !Int - , reaper :: Reaper [Action] Action + , reaper :: !(Reaper [Action] Action) } data Action = Action - { action :: IO () - , state :: IORef State + { action :: !(IO ()) + , state :: !(IORef State) } data State = Running !Int | Canceled diff --git a/src/Database/Redis/IO/Types.hs b/src/Database/Redis/IO/Types.hs --- a/src/Database/Redis/IO/Types.hs +++ b/src/Database/Redis/IO/Types.hs @@ -16,7 +16,7 @@ -- ConnectionError data ConnectionError - = ConnectionsBusy -- ^ All connections are in use and wait queue is full. + = ConnectionsBusy -- ^ All connections are in use. | ConnectionClosed -- ^ The connection has been closed unexpectedly. | ConnectTimeout -- ^ Connecting to redis server took too long. deriving Typeable @@ -32,7 +32,7 @@ -- InternalError -- | General error, e.g. parsing redis responses failed. -data InternalError = InternalError String +newtype InternalError = InternalError String deriving Typeable instance Exception InternalError @@ -44,7 +44,7 @@ -- Timeout -- | A single send-receive cycle took too long. -data Timeout = Timeout String +newtype Timeout = Timeout String deriving Typeable instance Exception Timeout