Bryan O'Sullivan avatar Bryan O'Sullivan committed 54a2b00

Automated conflict resolution must give up after enough failed attempts.

Got bitten by the NaN /= NaN issue, which left my server beating up Riak
in an infinite loop. Fun!

Comments (0)

Files changed (5)

src/Network/Riak.hs

     , getServerInfo
     -- * Data management
     , Quorum(..)
+    , Resolvable(..)
     , get
     , getMany
     , put
 
 import Network.Riak.Basic hiding (get, put, put_)
 import Network.Riak.JSON.Resolvable (get, getMany, put, putMany)
+import Network.Riak.Resolvable (Resolvable(..))

src/Network/Riak/JSON/Resolvable.hs

 --
 -- This module allows storage and retrieval of JSON-encoded data.
 --
--- Functions automatically resolve conflicts using 'Resolvable' instances.
--- For instance, if a 'get' returns three siblings, a winner will be
--- chosen using 'mconcat'.  If a 'put' results in a conflict, a winner
--- will be chosen using 'mconcat', and the winner will be 'put'; this
--- will be repeated until no conflict occurs.
+-- Functions automatically resolve conflicts using 'Resolvable'
+-- instances.  For instance, if a 'get' returns three siblings, a
+-- winner will be chosen using 'resolve'.  If a 'put' results in a
+-- conflict, a winner will be chosen using 'resolve', and the winner
+-- will be 'put'; this will be repeated until either no conflict
+-- occurs or the process has been repeated too many times.
 
 module Network.Riak.JSON.Resolvable
     (
-      get
+      Resolvable(..)
+    , ResolutionFailure(..)
+    , get
     , getMany
     , put
     , put_
     ) where
 
 import Data.Aeson.Types (FromJSON(..), ToJSON(..))
-import Network.Riak.Resolvable.Internal (Resolvable)
+import Network.Riak.Resolvable.Internal (ResolutionFailure(..), Resolvable(..))
 import Network.Riak.Types.Internal hiding (MessageTag(..))
 import qualified Network.Riak.JSON as J
 import qualified Network.Riak.Resolvable.Internal as R
 
