summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorToralfWittner <>2014-09-12 21:47:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-09-12 21:47:00 (GMT)
commit60683bc460a09450fcb81e8aac1c47966bad0c49 (patch)
tree744795d1c81c834d4a5e1d62c1b42f452a28805a
parentfa30cda91d796c021478c7ce3435b10dbd294afe (diff)
version 0.3.10.3.1
-rw-r--r--redis-io.cabal37
-rw-r--r--src/Database/Redis/IO/Connection.hs53
2 files changed, 38 insertions, 52 deletions
diff --git a/redis-io.cabal b/redis-io.cabal
index d2923f9..61e51a4 100644
--- a/redis-io.cabal
+++ b/redis-io.cabal
@@ -1,5 +1,5 @@
name: redis-io
-version: 0.3
+version: 0.3.1
synopsis: Yet another redis client.
license: OtherLicense
license-file: LICENSE
@@ -37,22 +37,19 @@ library
Database.Redis.IO.Types
build-depends:
- attoparsec >= 0.11 && < 0.13
- , auto-update >= 0.1 && < 0.2
- , base >= 4.5 && < 5.0
- , bytestring >= 0.9 && < 0.11
- , containers == 0.5.*
- , exceptions == 0.6.*
- , mtl == 2.1.*
- , network >= 2.5 && < 2.6
+ 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.*
- , pipes == 4.1.*
- , pipes-attoparsec == 0.5.*
- , pipes-parse == 3.0.*
- , redis-resp >= 0.2 && < 0.4
- , resource-pool >= 0.2 && < 0.3
- , time == 1.4.*
- , transformers >= 0.3 && < 0.5
+ , 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.*
test-suite redis-io-tests
@@ -73,8 +70,8 @@ test-suite redis-io-tests
, containers
, redis-io
, redis-resp
- , tasty == 0.8.*
- , tasty-hunit == 0.8.*
+ , tasty >= 0.10
+ , tasty-hunit >= 0.9
, tinylog
, transformers
@@ -87,8 +84,8 @@ benchmark redis-io-bench
build-depends:
base
, bytestring
- , criterion >= 1.0.0.2 && < 1.1
- , hedis >= 0.6
+ , criterion >= 1.0.0.2 && < 2.0
+ , hedis >= 0.6 && < 1.0
, redis-io
, redis-resp
, tinylog
diff --git a/src/Database/Redis/IO/Connection.hs b/src/Database/Redis/IO/Connection.hs
index a8b660b..c5a0c41 100644
--- a/src/Database/Redis/IO/Connection.hs
+++ b/src/Database/Redis/IO/Connection.hs
@@ -20,6 +20,7 @@ module Database.Redis.IO.Connection
import Control.Applicative
import Control.Exception
import Control.Monad
+import Data.Attoparsec.ByteString hiding (Result)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toChunks)
import Data.Foldable hiding (concatMap)
@@ -34,22 +35,18 @@ import Database.Redis.IO.Timeouts (TimeoutManager, withTimeout)
import Network
import Network.Socket hiding (connect, close, send, recv)
import Network.Socket.ByteString (recv, sendMany)
-import Pipes
-import Pipes.Attoparsec
-import Pipes.Parse
import System.Logger hiding (Settings, settings, close)
import System.Timeout
-import qualified Data.ByteString as B
-import qualified Data.Sequence as Seq
-import qualified Network.Socket as S
+import qualified Data.Sequence as Seq
+import qualified Network.Socket as S
data Connection = Connection
{ settings :: !Settings
, logger :: !Logger
, timeouts :: !TimeoutManager
, sock :: !Socket
- , producer :: IORef (Producer ByteString IO ())
+ , leftover :: IORef ByteString
, buffer :: IORef (Seq (Resp, IORef Resp))
}
@@ -67,18 +64,10 @@ connect t g m a = bracketOnError mkSock S.close $ \s -> do
ok <- timeout (ms (sConnectTimeout t) * 1000) (S.connect s (addrAddress a))
unless (isJust ok) $
throwIO ConnectTimeout
- Connection t g m s <$> newIORef (fromSock s) <*> newIORef Seq.empty
+ Connection t g m s <$> newIORef "" <*> newIORef Seq.empty
where
mkSock = socket (addrFamily a) (addrSocketType a) (addrProtocol a)
- fromSock :: Socket -> Producer ByteString IO ()
- fromSock s = do
- x <- lift $ recv s 4096
- when (B.null x) $
- lift $ throwIO ConnectionClosed
- yield x
- fromSock s
-
close :: Connection -> IO ()
close = S.close . sock
@@ -96,37 +85,37 @@ sync c = do
where
go a = do
send c (toList $ fmap fst a)
- prod <- readIORef (producer c)
- foldlM fetchResult prod (fmap snd a) >>= writeIORef (producer c)
+ bb <- readIORef (leftover c)
+ foldlM fetchResult bb (fmap snd a) >>= writeIORef (leftover c)
abort = do
err (logger c) $ "connection.timeout" .= show c
close c
throwIO $ Timeout (show c)
- fetchResult :: Producer ByteString IO () -> IORef Resp -> IO (Producer ByteString IO ())
- fetchResult p r = do
- (p', x) <- receiveWith p
+ fetchResult :: ByteString -> IORef Resp -> IO ByteString
+ fetchResult b r = do
+ (b', x) <- receiveWith c b
writeIORef r x
- return p'
+ return b'
send :: Connection -> [Resp] -> IO ()
send c = sendMany (sock c) . concatMap (toChunks . encode)
receive :: Connection -> IO Resp
receive c = do
- prod <- readIORef (producer c)
- (p, x) <- receiveWith prod
- writeIORef (producer c) p
+ bstr <- readIORef (leftover c)
+ (b, x) <- receiveWith c bstr
+ writeIORef (leftover c) b
return x
-receiveWith :: Producer ByteString IO () -> IO (Producer ByteString IO (), Resp)
-receiveWith p = do
- (x, p') <- runStateT (parse resp) p
- case x of
- Nothing -> throwIO ConnectionClosed
- Just (Left e) -> throwIO $ InternalError (peMessage e)
- Just (Right y) -> (p',) <$> errorCheck y
+receiveWith :: Connection -> ByteString -> IO (ByteString, Resp)
+receiveWith c b = do
+ res <- parseWith (recv (sock c) 4096) resp b
+ case res of
+ Fail _ _ m -> throwIO $ InternalError m
+ Partial _ -> throwIO $ InternalError "partial result"
+ Done b' x -> (b',) <$> errorCheck x
errorCheck :: Resp -> IO Resp
errorCheck (Err e) = throwIO $ RedisError e