diff --git a/riak.cabal b/riak.cabal --- a/riak.cabal +++ b/riak.cabal @@ -1,5 +1,5 @@ name: riak -version: 0.9.0.0 +version: 0.9.1.0 synopsis: A Haskell client for the Riak decentralized data store description: A Haskell client library for the Riak decentralized data @@ -32,7 +32,7 @@ license: OtherLicense license-file: LICENSE author: Bryan O'Sullivan -maintainer: Mark Hibberd , Nathan Hunter +maintainer: Mark Hibberd , Nathan Hunter , Tim McGilchrist copyright: Copyright 2011 MailRank, Inc. Portions copyright 2007-2010 Basho Technologies, Inc. category: Network @@ -65,6 +65,7 @@ exposed-modules: Network.Riak Network.Riak.Basic + Network.Riak.Cluster Network.Riak.Connection Network.Riak.Connection.Pool Network.Riak.Content @@ -88,23 +89,28 @@ Network.Riak.Types.Internal build-depends: - aeson >= 0.8 && < 0.10, + aeson >= 0.8 && < 0.11, attoparsec >= 0.12.1.6 && < 0.14, base >= 3 && <5, binary, blaze-builder >= 0.3 && <= 0.5, bytestring, containers, + enclosed-exceptions >= 1.0.1.1 && <= 1.1, + exceptions >= 0.8.0.2 && <= 0.9, transformers >= 0.3 && < 0.5, - monad-control , + mersenne-random-pure64 >= 0.2.0.4 && < 0.3, + monad-control >= 1.0.0.4 && < 1.1, network >= 2.3, resource-pool == 0.2.*, - protocol-buffers >= 2.1.4 && < 2.2, + protocol-buffers >= 2.1.4 && < 2.2, pureMD5, random, + random-shuffle >= 0.0.4 && < 0.1, riak-protobuf == 0.20.*, text == 1.2.*, - time + time >= 1.4.2 && < 1.6, + vector >= 0.10.12.3 && < 0.11 if flag(debug) cpp-options: -DASSERTS -DDEBUG @@ -118,13 +124,16 @@ test-suite test type: exitcode-stdio-1.0 - main-is: Properties.hs + main-is: Test.hs hs-source-dirs: tests ghc-options: -Wall if flag(test2i) cpp-options: -DTEST2I + other-modules: + Properties + build-depends: base, riak, @@ -132,7 +141,7 @@ containers, HUnit, QuickCheck, - test-framework, - test-framework-hunit, - test-framework-quickcheck2, + tasty, + tasty-hunit, + tasty-quickcheck, text diff --git a/src/Network/Riak/Basic.hs b/src/Network/Riak/Basic.hs --- a/src/Network/Riak/Basic.hs +++ b/src/Network/Riak/Basic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards, CPP #-} -- | -- Module: Network.Riak.Basic @@ -43,7 +43,9 @@ , mapReduce ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) +#endif import Control.Monad.IO.Class import Data.Maybe (fromMaybe) import Network.Riak.Connection.Internal diff --git a/src/Network/Riak/Cluster.hs b/src/Network/Riak/Cluster.hs new file mode 100644 --- /dev/null +++ b/src/Network/Riak/Cluster.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Network.Riak.Cluster + ( Cluster(..) + , InClusterError(..) + , connectToCluster + , inCluster + , Riak.create + , Riak.defaultClient + ) where + +import Control.Exception +import Control.Exception.Enclosed +import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Typeable +import Data.Vector (Vector) +import qualified Data.Vector as V +import Network.Riak (Connection) +import qualified Network.Riak as Riak +import qualified Network.Riak.Connection.Pool as Riak +import System.Random.Mersenne.Pure64 +import System.Random.Shuffle (shuffle') + +-- | Datatype holding connection-pool with all known cluster nodes +data Cluster = Cluster + { clusterPools :: Vector Riak.Pool + -- ^ Vector of connection pools to riak cluster nodes + , clusterGen :: PureMT + } + deriving (Show) + +-- | Error that gets thrown whenever operation couldn't succeed with +-- any node. +data InClusterError = InClusterError [SomeException] + deriving (Show, Typeable) +instance Exception InClusterError + +-- | Function to connect to riak cluster with sane pool defaults +connectToCluster :: [Riak.Client] -> IO Cluster +connectToCluster clients = do + pools <- mapM (\c -> Riak.create c 1 10 20) clients + connectToClusterWithPools pools + +-- | Function to connect to riak cluster with pre-created list of +-- 'Riak.Pool' objects +connectToClusterWithPools :: [Riak.Pool] -> IO Cluster +connectToClusterWithPools pools = do + mt <- newPureMT + return (Cluster (V.fromList pools) mt) + +-- | Tries to run some operation for a random riak node. If it fails, +-- tries all other nodes. If all other nodes fail - throws +-- 'InClusterError' exception. +inCluster :: (MonadThrow m, MonadBaseControl IO m) + => Cluster -> (Connection -> m a) -> m a +inCluster rc f = do + let pools = shuffle' (V.toList (clusterPools rc)) + (V.length (clusterPools rc)) + (clusterGen rc) + go pools [] + where + go [] errors = throwM (InClusterError errors) + go (p:ps) es = Riak.withConnectionM p $ \c -> do + er <- tryAny (f c) + either (\err -> go ps (err:es)) + return er diff --git a/src/Network/Riak/Escape.hs b/src/Network/Riak/Escape.hs --- a/src/Network/Riak/Escape.hs +++ b/src/Network/Riak/Escape.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings, CPP #-} -- | -- Module: Network.Riak.Connection @@ -24,12 +24,16 @@ import Blaze.ByteString.Builder (Builder, fromByteString, toByteString, toLazyByteString) import Blaze.ByteString.Builder.Word (fromWord8) +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) +#endif import Data.Attoparsec.ByteString as A import Data.Attoparsec.Lazy as AL import Data.Bits ((.|.), (.&.), shiftL, shiftR) import Data.ByteString (ByteString) +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend, mempty) +#endif import Data.Text (Text) import Data.Word (Word8) import Network.Riak.Functions (mapEither) diff --git a/src/Network/Riak/JSON.hs b/src/Network/Riak/JSON.hs --- a/src/Network/Riak/JSON.hs +++ b/src/Network/Riak/JSON.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP #-} -- | -- Module: Network.Riak.JSON @@ -26,10 +26,14 @@ , putMany_ ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) +#endif import Control.Arrow (first) import Data.Aeson.Types (FromJSON(..), ToJSON(..)) +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid) +#endif import Data.Typeable (Typeable) import Network.Riak.Types.Internal import qualified Network.Riak.Value as V 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, CPP #-} -- | -- Module: Network.Riak.Request @@ -46,7 +46,9 @@ , mapReduce ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) +#endif import qualified Data.ByteString.Char8 as B8 import Data.Monoid import Network.Riak.Protocol.BucketProps hiding (r,rw) 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP #-} -- | -- Module: Network.Riak.Resolvable.Internal -- Copyright: (c) 2011 MailRank, Inc. @@ -29,7 +29,9 @@ , putMany_ ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) +#endif import Control.Arrow (first) import Control.Exception (Exception, throwIO) import Control.Monad (unless) @@ -40,7 +42,9 @@ import Data.Function (on) import Data.List (foldl', sortBy) import Data.Maybe (isJust) +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(mappend)) +#endif import Data.Typeable (Typeable) import Network.Riak.Debug (debugValues) import Network.Riak.Types.Internal hiding (MessageTag(..)) diff --git a/src/Network/Riak/Response.hs b/src/Network/Riak/Response.hs --- a/src/Network/Riak/Response.hs +++ b/src/Network/Riak/Response.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, CPP #-} -- | -- Module: Network.Riak.Request @@ -26,7 +26,9 @@ , unescapeLinks ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) +#endif import Data.Maybe (fromMaybe) import Network.Riak.Escape (unescape) import Network.Riak.Protocol.BucketProps diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,31 +1,25 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} -import Control.Applicative ((<$>)) -import Control.Exception (finally) -import Control.Monad (forM_) -import Data.IORef (IORef, modifyIORef, newIORef, readIORef) -import Data.Text (Text) -import Network.Riak (getByIndex) -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(..), IndexValue(..), - IndexQuery(..)) -import Network.Riak.Resolvable (ResolvableMonoid(..)) -import System.IO.Unsafe (unsafePerformIO) -import qualified Test.HUnit as HU -import Test.Framework (defaultMain, Test) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary(..), (==>)) -import Test.QuickCheck.Property (Property) -import Test.QuickCheck.Monadic (assert, monadicIO, run) -import qualified Data.Map as M -import qualified Data.ByteString.Lazy as L -import qualified Network.Riak.Basic as B -import qualified Network.Riak.JSON as J +module Properties where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import qualified Data.ByteString.Lazy as L +import Data.IORef (IORef, modifyIORef, newIORef) +import qualified Network.Riak.Basic as B +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.QuickCheck.Monadic (assert, monadicIO, run) +import Test.Tasty +import Test.Tasty.QuickCheck + instance Arbitrary L.ByteString where arbitrary = L.pack `fmap` arbitrary @@ -49,27 +43,5 @@ return (p,r) notempty = not . L.null -t_indexed_put_get :: HU.Assertion -t_indexed_put_get = withConnection pool $ \c -> do - let b = "riak-haskell-client-test" - k = "test" - _ <- J.putIndexed c b k [(IndexInt "someindex" 135)] Nothing - (RM (M.fromList [("somekey", "someval")] :: M.Map Text Text)) - Default Default - keys <- getByIndex c b (IndexQueryExactInt "someindex" 135) - HU.assertEqual "" ["test"] keys - -main :: IO () -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 :: [Test] -tests = - [ testProperty "t_put_get" t_put_get -#ifdef TEST2I - , testCase "t_indexed_put_get" t_indexed_put_get -#endif - ] +tests :: [TestTree] +tests = [ testProperty "t_put_get" t_put_get ] diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Exception (finally) +import Control.Monad (forM_) +import Data.IORef +import qualified Data.Map as M +import Data.Text (Text) +import qualified Network.Riak as Riak +import qualified Network.Riak.Basic as B +import qualified Network.Riak.Cluster as Riak +import Network.Riak.Connection.Pool (withConnection) +import qualified Network.Riak.JSON as J +import Network.Riak.Resolvable (ResolvableMonoid (..)) +import Network.Riak.Types +import qualified Properties +import Test.Tasty +import Test.Tasty.HUnit + +main :: IO () +main = defaultMain tests `finally` cleanup + where + cleanup = withConnection Properties.pool $ \c -> do + bks <- readIORef Properties.cruft + forM_ bks $ \(b,k) -> B.delete c b k Default + +tests :: TestTree +tests = testGroup "Tests" [properties, integrationalTests] + +properties :: TestTree +properties = testGroup "Properties" Properties.tests + +integrationalTests :: TestTree +integrationalTests = testGroup "Integrational tests" + [ testClusterSimple +#ifdef TEST2I + , testIndexedPutGet +#endif + ] + +testClusterSimple :: TestTree +testClusterSimple = testCase "testClusterSimple" $ do + rc <- Riak.connectToCluster [Riak.defaultClient] + Riak.inCluster rc B.ping + + +testIndexedPutGet :: TestTree +testIndexedPutGet = testCase "testIndexedPutGet" $ do + rc <- Riak.connectToCluster [Riak.defaultClient] + let b = "riak-haskell-client-test" + k = "test" + keys <- Riak.inCluster rc $ \c -> do + _ <- J.putIndexed c b k [(IndexInt "someindex" 135)] Nothing + (RM (M.fromList [("somekey", "someval")] :: M.Map Text Text)) + Default Default + Riak.getByIndex c b (IndexQueryExactInt "someindex" 135) + assertEqual "" ["test"] keys