Commits

Bryan O'Sullivan committed a917225

Implement monoid-oriented putMany.

Comments (0)

Files changed (6)

     Network.Riak.Protocol.ListBucketsRequest
 
   other-modules:       
+    Network.Riak.Monoid
     Network.Riak.Connection.Internal
     Network.Riak.Tag
     Network.Riak.Types.Internal

src/Network/Riak/JSON.hs

 
 import Control.Applicative ((<$>))
 import Control.Arrow (first)
-import Data.Monoid (Monoid)
+import Data.Monoid (Dual(..), First(..), Last(..), Monoid)
 import Data.Typeable (Typeable)
 import Network.Riak.Types.Internal
-import qualified Data.Aeson.Types as Aeson
+import Data.Aeson.Types (FromJSON(..), ToJSON(..))
 import qualified Network.Riak.Value as V
 
 newtype JSON a = J {
       plain :: a
     } deriving (Eq, Ord, Show, Read, Bounded, Typeable, Monoid)
 
-json :: (Aeson.FromJSON a, Aeson.ToJSON a) => a -> JSON a
+json :: (FromJSON a, ToJSON a) => a -> JSON a
 json = J
 {-# INLINE json #-}
 
     fmap f (J a) = J (f a)
     {-# INLINE fmap #-}
 
-instance (Aeson.FromJSON a, Aeson.ToJSON a) => V.IsContent (JSON a) where
-    fromContent c = J `fmap` (V.fromContent c >>= Aeson.fromJSON)
+instance ToJSON a => ToJSON (Dual a) where
+    toJSON = toJSON . getDual
+    {-# INLINE toJSON #-}
+
+instance FromJSON a => FromJSON (Dual a) where
+    fromJSON = fmap Dual . fromJSON
+    {-# INLINE fromJSON #-}
+
+instance ToJSON a => ToJSON (First a) where
+    toJSON = toJSON . getFirst
+    {-# INLINE toJSON #-}
+
+instance FromJSON a => FromJSON (First a) where
+    fromJSON = fmap First . fromJSON
+    {-# INLINE fromJSON #-}
+
+instance ToJSON a => ToJSON (Last a) where
+    toJSON = toJSON . getLast
+    {-# INLINE toJSON #-}
+
+instance FromJSON a => FromJSON (Last a) where
+    fromJSON = fmap Last . fromJSON
+    {-# INLINE fromJSON #-}
+
+instance (FromJSON a, ToJSON a) => V.IsContent (JSON a) where
+    fromContent c = J `fmap` (V.fromContent c >>= fromJSON)
     {-# INLINE fromContent #-}
 
-    toContent (J a) = V.toContent (Aeson.toJSON a)
+    toContent (J a) = V.toContent (toJSON a)
     {-# INLINE toContent #-}
 
-get :: (Aeson.FromJSON c, Aeson.ToJSON c) => Connection -> Bucket -> Key -> R
+get :: (FromJSON c, ToJSON c) => Connection -> Bucket -> Key -> R
     -> IO (Maybe ([c], VClock))
 get conn bucket key r = fmap convert <$> V.get conn bucket key r
 
-getMany :: (Aeson.FromJSON c, Aeson.ToJSON c) => Connection -> Bucket -> [Key] -> R
+getMany :: (FromJSON c, ToJSON c) => Connection -> Bucket -> [Key] -> R
     -> IO [Maybe ([c], VClock)]
 getMany conn bucket ks r = map (fmap convert) <$> V.getMany conn bucket ks r
 
-put :: (Aeson.FromJSON c, Aeson.ToJSON c) =>
+put :: (FromJSON c, ToJSON c) =>
        Connection -> Bucket -> Key -> Maybe VClock -> c
     -> W -> DW -> IO ([c], VClock)
 put conn bucket key mvclock val w dw =
     convert <$> V.put conn bucket key mvclock (json val) w dw
 
-put_ :: (Aeson.FromJSON c, Aeson.ToJSON c) =>
+put_ :: (FromJSON c, ToJSON c) =>
        Connection -> Bucket -> Key -> Maybe VClock -> c
     -> W -> DW -> IO ()
 put_ conn bucket key mvclock val w dw =
     V.put_ conn bucket key mvclock (json val) w dw
 
-putMany :: (Aeson.FromJSON c, Aeson.ToJSON c) =>
+putMany :: (FromJSON c, ToJSON c) =>
        Connection -> Bucket -> [(Key, Maybe VClock, c)]
     -> W -> DW -> IO [([c], VClock)]
 putMany conn bucket puts w dw =
     map convert <$> V.putMany conn bucket (map f puts) w dw
   where f (k,v,c) = (k,v,json c)
 
-putMany_ :: (Aeson.FromJSON c, Aeson.ToJSON c) =>
+putMany_ :: (FromJSON c, ToJSON c) =>
             Connection -> Bucket -> [(Key, Maybe VClock, c)]
          -> W -> DW -> IO ()
 putMany_ conn bucket puts w dw = V.putMany_ conn bucket (map f puts) w dw

src/Network/Riak/JSON/Monoid.hs

-{-# LANGUAGE RecordWildCards #-}
-
 module Network.Riak.JSON.Monoid
     (
       get
     , getMany
     , put
+    , putMany
     ) where
 
-import Control.Arrow (first)
 import Data.Monoid (Monoid(..))
 import Network.Riak.Types.Internal hiding (MessageTag(..))
-import qualified Data.Aeson.Types as Aeson
+import Data.Aeson.Types (FromJSON, ToJSON)
 import qualified Network.Riak.JSON as J
+import qualified Network.Riak.Monoid as M
 
-get :: (Aeson.FromJSON c, Aeson.ToJSON c, Monoid c) =>
+get :: (FromJSON c, ToJSON c, Monoid c) =>
        Connection -> Bucket -> Key -> R -> IO (Maybe (c, VClock))
-get conn bucket key r = fmap (first mconcat) `fmap` J.get conn bucket key r
+get = M.get J.get
 {-# INLINE get #-}
 
-getMany :: (Aeson.FromJSON c, Aeson.ToJSON c, Monoid c)
+getMany :: (FromJSON c, ToJSON c, Monoid c)
            => Connection -> Bucket -> [Key] -> R
         -> IO [Maybe (c, VClock)]
-getMany conn b ks r = map (fmap (first mconcat)) `fmap` J.getMany conn b ks r
+getMany = M.getMany J.getMany
 {-# INLINE getMany #-}
 
-put :: (Aeson.FromJSON c, Aeson.ToJSON c, Monoid c) =>
+put :: (FromJSON c, ToJSON c, Monoid c) =>
        Connection -> Bucket -> Key -> Maybe VClock -> c -> W -> DW
     -> IO (c, VClock)
-put conn bucket key mvclock0 val0 w dw = do
-  let go val mvclock1 = do
-        (xs, vclock) <- J.put conn bucket key mvclock1 val w dw
-        case xs of
-          [c] -> return (c, vclock)
-          _   -> go (mconcat xs) (Just vclock)
-  go val0 mvclock0
+put = M.put J.put
+{-# INLINE put #-}
+
+putMany :: (FromJSON c, ToJSON c, Monoid c) =>
+           Connection -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW
+        -> IO [(c, VClock)]
+putMany = M.putMany J.putMany
+{-# INLINE putMany #-}

src/Network/Riak/Monoid.hs

+module Network.Riak.Monoid
+    (
+      get
+    , getMany
+    , put
+    , putMany
+    ) where
+
+import Control.Arrow (first, second)
+import Data.Function (on)
+import Data.List (partition, sortBy)
+import Data.Monoid (Monoid(..))
+import Network.Riak.Types.Internal hiding (MessageTag(..))
+import qualified Data.IntMap as M
+
+get :: (Monoid c) =>
+       (Connection -> Bucket -> Key -> R -> IO (Maybe ([c], VClock)))
+       -> (Connection -> Bucket -> Key -> R -> IO (Maybe (c, VClock)))
+get doGet conn bucket key r =
+    fmap (first mconcat) `fmap` doGet conn bucket key r
+
+getMany :: (Monoid c) =>
+           (Connection -> Bucket -> [Key] -> R -> IO [Maybe ([c], VClock)])
+        -> Connection -> Bucket -> [Key] -> R -> IO [Maybe (c, VClock)]
+getMany doGet conn b ks r = map (fmap (first mconcat)) `fmap` doGet conn b ks r
+
+put :: Monoid c => (Connection -> Bucket -> Key -> Maybe VClock -> c -> W -> DW
+                               -> IO ([c], VClock))
+    -> Connection -> Bucket -> Key -> Maybe VClock -> c -> W -> DW
+    -> IO (c, VClock)
+put doPut conn bucket key mvclock0 val0 w dw = do
+  let go val mvclock1 = do
+        (xs, vclock) <- doPut conn bucket key mvclock1 val w dw
+        case xs of
+          [c] -> return (c, vclock)
+          _   -> go (mconcat xs) (Just vclock)
+  go val0 mvclock0
+
+putMany :: (Monoid c) =>
+           (Connection -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW
+                       -> IO [([c], VClock)])
+        -> Connection -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW
+        -> IO [(c, 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
+    rs <- doPut conn bucket (map snd puts) w dw
+    let (ok, conflicts) = partition isConflict $ zip (map fst puts) rs
+        isConflict (_,(_:_:_,_)) = True
+        isConflict  _            = False
+    go (map (second (first mconcat)) ok++acc) (map asPut conflicts)
+  asPut (i,(c,v)) = (i,(keys M.! i, Just v, mconcat c))
+  keys = M.fromAscList (zip [(0::Int)..] (map fst3 puts0))
+  fst3 (a,_,_) = a

src/Network/Riak/Types.hs

     -- * Message identification
     , Request
     , Response
+    , Exchange
     , MessageTag(..)
     , Tagged(..)
     ) where

src/Network/Riak/Value/Monoid.hs

-{-# LANGUAGE RecordWildCards #-}
-
 module Network.Riak.Value.Monoid
     (
       V.IsContent(..)
     , get
     , getMany
     , put
+    , putMany
     ) where
 
-import Control.Arrow (first)
 import Data.Monoid (Monoid(..))
 import Network.Riak.Types.Internal hiding (MessageTag(..))
+import qualified Network.Riak.Monoid as M
 import qualified Network.Riak.Value as V
 
 get :: (Monoid c, V.IsContent c) =>
        Connection -> Bucket -> Key -> R -> IO (Maybe (c, VClock))
-get conn bucket key r = fmap (first mconcat) `fmap` V.get conn bucket key r
+get = M.get V.get
 {-# INLINE get #-}
 
 getMany :: (Monoid c, V.IsContent c) => Connection -> Bucket -> [Key] -> R
         -> IO [Maybe (c, VClock)]
-getMany conn b ks r = map (fmap (first mconcat)) `fmap` V.getMany conn b ks r
+getMany = M.getMany V.getMany
 {-# INLINE getMany #-}
 
 put :: (Monoid c, V.IsContent c) =>
        Connection -> Bucket -> Key -> Maybe VClock -> c -> W -> DW
     -> IO (c, VClock)
-put conn bucket key mvclock0 val0 w dw = do
-  let go val mvclock1 = do
-        (xs, vclock) <- V.put conn bucket key mvclock1 val w dw
-        case xs of
-          [c] -> return (c, vclock)
-          _   -> go (mconcat xs) (Just vclock)
-  go val0 mvclock0
+put = M.put V.put 
+{-# INLINE put #-}
+
+putMany :: (Monoid c, V.IsContent c) =>
+           Connection -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW
+        -> IO [(c, VClock)]
+putMany = M.putMany V.putMany
+{-# INLINE putMany #-}