redis-io 0.5.2 → 0.6.0
raw patch · 8 files changed
+88/−57 lines, 8 filesdep ~attoparsecdep ~auto-updatedep ~base
Dependency ranges changed: attoparsec, auto-update, base, bytestring, containers, criterion, exceptions, hedis, iproute, monad-control, mtl, network, operational, redis-resp, resource-pool, semigroups, stm, time, tinylog, transformers, transformers-base
Files
- CHANGELOG.md +6/−0
- README.md +1/−3
- redis-io.cabal +26/−26
- src/Database/Redis/IO/Client.hs +21/−12
- src/Database/Redis/IO/Connection.hs +20/−12
- src/Database/Redis/IO/Types.hs +6/−1
- test/CommandTests.hs +2/−2
- test/Test.hs +6/−1
CHANGELOG.md view
@@ -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
README.md view
@@ -1,9 +1,7 @@ # 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+[1]: https://gitlab.com/twittner/redis-resp
redis-io.cabal view
@@ -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 @@ 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 @@ 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 @@ 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
src/Database/Redis/IO/Client.hs view
@@ -42,6 +42,7 @@ 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 @@ -- | 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 @@ 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 @@ 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 @@ -- 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 #-}
src/Database/Redis/IO/Connection.hs view
@@ -30,7 +30,7 @@ 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 @@ 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 @@ 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 @@ 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@@ -173,6 +178,9 @@ 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
src/Database/Redis/IO/Types.hs view
@@ -94,12 +94,17 @@ -- 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 ()
test/CommandTests.hs view
@@ -371,8 +371,8 @@ 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")
test/Test.hs view
@@ -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