Commits

Bryan O'Sullivan committed c099150

Add modify and modify_ functions.

Comments (0)

Files changed (4)

src/Network/Riak.hs

     , Resolvable(..)
     , get
     , getMany
+    , modify
+    , modify_
+    , delete
+    -- ** Low-level modification functions
     , put
     , putMany
-    , delete
     -- * Metadata
     , listBuckets
     , foldKeys
     ) where
 
 import Network.Riak.Basic hiding (get, put, put_)
-import Network.Riak.JSON.Resolvable (get, getMany, put, putMany)
+import Network.Riak.JSON.Resolvable (get, getMany, modify, modify_, put, putMany)
 import Network.Riak.Resolvable (Resolvable(..))

src/Network/Riak/JSON/Resolvable.hs

     , ResolutionFailure(..)
     , get
     , getMany
+    , modify
+    , modify_
+    -- * Low-level modification functions
     , put
     , put_
     , putMany
 getMany = R.getMany J.getMany
 {-# INLINE getMany #-}
 
+-- | Modify a single value.  The value, if any, is retrieved using
+-- 'get'; conflict resolution is performed if necessary.  The
+-- modification function is called on the resulting value, and its
+-- result is stored using 'put', which may again perform conflict
+-- resolution.
+--
+-- The result of this function is whatever was returned by 'put',
+-- along with the auxiliary value returned by the modification
+-- function.
+--
+-- If the 'put' phase of this function gives up due to apparently
+-- being stuck in a conflict resolution loop, it will throw a
+-- 'ResolutionFailure' exception.
+modify :: (FromJSON a, ToJSON a, Resolvable a) =>
+          Connection -> Bucket -> Key -> R -> W -> DW
+       -> (Maybe a -> IO (a,b))
+       -- ^ Modification function.  Called with 'Just' the value if
+       -- the key is present, 'Nothing' otherwise.
+       -> IO (a,b)
+modify = R.modify J.get J.put
+{-# INLINE modify #-}
+
+-- | Modify a single value.  The value, if any, is retrieved using
+-- 'get'; conflict resolution is performed if necessary.  The
+-- modification function is called on the resulting value, and its
+-- result is stored using 'put', which may again perform conflict
+-- resolution.
+--
+-- The result of this function is whatever was returned by 'put'.
+--
+-- If the 'put' phase of this function gives up due to apparently
+-- being stuck in a conflict resolution loop, it will throw a
+-- 'ResolutionFailure' exception.
+modify_ :: (FromJSON a, ToJSON a, Resolvable a) =>
+           Connection -> Bucket -> Key -> R -> W -> DW
+        -> (Maybe a -> IO a) -> IO a
+modify_ = R.modify_ J.get J.put
+{-# INLINE modify_ #-}
+
 -- | Store a single value, automatically resolving any vector clock
 -- conflicts that arise.  A single invocation of this function may
 -- involve several roundtrips to the server to resolve conflicts.

src/Network/Riak/Resolvable/Internal.hs

     , ResolutionFailure(..)
     , get
     , getMany
+    , modify
+    , modify_
     , put
     , put_
     , putMany
     , putMany_
     ) where
 
+import Control.Applicative ((<$>))
 import Control.Arrow (first)
 import Control.Exception (Exception, throwIO)
 import Control.Monad (unless)
 import Data.Either (partitionEithers)
 import Data.Function (on)
 import Data.List (foldl', sortBy)
+import Data.Maybe (isJust)
 import Data.Monoid (Monoid(mappend))
 import Data.Typeable (Typeable)
 import Network.Riak.Debug (debugValues)
     resolve _          b        = b
     {-# INLINE resolve #-}
 
-get :: (Resolvable a) =>
-       (Connection -> Bucket -> Key -> R -> IO (Maybe ([a], VClock)))
-       -> (Connection -> Bucket -> Key -> R -> IO (Maybe (a, VClock)))
+type Get a = Connection -> Bucket -> Key -> R -> IO (Maybe ([a], VClock))
+
+get :: (Resolvable a) => Get a
+    -> (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 #-}
     map (fmap (first resolveMany)) `fmap` doGet conn b ks r
 {-# INLINE getMany #-}
 
-put :: (Resolvable a) =>
-       (Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
-                   -> IO ([a], VClock))
+-- If Riak receives a put request with no vclock, and the given
+-- bucket+key already exists, it will treat the missing vclock as
+-- stale, ignore the put request, and send back whatever values it
+-- currently knows about.  The same problem will arise if we send a
+-- vclock that really is stale, but that's much less likely to occur.
+-- We handle the missing-vclock case in the single-body-response case
+-- of both put and putMany below, but we do not (can not?) handle the
+-- stale-vclock case.
+
+type Put a = Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
+           -> IO ([a], VClock)
+
+put :: (Resolvable a) => Put a
     -> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
     -> IO (a, VClock)
 put doPut conn bucket key mvclock0 val0 w dw = do
-  let go !i val mvclock1
+  let go !i val mvclock
          | i == maxRetries = throwIO RetriesExceeded
          | otherwise       = do
-        (xs, vclock) <- doPut conn bucket key mvclock1 val w dw
+        (xs, vclock) <- doPut conn bucket key mvclock val w dw
         case xs of
-          [_]   -> return (val, vclock)
+          [x] | i > 0 || isJust mvclock -> return (x, vclock)
           (_:_) -> do debugValues "put" "conflict" xs
                       go (i+1) (resolveMany' val xs) (Just vclock)
           []    -> unexError "Network.Riak.Resolvable" "put"
     put doPut conn bucket key mvclock0 val0 w dw >> return ()
 {-# INLINE put_ #-}
 
+modify :: (Resolvable a) => Get a -> Put a
+       -> Connection -> Bucket -> Key -> R -> W -> DW -> (Maybe a -> IO (a,b))
+       -> IO (a,b)
+modify doGet doPut conn bucket key r w dw act = do
+  a0 <- get doGet conn bucket key r
+  (a,b) <- act (fst <$> a0)
+  (a',_) <- put doPut conn bucket key (snd <$> a0) a w dw
+  return (a',b)
+{-# INLINE modify #-}
+
+modify_ :: (Resolvable a) => Get a -> Put a
+        -> Connection -> Bucket -> Key -> R -> W -> DW -> (Maybe a -> IO a)
+        -> IO a
+modify_ doGet doPut conn bucket key r w dw act = do
+  a0 <- get doGet conn bucket key r
+  a <- act (fst <$> a0)
+  fst <$> put doPut conn bucket key (snd <$> a0) a w dw
+{-# INLINE modify_ #-}
+
 putMany :: (Resolvable a) =>
            (Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW
                        -> IO [([a], VClock)])
     unless (null conflicts) $
       debugValues "putMany" "conflicts" conflicts
     go (i+1) (ok++acc) conflicts
-  mush (i,(k,_,c)) (cs,v) =
+  mush (i,(k,mv,c)) (cs,v) =
       case cs of
-        [_]   -> Right (i,(c,v))
+        [x] | i > 0 || isJust mv -> Right (i,(x,v))
         (_:_) -> Left (i,(k,Just v, resolveMany' c cs))
         []    -> unexError "Network.Riak.Resolvable" "put"
                  "received empty response from server"

src/Network/Riak/Value/Resolvable.hs

     , ResolutionFailure(..)
     , get
     , getMany
+    , modify
+    , modify_
+    -- * Low-level modification functions
     , put
     , put_
     , putMany
 getMany = R.getMany V.getMany
 {-# INLINE getMany #-}
 
+-- | Modify a single value.  The value, if any, is retrieved using
+-- 'get'; conflict resolution is performed if necessary.  The
+-- modification function is called on the resulting value, and its
+-- result is stored using 'put', which may again perform conflict
+-- resolution.
+--
+-- The result of this function is whatever was returned by 'put',
+-- along with the auxiliary value returned by the modification
+-- function.
+--
+-- If the 'put' phase of this function gives up due to apparently
+-- being stuck in a conflict resolution loop, it will throw a
+-- 'ResolutionFailure' exception.
+modify :: (Resolvable a, V.IsContent a) =>
+          Connection -> Bucket -> Key -> R -> W -> DW
+       -> (Maybe a -> IO (a,b))
+       -- ^ Modification function.  Called with 'Just' the value if
+       -- the key is present, 'Nothing' otherwise.
+       -> IO (a,b)
+modify = R.modify V.get V.put
+{-# INLINE modify #-}
+
+-- | Modify a single value.  The value, if any, is retrieved using
+-- 'get'; conflict resolution is performed if necessary.  The
+-- modification function is called on the resulting value, and its
+-- result is stored using 'put', which may again perform conflict
+-- resolution.
+--
+-- The result of this function is whatever was returned by 'put'.
+--
+-- If the 'put' phase of this function gives up due to apparently
+-- being stuck in a conflict resolution loop, it will throw a
+-- 'ResolutionFailure' exception.
+modify_ :: (Resolvable a, V.IsContent a) =>
+           Connection -> Bucket -> Key -> R -> W -> DW
+        -> (Maybe a -> IO a) -> IO a
+modify_ = R.modify_ V.get V.put
+{-# INLINE modify_ #-}
+
 -- | Store a single value, automatically resolving any vector clock
 -- conflicts that arise.  A single invocation of this function may
 -- involve several roundtrips to the server to resolve conflicts.