--- | Retrieve a single value.  If conflicting values are returned, the
--- 'Resolvable' is used to choose a winner.
+-- | Retrieve a single value.  If conflicting values are returned,
+-- 'resolve' is used to choose a winner.
 get :: (FromJSON c, ToJSON c, Resolvable c) =>
        Connection -> Bucket -> Key -> R -> IO (Maybe (c, VClock))
 get = R.get J.get
 {-# INLINE get #-}
 
 -- | Retrieve multiple values.  If conflicting values are returned for
--- a key, the 'Resolvable' is used to choose a winner.
+-- a key, 'resolve' is used to choose a winner.
 getMany :: (FromJSON c, ToJSON c, Resolvable c)
            => Connection -> Bucket -> [Key] -> R -> IO [Maybe (c, VClock)]
 getMany = R.getMany J.getMany
 -- conflicts that arise.  A single invocation of this function may
 -- involve several roundtrips to the server to resolve conflicts.
 --
--- If a conflict arises, a winner will be chosen using 'mconcat', and
+-- If a conflict arises, a winner will be chosen using 'resolve', and
 -- the winner will be stored; this will be repeated until no conflict
--- occurs.
+-- occurs or a (fairly large) number of retries has been attempted
+-- without success.
 --
--- The final value to be stored at the end of any conflict resolution
--- is returned.
+-- If this function gives up due to apparently being stuck in a
+-- conflict resolution loop, it will throw a 'ResolutionFailure'
+-- exception.
 put :: (Eq c, FromJSON c, ToJSON c, Resolvable c) =>
        Connection -> Bucket -> Key -> Maybe VClock -> c -> W -> DW
     -> IO (c, VClock)
 -- conflicts that arise.  A single invocation of this function may
 -- involve several roundtrips to the server to resolve conflicts.
 --
--- If a conflict arises, a winner will be chosen using 'mconcat', and
+-- If a conflict arises, a winner will be chosen using 'resolve', and
 -- the winner will be stored; this will be repeated until no conflict
--- occurs.
+-- occurs or a (fairly large) number of retries has been attempted
+-- without success.
+--
+-- If this function gives up due to apparently being stuck in a
+-- conflict resolution loop, it will throw a 'ResolutionFailure'
+-- exception.
 put_ :: (Eq c, FromJSON c, ToJSON c, Resolvable c) =>
         Connection -> Bucket -> Key -> Maybe VClock -> c -> W -> DW
      -> IO ()
 -- roundtrips to the server to resolve conflicts.
 --
 -- If any conflicts arise, a winner will be chosen in each case using
--- 'mconcat', and the winners will be stored; this will be repeated
--- until no conflicts occur.
+-- 'resolve', and the winners will be stored; this will be repeated
+-- until either no conflicts occur or a (fairly large) number of
+-- retries has been attempted without success.
 --
 -- For each original value to be stored, the final value that was
 -- stored at the end of any conflict resolution is returned.
+--
+-- If this function gives up due to apparently being stuck in a loop,
+-- it will throw a 'ResolutionFailure' exception.
 putMany :: (Eq c, FromJSON c, ToJSON c, Resolvable c) =>
            Connection -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW
         -> IO [(c, VClock)]
 -- roundtrips to the server to resolve conflicts.
 --
 -- If any conflicts arise, a winner will be chosen in each case using
--- 'mconcat', and the winners will be stored; this will be repeated
--- until no conflicts occur.
+-- 'resolve', and the winners will be stored; this will be repeated
+-- until either no conflicts occur or a (fairly large) number of
+-- retries has been attempted without success.
+--
+-- If this function gives up due to apparently being stuck in a loop,
+-- it will throw a 'ResolutionFailure' exception.
 putMany_ :: (Eq c, FromJSON c, ToJSON c, Resolvable c) =>
             Connection -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW
          -> IO ()

src/Network/Riak/Resolvable.hs

     (
       Resolvable(..)
     , ResolvableMonoid(..)
+    , ResolutionFailure(..)
     ) where
 
-import Network.Riak.Resolvable.Internal (Resolvable(..), ResolvableMonoid(..))
+import Network.Riak.Resolvable.Internal
+    (ResolutionFailure(..), Resolvable(..), ResolvableMonoid(..))

src/Network/Riak/Resolvable/Internal.hs

-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE BangPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 -- |
 -- Module:      Network.Riak.Resolvable.Internal
 -- Copyright:   (c) 2011 MailRank, Inc.
 -- Portability: portable
 --
 -- Storage and retrieval of data with automatic conflict resolution.
+--
+-- The 'put' and 'putMany' functions will attempt to perform automatic
+-- conflict resolution a large number of times.  If they give up due
+-- to apparently being stuck in a loop, they will throw a
+-- 'ResolutionFailure' exception.
 
 module Network.Riak.Resolvable.Internal
     (
       Resolvable(..)
     , ResolvableMonoid(..)
+    , ResolutionFailure(..)
     , get
     , getMany
     , put
     ) where
 
 import Control.Arrow (first)
+import Control.Exception (Exception, throwIO)
 import Control.Monad (unless)
 import Data.Aeson.Types (FromJSON, ToJSON)
 import Data.Data (Data)
 import Network.Riak.Debug (debugValues)
 import Network.Riak.Types.Internal hiding (MessageTag(..))
 
+-- | Automated conflict resolution failed.
+data ResolutionFailure = RetriesExceeded
+    -- ^ Too many attempts were made to resolve a conflict, with each
+    -- attempt resulting in another conflict.
+    --
+    -- The number of retries to attempt is high (64). This makes it
+    -- extremely unlikely that this exception will be thrown during
+    -- normal application operation.  Instead, this exception is most
+    -- likely to arise as a result of a bug in your application code.
+    --
+    -- For example, this exception may be thrown if your 'Eq' instance
+    -- is faulty, such that '==' gives false negatives.  This can
+    -- easily occur if you are storing a structure containing 'Double'
+    -- values where some are @NaN@ (the value used to represent the
+    -- expression @0/0@), because two @NaN@ values are /not/
+    -- considered equal in Haskell.
+                         deriving (Eq, Show, Typeable)
+
+instance Exception ResolutionFailure
+
 -- | A type that can automatically resolve a vector clock conflict
 -- between two or more versions of a value.
 --
     -> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
     -> IO (a, VClock)
 put doPut conn bucket key mvclock0 val0 w dw = do
-  let go val mvclock1 = do
+  let go !i val mvclock1
+         | i == maxRetries = throwIO RetriesExceeded
+         | otherwise       = do
         (xs, vclock) <- doPut conn bucket key mvclock1 val w dw
         case xs of
           []             -> return (val, vclock) -- not observed in the wild
           [v] | v == val -> return (val, vclock)
           ys             -> do debugValues "put" "conflict" ys
-                               go (resolveMany' val ys) (Just vclock)
-  go val0 mvclock0
+                               go (i+1) (resolveMany' val ys) (Just vclock)
+  go (0::Int) val0 mvclock0
 {-# INLINE put #-}
 
+-- | The maximum number of times to retry conflict resolution.
+maxRetries :: Int
+maxRetries = 64
+{-# INLINE maxRetries #-}
+
 put_ :: (Resolvable a) =>
         (Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
                     -> IO ([a], VClock))
                        -> IO [([a], VClock)])
         -> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW
         -> IO [(a, VClock)]
-putMany doPut conn bucket puts0 w dw = go [] . zip [(0::Int)..] $ puts0 where
-  go acc [] = return . map snd . sortBy (compare `on` fst) $ acc
-  go acc puts = do
+putMany doPut conn bucket puts0 w dw = go (0::Int) [] . zip [(0::Int)..] $ puts0
+ where
+  go _ acc [] = return . map snd . sortBy (compare `on` fst) $ acc
+  go !i acc puts
+      | i == maxRetries = throwIO RetriesExceeded
+      | otherwise = do
     rs <- doPut conn bucket (map snd puts) w dw
     let (conflicts, ok) = partitionEithers $ zipWith mush puts rs
     unless (null conflicts) $
       debugValues "putMany" "conflicts" conflicts
-    go (ok++acc) conflicts
+    go (i+1) (ok++acc) conflicts
   mush (i,(k,_,c)) (cs,v) =
       case cs of
         []           -> Right (i,(c,v)) -- not observed in the wild

src/Network/Riak/Value/Resolvable.hs

 -- 'V.IsContent' typeclass.  This provides access to more of Riak's
 -- storage features than JSON, e.g. links.
 --
--- Functions automatically resolve conflicts using 'Resolvable' instances.
--- For instance, if a 'get' returns three siblings, a winner will be
--- chosen using 'mconcat'.  If a 'put' results in a conflict, a winner
--- will be chosen using 'mconcat', and the winner will be 'put'; this
--- will be repeated until no conflict occurs.
+-- Functions automatically resolve conflicts using 'Resolvable'
+-- instances.  For instance, if a 'get' returns three siblings, a
+-- winner will be chosen using 'resolve'.  If a 'put' results in a
+-- conflict, a winner will be chosen using 'resolve', and the winner
+-- will be 'put'; this will be repeated until either no conflict
+-- occurs or the process has been repeated too many times.
 
 module Network.Riak.Value.Resolvable
     (
       V.IsContent(..)
+    , Resolvable(..)
+    , ResolutionFailure(..)
     , get
     , getMany
     , put
     , putMany_
     ) where
 
-import Network.Riak.Resolvable.Internal (Resolvable)
+import Network.Riak.Resolvable.Internal (ResolutionFailure(..), Resolvable(..))
 import Network.Riak.Types.Internal hiding (MessageTag(..))
 import qualified Network.Riak.Resolvable.Internal as R
 import qualified Network.Riak.Value as V
 -- conflicts that arise.  A single invocation of this function may
 -- involve several roundtrips to the server to resolve conflicts.
 --
--- If a conflict arises, a winner will be chosen using 'mconcat', and
+-- If a conflict arises, a winner will be chosen using 'resolve', and
 -- the winner will be stored; this will be repeated until no conflict
--- occurs.
+-- occurs or a (fairly large) number of retries has been attempted
+-- without success.
 --
--- The final value to be stored at the end of any conflict resolution
--- is returned.
+-- If this function gives up due to apparently being stuck in a
+-- conflict resolution loop, it will throw a 'ResolutionFailure'
+-- exception.
 put :: (Eq a, Resolvable a, V.IsContent a) =>
        Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
     -> IO (a, VClock)
 -- conflicts that arise.  A single invocation of this function may
 -- involve several roundtrips to the server to resolve conflicts.
 --
--- If a conflict arises, a winner will be chosen using 'mconcat', and
+-- If a conflict arises, a winner will be chosen using 'resolve', and
 -- the winner will be stored; this will be repeated until no conflict
--- occurs.
+-- occurs or a (fairly large) number of retries has been attempted
+-- without success.
+--
+-- If this function gives up due to apparently being stuck in a
+-- conflict resolution loop, it will throw a 'ResolutionFailure'
+-- exception.
 put_ :: (Eq a, Resolvable a, V.IsContent a) =>
         Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
      -> IO ()
 -- roundtrips to the server to resolve conflicts.
 --
 -- If any conflicts arise, a winner will be chosen in each case using
--- 'mconcat', and the winners will be stored; this will be repeated
--- until no conflicts occur.
+-- 'resolve', and the winners will be stored; this will be repeated
+-- until either no conflicts occur or a (fairly large) number of
+-- retries has been attempted without success.
 --
 -- For each original value to be stored, the final value that was
 -- stored at the end of any conflict resolution is returned.
+--
+-- If this function gives up due to apparently being stuck in a loop,
+-- it will throw a 'ResolutionFailure' exception.
 putMany :: (Eq a, Resolvable a, V.IsContent a) =>
            Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW
         -> IO [(a, VClock)]
 -- roundtrips to the server to resolve conflicts.
 --
 -- If any conflicts arise, a winner will be chosen in each case using
--- 'mconcat', and the winners will be stored; this will be repeated
--- until no conflicts occur.
+-- 'resolve', and the winners will be stored; this will be repeated
+-- until either no conflicts occur or a (fairly large) number of
+-- retries has been attempted without success.
+--
+-- If this function gives up due to apparently being stuck in a loop,
+-- it will throw a 'ResolutionFailure' exception.
 putMany_ :: (Eq a, Resolvable a, V.IsContent a) =>
             Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW -> IO ()
 putMany_ = R.putMany_ V.putMany
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.