redis-io 0.3.1 → 0.4.1
raw patch · 9 files changed
+122/−79 lines, 9 filesdep +monad-controldep +transformers-basedep ~bytestring-conversiondep ~tinylog
Dependencies added: monad-control, transformers-base
Dependency ranges changed: bytestring-conversion, tinylog
Files
- CHANGELOG.md +3/−0
- README.md +9/−0
- redis-io.cabal +23/−20
- src/Database/Redis/IO.hs +1/−1
- src/Database/Redis/IO/Client.hs +66/−28
- src/Database/Redis/IO/Connection.hs +2/−2
- src/Database/Redis/IO/Settings.hs +12/−22
- src/Database/Redis/IO/Timeouts.hs +3/−3
- src/Database/Redis/IO/Types.hs +3/−3
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+0.4.1+-----------------------------------------------------------------------------+- Support `monad-control` 1.*
+ README.md view
@@ -0,0 +1,9 @@+# redis-io++[](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
redis-io.cabal view
@@ -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 <tw@dtex.org>-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
src/Database/Redis/IO.hs view
@@ -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
src/Database/Redis/IO/Client.hs view
@@ -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
src/Database/Redis/IO/Connection.hs view
@@ -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
src/Database/Redis/IO/Settings.hs view
@@ -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
src/Database/Redis/IO/Timeouts.hs view
@@ -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
src/Database/Redis/IO/Types.hs view
@@ -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