summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorToralfWittner <>2016-03-26 23:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-03-26 23:03:00 (GMT)
commit260d0292528c526aec686ed0602b2d63023ac345 (patch)
tree3b6bb1e3c02b84e2d1fdce7bf6605cb19109bc25
parentf76388adbc9ef9912faef04cb5082bce15a557a1 (diff)
version 0.6.00.6.0
-rw-r--r--CHANGELOG.md6
-rw-r--r--README.md4
-rw-r--r--redis-io.cabal52
-rw-r--r--src/Database/Redis/IO/Client.hs33
-rw-r--r--src/Database/Redis/IO/Connection.hs32
-rw-r--r--src/Database/Redis/IO/Types.hs7
-rw-r--r--test/CommandTests.hs4
-rw-r--r--test/Test.hs7
8 files changed, 88 insertions, 57 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 8d2315c..ea8787c 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,9 @@
+0.6.0
+-----------------------------------------------------------------------------
+- The `TransactionFailure` type distinguishes more cases.
+- Bugfixes:
+ https://gitlab.com/twittner/redis-io/merge_requests/1
+
0.5.2
-----------------------------------------------------------------------------
- Update test dependencies
diff --git a/README.md b/README.md
index 737dc9a..569c8a1 100644
--- a/README.md
+++ b/README.md
@@ -1,9 +1,7 @@
# 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
+[1]: https://gitlab.com/twittner/redis-resp
diff --git a/redis-io.cabal b/redis-io.cabal
index 78b179f..0093e68 100644
--- a/redis-io.cabal
+++ b/redis-io.cabal
@@ -1,13 +1,13 @@
name: redis-io
-version: 0.5.2
+version: 0.6.0
synopsis: Yet another redis client.
license: MPL-2.0
license-file: LICENSE
author: Toralf Wittner
maintainer: Toralf Wittner <tw@dtex.org>
-copyright: (C) 2014-2016 Toralf Wittner
-homepage: https://github.com/twittner/redis-io/
-bug-reports: https://github.com/twittner/redis-io/issues
+copyright: (C) 2014 Toralf Wittner
+homepage: https://gitlab.com/twittner/redis-io/
+bug-reports: https://gitlab.com/twittner/redis-io/issues
stability: experimental
category: Database
build-type: Simple
@@ -19,7 +19,7 @@ description:
source-repository head
type: git
- location: git://github.com/twittner/redis-io.git
+ location: git://gitlab.com/twittner/redis-io.git
library
default-language: Haskell2010
@@ -37,25 +37,25 @@ library
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
- , iproute >= 1.3 && < 2.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
- , semigroups >= 0.16 && < 0.20
- , stm >= 2.4 && < 3.0
- , time >= 1.4 && < 2.0
- , transformers >= 0.3 && < 0.5
- , transformers-base >= 0.4 && < 1.0
- , tinylog >= 0.10 && < 0.15
+ attoparsec >= 0.12.1.2
+ , auto-update >= 0.1
+ , base >= 4.5 && < 5
+ , bytestring >= 0.9
+ , containers >= 0.5
+ , exceptions >= 0.6
+ , iproute >= 1.3
+ , monad-control >= 0.3
+ , mtl >= 2.1
+ , network >= 2.5
+ , operational >= 0.2
+ , redis-resp >= 0.4
+ , resource-pool >= 0.2
+ , semigroups >= 0.16
+ , stm >= 2.4
+ , time >= 1.4
+ , transformers >= 0.3
+ , transformers-base >= 0.4
+ , tinylog >= 0.10
test-suite redis-io-tests
type: exitcode-stdio-1.0
@@ -89,8 +89,8 @@ benchmark redis-io-bench
build-depends:
base
, bytestring
- , criterion >= 1.0.0.2 && < 2.0
- , hedis >= 0.6 && < 1.0
+ , criterion >= 1.0.0.2
+ , hedis >= 0.6
, redis-io
, redis-resp
, tinylog
diff --git a/src/Database/Redis/IO/Client.hs b/src/Database/Redis/IO/Client.hs
index cc02d87..a3a48db 100644
--- a/src/Database/Redis/IO/Client.hs
+++ b/src/Database/Redis/IO/Client.hs
@@ -42,6 +42,7 @@ import qualified Control.Monad.State.Strict as S
import qualified Control.Monad.State.Lazy as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Pool as P
+import qualified Data.Sequence as Seq
import qualified Database.Redis.IO.Connection as C
import qualified System.Logger as Logger
import qualified Database.Redis.IO.Timeouts as TM
@@ -156,13 +157,20 @@ pipelined a = liftClient $ withConnection (flip (eval getLazy) a)
-- | Execute the given redis commands in a Redis transaction.
+-- The commands in 'transactional' are implicitly run within @MULTI@ and
+-- @EXEC@, i.e. neither must be part of the commands. @DISCARD@ can be
+-- used and throws 'TransactionAborted'.
transactional :: MonadClient m => Redis IO a -> m a
transactional a = liftClient $ withConnection (flip (eval getTransaction) a)
--- | Execute the given publish\/subscribe commands. The first parameter is
--- the callback function which will be invoked with channel and message
+-- | Execute the given publish\/subscribe commands.
+-- The first parameter is the callback function which will be invoked with
+-- a possible pattern (if @PSUBSCRIBE@ was used), channel, and message,
-- once messages arrive.
-pubSub :: MonadClient m => (ByteString -> ByteString -> PubSub IO ()) -> PubSub IO () -> m ()
+pubSub :: MonadClient m
+ => (Maybe ByteString -> ByteString -> ByteString -> PubSub IO ())
+ -> PubSub IO ()
+ -> m ()
pubSub f a = liftClient $ withConnection (loop a)
where
loop :: PubSub IO () -> Connection -> IO ((), [IO ()])
@@ -178,18 +186,20 @@ pubSub f a = liftClient $ withConnection (loop a)
r <- viewT c
case r of
Return x -> return x
- Subscribe x :>>= k -> C.send h [x] >>= commands h . k
- Unsubscribe x :>>= k -> C.send h [x] >>= commands h . k
- PSubscribe x :>>= k -> C.send h [x] >>= commands h . k
- PUnsubscribe x :>>= k -> C.send h [x] >>= commands h . k
+ Subscribe x :>>= k -> C.send h (Seq.singleton x) >>= commands h . k
+ Unsubscribe x :>>= k -> C.send h (Seq.singleton x) >>= commands h . k
+ PSubscribe x :>>= k -> C.send h (Seq.singleton x) >>= commands h . k
+ PUnsubscribe x :>>= k -> C.send h (Seq.singleton x) >>= commands h . k
responses :: Connection -> IO (Maybe (PubSub IO ()))
responses h = do
m <- readPushMessage <$> C.receive h
case m of
- Right (Message ch ms) -> return (Just $ f ch ms)
+ Right (Message ch ms) -> return (Just $ f Nothing ch ms)
+ Right (PMessage pat ch ms) -> return (Just $ f (Just pat) ch ms)
Right (UnsubscribeMessage _ 0) -> return Nothing
- Right _ -> responses h
+ Right UnsubscribeMessage {} -> responses h
+ Right SubscribeMessage {} -> responses h
Left e -> throwIO e
eval :: (forall a. Connection -> Resp -> (Resp -> Result a) -> IO (a, IO ()))
@@ -225,8 +235,7 @@ eval f conn red = run conn [] red
Watch x :>>= k -> f h x (matchStr "WATCH" "OK") >>= \(a, i) -> run h (i:ii) $ k a
Unwatch x :>>= k -> f h x (matchStr "UNWATCH" "OK") >>= \(a, i) -> run h (i:ii) $ k a
Discard x :>>= k -> f h x (matchStr "DISCARD" "OK") >>= \(a, i) -> run h (i:ii) $ k a
- Exec x :>>= k -> f h x (readList "EXEC") >>= \(a, i) -> run h (i:ii) $ k a
- ExecRaw x :>>= k -> f h x return >>= \(a, i) -> run h (i:ii) $ k a
+ Exec x :>>= k -> f h x (const $ Right ()) >>= \(a, i) -> run h (i:ii) $ k a
-- Keys
Del x :>>= k -> f h x (readInt "DEL") >>= \(a, i) -> run h (i:ii) $ k a
@@ -399,7 +408,7 @@ getNow h x g = do
-- receives through the underlying socket.
getEager :: Connection -> Resp -> (Resp -> Result a) -> IO (a, IO ())
getEager c r f = do
- C.send c [r]
+ C.send c (Seq.singleton r)
a <- either throwIO return =<< f <$> C.receive c
return (a, return ())
{-# INLINE getEager #-}
diff --git a/src/Database/Redis/IO/Connection.hs b/src/Database/Redis/IO/Connection.hs
index 68ce9fe..eabdcfa 100644
--- a/src/Database/Redis/IO/Connection.hs
+++ b/src/Database/Redis/IO/Connection.hs
@@ -30,7 +30,7 @@ import Data.Foldable (for_, foldlM, toList)
import Data.IORef
import Data.Maybe (isJust)
import Data.Redis
-import Data.Sequence (Seq, (|>))
+import Data.Sequence (Seq, (<|), (|>))
import Data.Int
import Data.Word
import Foreign.C.Types (CInt (..))
@@ -102,18 +102,23 @@ transaction c = do
t -> withTimeout (timeouts c) t (abort c) (go buf)
where
go buf = do
- let (reqs, vars) = unzip (toList buf)
- send c (cmdMulti : reqs ++ [cmdExecute])
+ send c ((cmdMulti <| fmap fst buf) |> cmdExecute)
receive c >>= expect "MULTI" "OK"
- for_ vars $ const $
- receive c >>= expect "*" "QUEUED"
+ for_ buf $ \(cmd, _) -> do
+ res <- receive c
+ if cmd == cmdDiscard then do
+ expect "DISCARD" "OK" res
+ throwIO TransactionDiscarded
+ else
+ expect "*" "QUEUED" res
(lft, res) <- receiveWith c =<< readIORef (leftover c)
writeIORef (leftover c) lft
case res of
- Array n resps
- | n == length vars -> mapM_ (uncurry writeIORef) (zip vars resps)
- Err e -> throwIO (TransactionFailure $ show e)
- _ -> throwIO (TransactionFailure "invalid exec response")
+ Array _ xs -> mapM_ (uncurry writeIORef) (zip (toList $ fmap snd buf) xs)
+ NullArray -> throwIO TransactionAborted
+ NullBulk -> throwIO TransactionAborted
+ Err e -> throwIO (TransactionFailure $ show e)
+ _ -> throwIO (TransactionFailure "invalid response for exec")
sync :: Connection -> IO ()
sync c = do
@@ -125,7 +130,7 @@ sync c = do
t -> withTimeout (timeouts c) t (abort c) (go buf)
where
go buf = do
- send c (toList $ fmap fst buf)
+ send c (fmap fst buf)
bb <- readIORef (leftover c)
foldlM fetchResult bb (fmap snd buf) >>= writeIORef (leftover c)
@@ -141,8 +146,8 @@ abort c = do
close c
throwIO $ Timeout (show c)
-send :: Connection -> [Resp] -> IO ()
-send c = sendMany (sock c) . concatMap (toChunks . encode)
+send :: Connection -> Seq Resp -> IO ()
+send c = sendMany (sock c) . concatMap (toChunks . encode) . toList
receive :: Connection -> IO Resp
receive c = do
@@ -174,5 +179,8 @@ cmdMulti = Array 1 [Bulk "MULTI"]
cmdExecute :: Resp
cmdExecute = Array 1 [Bulk "EXEC"]
+cmdDiscard :: Resp
+cmdDiscard = Array 1 [Bulk "DISCARD"]
+
expect :: String -> Char8.ByteString -> Resp -> IO ()
expect x y = void . either throwIO return . matchStr x y
diff --git a/src/Database/Redis/IO/Types.hs b/src/Database/Redis/IO/Types.hs
index d06593e..09dff71 100644
--- a/src/Database/Redis/IO/Types.hs
+++ b/src/Database/Redis/IO/Types.hs
@@ -94,12 +94,17 @@ instance Show Timeout where
-- Transaction failure
-- | An exception thrown on transaction failures.
-newtype TransactionFailure = TransactionFailure String
+data TransactionFailure
+ = TransactionAborted -- ^ A @WATCH@ed key changed conccurrently.
+ | TransactionDiscarded -- ^ The transaction was @DISCARD@ed.
+ | TransactionFailure String -- ^ Other transaction failure.
deriving Typeable
instance Exception TransactionFailure
instance Show TransactionFailure where
+ show TransactionAborted = "redis-io: transaction aborted"
+ show TransactionDiscarded = "redis-io: transaction discarded"
show (TransactionFailure e) = "redis-io: transaction failed: " ++ e
ignore :: IO () -> IO ()
diff --git a/test/CommandTests.hs b/test/CommandTests.hs
index 28b1fe8..b741e7f 100644
--- a/test/CommandTests.hs
+++ b/test/CommandTests.hs
@@ -371,8 +371,8 @@ pubSubTest p = do
psubscribe (one "z.*")
wait a
where
- k ch ms = do
- liftIO $ print $ "message: " <> ch <> ": " <> ms
+ k pat ch ms = do
+ liftIO $ print $ "message: " <> maybe "" (<> ": ") pat <> ch <> ": " <> ms
case ms of
"quit" -> unsubscribe [] >> punsubscribe []
"add" -> subscribe (one "x")
diff --git a/test/Test.hs b/test/Test.hs
index 1f983d7..75e6f0a 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -4,16 +4,21 @@
module Main (main) where
+import Control.Applicative
import Control.Exception (finally)
import CommandTests (tests)
import Database.Redis.IO
+import Data.Maybe (fromMaybe)
+import System.Environment
import Test.Tasty
+import Prelude
import qualified System.Logger as Logger
main :: IO ()
main = do
g <- Logger.new Logger.defSettings
- p <- mkPool g defSettings
+ h <- fromMaybe "localhost" <$> lookupEnv "REDIS_HOST"
+ p <- mkPool g (setHost h defSettings)
defaultMain (tests p) `finally` shutdown p `finally` Logger.close g