riak 0.3.1.0 → 0.3.2.0

raw patch · 3 files changed

+47/−13 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• riak.cabal +1/−1
• src/Network/Riak/Debug.hs +28/−1
• src/Network/Riak/Resolvable/Internal.hs +18/−11

@@ -1,5 +1,5 @@ name:                riak-version:             0.3.1.0+version:             0.3.2.0 synopsis:            A Haskell client for the Riak decentralized data store description:   A Haskell client library for the Riak decentralized data

@@ -16,12 +16,14 @@     (       level     , debug+    , debugValues     , setHandle     , showM     ) where  import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, withMVar) import Control.Exception hiding (handle)+import Control.Monad (forM_, when) import Network.Riak.Types.Internal import System.Environment (getEnv) import System.IO (Handle, hPutStrLn, stderr)@@ -60,7 +62,10 @@ {-# INLINE setHandle #-} #endif -debug :: String -> String -> IO ()+-- | Print a debug message, if debugging is enabled.+debug :: String                 -- ^ Function name.+      -> String                 -- ^ Debug message.+      -> IO () #ifdef DEBUG debug func str     | level == 0 = return ()@@ -69,6 +74,28 @@ #else debug _ _ = return () {-# INLINE debug #-}+#endif++-- | Print a debug message, and information about some values.  If the+-- debug level is greater than 1, print the values themselves.+debugValues :: (Show a) =>+               String+            -> String+            -> [a]+            -> IO ()+debugValues func str values+#ifdef DEBUG+    | level == 0 = return ()+    | otherwise = +  withMVar handle $ \h -> do+    hPutStrLn h $ str ++ ": " ++ show (length values) +++                  " values [" ++ func ++ "]"+    when (level > 1) .+      forM_ (zip [(0::Int)..] values) $ \(i,v) ->+        hPutStrLn h $ "  [" ++ show i ++ "] " ++ show v+#else+debugValues _ _ _ = return ()+{-# INLINE debugValues #-} #endif  -- | Show a 'Tagged' value.  Show the entire value if the debug level

@@ -30,7 +30,7 @@ import Data.List (foldl', sortBy) import Data.Monoid (Monoid(mappend)) import Data.Typeable (Typeable)-import Network.Riak.Debug (debug)+import Network.Riak.Debug (debugValues) import Network.Riak.Types.Internal hiding (MessageTag(..))  -- | A type that can automatically resolve a vector clock conflict@@ -48,7 +48,7 @@ -- If several conflicting siblings are found, 'resolve' will be -- applied over all of them using a fold, to yield a single -- \"winner\".-class Resolvable a where+class (Eq a, Show a) => Resolvable a where     -- | Resolve a conflict between two values.     resolve :: a -> a -> a @@ -57,7 +57,7 @@ newtype ResolvableMonoid a = RM { unRM :: a }     deriving (Eq, Ord, Read, Show, Typeable, Data, Monoid, FromJSON, ToJSON) -instance (Monoid a) => Resolvable (ResolvableMonoid a) where+instance (Eq a, Show a, Monoid a) => Resolvable (ResolvableMonoid a) where     resolve = mappend     {-# INLINE resolve #-} @@ -72,13 +72,16 @@        -> (Connection -> Bucket -> Key -> R -> IO (Maybe (a, VClock))) get doGet conn bucket key r =     fmap (first resolveMany) `fmap` doGet conn bucket key r+{-# INLINE get #-}  getMany :: (Resolvable a) =>            (Connection -> Bucket -> [Key] -> R -> IO [Maybe ([a], VClock)])         -> Connection -> Bucket -> [Key] -> R -> IO [Maybe (a, VClock)]-getMany doGet conn b ks r = map (fmap (first resolveMany)) `fmap` doGet conn b ks r+getMany doGet conn b ks r =+    map (fmap (first resolveMany)) `fmap` doGet conn b ks r+{-# INLINE getMany #-} -put :: (Eq a, Resolvable a) =>+put :: (Resolvable a) =>        (Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW                    -> IO ([a], VClock))     -> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW@@ -89,11 +92,12 @@         case xs of           []             -> return (val, vclock) -- not observed in the wild           [v] | v == val -> return (val, vclock)-          ys             -> do debug "put" "conflict" +          ys             -> do debugValues "put" "conflict" ys                                go (resolveMany' val ys) (Just vclock)   go val0 mvclock0+{-# INLINE put #-} -put_ :: (Eq a, Resolvable a) =>+put_ :: (Resolvable a) =>         (Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW                     -> IO ([a], VClock))      -> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW@@ -102,7 +106,7 @@     put doPut conn bucket key mvclock0 val0 w dw >> return () {-# INLINE put_ #-} -putMany :: (Eq a, Resolvable a) =>+putMany :: (Resolvable a) =>            (Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW                        -> IO [([a], VClock)])         -> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW@@ -113,15 +117,16 @@     rs <- doPut conn bucket (map snd puts) w dw     let (conflicts, ok) = partitionEithers $ zipWith mush puts rs     unless (null conflicts) $-      debug "putMany" $ show (length conflicts) ++ " conflicts"+      debugValues "putMany" "conflicts" conflicts     go (ok++acc) conflicts   mush (i,(k,_,c)) (cs,v) =       case cs of         []           -> Right (i,(c,v)) -- not observed in the wild         [x] | x == c -> Right (i,(c,v))         _            -> Left (i,(k,Just v, resolveMany' c cs))+{-# INLINE putMany #-} -putMany_ :: (Eq a, Resolvable a) =>+putMany_ :: (Resolvable a) =>             (Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW                         -> IO [([a], VClock)])          -> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW -> IO ()@@ -130,8 +135,10 @@ {-# INLINE putMany_ #-}  resolveMany' :: (Resolvable a) => a -> [a] -> a-resolveMany' a as = foldl' resolve a as+resolveMany' = foldl' resolve+{-# INLINE resolveMany' #-}  resolveMany :: (Resolvable a) => [a] -> a resolveMany (a:as) = resolveMany' a as resolveMany _      = error "resolveMany: empty list"+{-# INLINE resolveMany #-}