diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -3,7 +3,7 @@ This library is a fast Haskell client for the [Riak](http://www.basho.com/Riak.html) decentralized key/value data store. -It uses Riak's [protobuf API](http://wiki.basho.com/PBC-API.html) for +It uses Riak's [protobuf API](http://docs.basho.com/riak/latest/dev/references/protocol-buffers/) for optimal performance. This project was originally the work of Bryan O'Sullivan (), and then [Janrain, Inc.](http://janrain.com/), it is now being maintained by Mark Hibberd (). @@ -14,7 +14,7 @@ and other improvements. Please report bugs via the -[github issue tracker](http://github.com/markhibberd/riak-haskell- client/issues). +[github issue tracker](http://github.com/markhibberd/riak-haskell-client/issues). Master [git repository](http://github.com/markhibberd/riak-haskell-client): @@ -26,4 +26,3 @@ # Build [![Build Status](https://travis-ci.org/markhibberd/riak-haskell-client.svg)](https://travis-ci.org/markhibberd/riak-haskell-client) - diff --git a/riak.cabal b/riak.cabal --- a/riak.cabal +++ b/riak.cabal @@ -1,5 +1,5 @@ name: riak -version: 0.7.0.3 +version: 0.7.2.0 synopsis: A Haskell client for the Riak decentralized data store description: A Haskell client library for the Riak decentralized data @@ -86,12 +86,13 @@ blaze-builder, bytestring, containers, + monad-control >= 0.2.0.1, network >= 2.3, - resource-pool >= 0.1.0.2, - protocol-buffers >= 2.0.5, + resource-pool == 0.2.*, + protocol-buffers-fork == 2.0.*, pureMD5, random, - riak-protobuf >= 0.16.0.1, + riak-protobuf == 0.18.*, text >= 0.11.0.6, time @@ -104,6 +105,20 @@ cpp-options: -DASSERTS -DDEBUG ghc-options: -Wall + +test-suite test + type: exitcode-stdio-1.0 + main-is: Properties.hs + hs-source-dirs: tests + ghc-options: -Wall + + build-depends: + riak, + base, + bytestring, + QuickCheck, + test-framework, + test-framework-quickcheck2 source-repository head type: git diff --git a/src/Network/Riak/Connection/Pool.hs b/src/Network/Riak/Connection/Pool.hs --- a/src/Network/Riak/Connection/Pool.hs +++ b/src/Network/Riak/Connection/Pool.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, NamedFieldPuns, RecordWildCards, - ScopedTypeVariables #-} + ScopedTypeVariables, FlexibleContexts #-} -- | -- Module: Network.Riak.Connection.Pool @@ -21,8 +21,10 @@ , maxConnections , numStripes , withConnection + , withConnectionM ) where +import Control.Monad.Trans.Control (MonadBaseControl) import Data.Time.Clock (NominalDiffTime) import Data.Typeable (Typeable) import Network.Riak (Client(clientID), Connection, connect, disconnect) @@ -123,3 +125,27 @@ -- user (who expects the connection to be valid) to throw an exception. withConnection :: Pool -> (Connection -> IO a) -> IO a withConnection = Pool.withResource . pool + +-- | Temporarily take a connection from a 'Pool', perform an action +-- with it, and return it to the pool afterwards. This is a +-- generalization of 'withConnection', which remains specialized to +-- prevent breaking source compatibility with existing code. +-- +-- * If the pool has a connection available, it is used +-- immediately. +-- +-- * Otherwise, if the maximum number of connections has not been +-- reached, a new connection is created and used. +-- +-- * If the maximum number of connections has been reached, this +-- function blocks until a connection becomes available, then that +-- connection is used. +-- +-- If the action throws an exception of any type, the 'Connection' is +-- destroyed, and not returned to the pool. +-- +-- It probably goes without saying that you should never call +-- 'disconnect' on a connection, as doing so will cause a subsequent +-- user (who expects the connection to be valid) to throw an exception. +withConnectionM :: MonadBaseControl IO m => Pool -> (Connection -> m a) -> m a +withConnectionM = Pool.withResource . pool diff --git a/src/Network/Riak/Content.hs b/src/Network/Riak/Content.hs --- a/src/Network/Riak/Content.hs +++ b/src/Network/Riak/Content.hs @@ -47,6 +47,7 @@ , last_mod_usecs = Nothing , usermeta = Seq.empty , indexes = Seq.empty + , deleted = Nothing } -- | Content encoded as @application/octet-stream@. diff --git a/src/Network/Riak/Request.hs b/src/Network/Riak/Request.hs --- a/src/Network/Riak/Request.hs +++ b/src/Network/Riak/Request.hs @@ -88,6 +88,9 @@ , Get.if_modified = Nothing , Get.head = Nothing , Get.deletedvclock = Nothing + , Get.timeout = Nothing + , Get.sloppy_quorum = Nothing + , Get.n_val = Nothing } {-# INLINE get #-} @@ -99,7 +102,7 @@ put bucket key mvclock cont mw mdw returnBody = Put.PutRequest (escape bucket) (Just $ escape key) (fromVClock <$> mvclock) cont (fromQuorum mw) (fromQuorum mdw) (Just returnBody) - Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing {-# INLINE put #-} -- | Create a link. The bucket and key names are URL-escaped. @@ -111,17 +114,17 @@ delete :: Bucket -> Key -> RW -> Del.DeleteRequest delete bucket key rw = Del.DeleteRequest (escape bucket) (escape key) (fromQuorum rw) Nothing Nothing Nothing - Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing {-# INLINE delete #-} -- | Create a list-buckets request. listBuckets :: ListBucketsRequest -listBuckets = ListBucketsRequest +listBuckets = ListBucketsRequest Nothing Nothing {-# INLINE listBuckets #-} -- | Create a list-keys request. The bucket name is URL-escaped. listKeys :: Bucket -> Keys.ListKeysRequest -listKeys = Keys.ListKeysRequest . escape +listKeys b = Keys.ListKeysRequest (escape b) Nothing {-# INLINE listKeys #-} -- | Create a get-bucket request. The bucket name is URL-escaped. diff --git a/src/Network/Riak/Resolvable/Internal.hs b/src/Network/Riak/Resolvable/Internal.hs --- a/src/Network/Riak/Resolvable/Internal.hs +++ b/src/Network/Riak/Resolvable/Internal.hs @@ -131,7 +131,7 @@ case xs of [x] | i > 0 || isJust mvclock -> return (x, vclock) (_:_) -> do debugValues "put" "conflict" xs - go (i+1) (resolveMany' val xs) (Just vclock) + go (i+1) (resolveMany xs) (Just vclock) [] -> unexError "Network.Riak.Resolvable" "put" "received empty response from server" go (0::Int) val0 mvclock0 @@ -189,7 +189,7 @@ mush (i,(k,mv,c)) (cs,v) = case cs of [x] | i > 0 || isJust mv -> Right (i,(x,v)) - (_:_) -> Left (i,(k,Just v, resolveMany' c cs)) + (_:_) -> Left (i,(k,Just v, resolveMany cs)) [] -> unexError "Network.Riak.Resolvable" "put" "received empty response from server" {-# INLINE putMany #-} diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,48 @@ +import Control.Applicative ((<$>)) +import Control.Exception (finally) +import Control.Monad (forM_) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +import Network.Riak.Connection (defaultClient) +import Network.Riak.Connection.Pool (Pool, create, withConnection) +import Network.Riak.Content (binary) +import Network.Riak.Types (Bucket, Key, Quorum(..)) +import System.IO.Unsafe (unsafePerformIO) +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Arbitrary(..), (==>)) +import Test.QuickCheck.Monadic (assert, monadicIO, run) +import qualified Data.ByteString.Lazy as L +import qualified Network.Riak.Basic as B +import qualified Network.Riak.JSON as J +import qualified Network.Riak.Value as V + +instance Arbitrary L.ByteString where + arbitrary = L.pack `fmap` arbitrary + +cruft :: IORef [(Bucket, Key)] +{-# NOINLINE cruft #-} +cruft = unsafePerformIO $ newIORef [] + +pool :: Pool +{-# NOINLINE pool #-} +pool = unsafePerformIO $ + create defaultClient 1 1 1 + +t_put_get b k v = notempty b && notempty k ==> monadicIO $ assert . uncurry (==) =<< run act + where + act = withConnection pool $ \c -> do + modifyIORef cruft ((b,k):) + p <- Just <$> B.put c b k Nothing (binary v) Default Default + r <- B.get c b k Default + return (p,r) + notempty = not . L.null + +main = defaultMain tests `finally` cleanup + where + cleanup = withConnection pool $ \c -> do + bks <- readIORef cruft + forM_ bks $ \(b,k) -> B.delete c b k Default + +tests = [ + testProperty "t_put_get" t_put_get + ]