riak 1.0.1.0 → 1.0.1.1

raw patch · 11 files changed

+233/−160 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.markdown +1/−1
• riak.cabal +1/−1
• src/Network/Riak/Basic.hs +18/−18
• src/Network/Riak/JSON.hs +33/−31
• src/Network/Riak/JSON/Resolvable.hs +13/−13
• src/Network/Riak/Request.hs +40/−12
• src/Network/Riak/Resolvable/Internal.hs +38/−33
• src/Network/Riak/Value.hs +38/−33
• src/Network/Riak/Value/Resolvable.hs +12/−8
• tests/Properties.hs +7/−7
• tests/Test.hs +32/−3

@@ -6,7 +6,7 @@ It uses Riak's [protobuf API](http://docs.basho.com/riak/latest/dev/references/protocol-buffers/) for optimal performance. -This project was originally the work of Bryan O'Sullivan (<bos@serpentine.com>), and then [Janrain, Inc.](http://janrain.com/), it is now being maintained by Mark Hibberd (<mark@hibberd.id.au>).+This project was originally the work of Bryan O'Sullivan (<bos@serpentine.com>), and then [Janrain, Inc.](http://janrain.com/), it is now being maintained by Mark Hibberd (<mark@hibberd.id.au>) and Tim McGilchrist (<timmcgil@gmail.com>).  # Join in! 

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

@@ -77,48 +77,48 @@  -- | Retrieve a value.  This may return multiple conflicting siblings. -- Choosing among them is your responsibility.-get :: Connection -> T.Bucket -> T.Key -> R+get :: Connection -> Maybe T.BucketType -> T.Bucket -> T.Key -> R     -> IO (Maybe (Seq.Seq Content, VClock))-get conn bucket key r = Resp.get <$> exchangeMaybe conn (Req.get bucket key r)+get conn btype bucket key r = Resp.get <$> exchangeMaybe conn (Req.get btype bucket key r)  -- | Store a single value.  This may return multiple conflicting -- siblings.  Choosing among them, and storing a new value, is your -- responsibility. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored.-put :: Connection -> T.Bucket -> T.Key -> Maybe T.VClock+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored.+put :: Connection -> Maybe T.BucketType -> T.Bucket -> T.Key -> Maybe T.VClock     -> Content -> W -> DW     -> IO (Seq.Seq Content, VClock)-put conn bucket key mvclock cont w dw =-  Resp.put <$> exchange conn (Req.put bucket key mvclock cont w dw True)+put conn btype bucket key mvclock cont w dw =+  Resp.put <$> exchange conn (Req.put btype bucket key mvclock cont w dw True)  -- | Store a single value, without the possibility of conflict -- resolution. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored, and you will not be notified.-put_ :: Connection -> T.Bucket -> T.Key -> Maybe T.VClock+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored, and you will not be notified.+put_ :: Connection -> Maybe T.BucketType -> T.Bucket -> T.Key -> Maybe T.VClock      -> Content -> W -> DW      -> IO ()-put_ conn bucket key mvclock cont w dw =-  exchange_ conn (Req.put bucket key mvclock cont w dw False)+put_ conn btype bucket key mvclock cont w dw =+  exchange_ conn (Req.put btype bucket key mvclock cont w dw False)  -- | Delete a value.-delete :: Connection -> T.Bucket -> T.Key -> RW -> IO ()-delete conn bucket key rw = exchange_ conn $ Req.delete bucket key rw+delete :: Connection -> Maybe T.BucketType -> T.Bucket -> T.Key -> RW -> IO ()+delete conn btype bucket key rw = exchange_ conn $ Req.delete btype bucket key rw --- List the buckets in the cluster.+-- | List the buckets in the cluster. -- -- /Note/: this operation is expensive.  Do not use it in production. listBuckets :: Connection -> Maybe BucketType -> IO (Seq.Seq T.Bucket) listBuckets conn btype = Resp.listBuckets <$> exchange conn (Req.listBuckets btype) --- Fold over the keys in a bucket.+-- | Fold over the keys in a bucket. -- -- /Note/: this operation is expensive.  Do not use it in production. foldKeys :: (MonadIO m) => Connection -> Maybe BucketType -> Bucket

@@ -61,75 +61,77 @@  -- | Retrieve a value.  This may return multiple conflicting siblings. -- Choosing among them is your responsibility.-get :: (FromJSON c, ToJSON c) => Connection -> Bucket -> Key -> R+get :: (FromJSON c, ToJSON c) => Connection+    -> Maybe BucketType -> Bucket -> Key -> R     -> IO (Maybe ([c], VClock))-get conn bucket' key' r = fmap convert <$> V.get conn bucket' key' r+get conn btype bucket' key' r = fmap convert <$> V.get conn btype 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+getMany :: (FromJSON c, ToJSON c) => Connection+        -> Maybe BucketType -> Bucket -> [Key] -> R+        -> IO [Maybe ([c], VClock)]+getMany conn btype bucket' ks r = map (fmap convert) <$> V.getMany conn btype bucket' ks r  -- | Store a single value.  This may return multiple conflicting -- siblings.  Choosing among them, and storing a new value, is your -- responsibility. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored.+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored. put :: (FromJSON c, ToJSON c) =>-       Connection -> Bucket -> Key -> Maybe VClock -> c+       Connection -> Maybe BucketType -> 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 conn btype bucket' key' mvclock val w dw =+    convert <$> V.put conn btype bucket' key' mvclock (json val) w dw  -- | Store a single value indexed. putIndexed :: (FromJSON c, ToJSON c)-           => Connection -> Bucket -> Key -> [IndexValue]+           => Connection -> Maybe BucketType -> Bucket -> Key -> [IndexValue]            -> Maybe VClock -> c            -> W -> DW -> IO ([c], VClock)-putIndexed conn bucket' key' ixs mvclock val w dw =-    convert <$> V.putIndexed conn bucket' key' ixs mvclock (json val) w dw+putIndexed conn btype bucket' key' ixs mvclock val w dw =+    convert <$> V.putIndexed conn btype bucket' key' ixs mvclock (json val) w dw  -- | Store a single value, without the possibility of conflict -- resolution. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored, and you will not be notified.+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored, and you will not be notified. put_ :: (FromJSON c, ToJSON c) =>-       Connection -> Bucket -> Key -> Maybe VClock -> c+       Connection -> Maybe BucketType -> 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+put_ conn btype bucket' key' mvclock val w dw =+    V.put_ conn btype bucket' key' mvclock (json val) w dw  -- | Store many values.  This may return multiple conflicting siblings -- for each value stored.  Choosing among them, and storing a new -- value in each case, is your responsibility. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored.+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored. putMany :: (FromJSON c, ToJSON c) =>-           Connection -> Bucket -> [(Key, Maybe VClock, c)]+           Connection -> Maybe BucketType -> 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+putMany conn btype bucket' puts w dw =+    map convert <$> V.putMany conn btype bucket' (map f puts) w dw   where f (k,v,c) = (k,v,json c)  -- | Store many values, without the possibility of conflict -- resolution. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored, and you will not be notified.+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored, and you will not be notified. putMany_ :: (FromJSON c, ToJSON c) =>-            Connection -> Bucket -> [(Key, Maybe VClock, c)]+            Connection -> Maybe BucketType -> Bucket -> [(Key, Maybe VClock, c)]          -> W -> DW -> IO ()-putMany_ conn bucket' puts w dw = V.putMany_ conn bucket' (map f puts) w dw+putMany_ conn btype bucket' puts w dw = V.putMany_ conn btype bucket' (map f puts) w dw   where f (k,v,c) = (k,v,json c)  convert :: ([JSON a], VClock) -> ([a], VClock)

@@ -41,14 +41,14 @@ -- | 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))+       Connection -> Maybe BucketType -> 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, 'resolve' is used to choose a winner. getMany :: (FromJSON c, ToJSON c, Resolvable c)-           => Connection -> Bucket -> [Key] -> R -> IO [Maybe (c, VClock)]+           => Connection -> Maybe BucketType -> Bucket -> [Key] -> R -> IO [Maybe (c, VClock)] getMany = R.getMany J.getMany {-# INLINE getMany #-} @@ -66,7 +66,7 @@ -- 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+          Connection -> Maybe BucketType -> Bucket -> Key -> R -> W -> DW        -> (Maybe a -> IO (a,b))        -- ^ Modification function.  Called with 'Just' the value if        -- the key is present, 'Nothing' otherwise.@@ -86,7 +86,7 @@ -- being stuck in a conflict resolution loop, it will throw a -- 'ResolutionFailure' exception. modify_ :: (MonadIO m, FromJSON a, ToJSON a, Resolvable a) =>-           Connection -> Bucket -> Key -> R -> W -> DW+           Connection -> Maybe BucketType -> Bucket -> Key -> R -> W -> DW         -> (Maybe a -> m a) -> m a modify_ = R.modify_ J.get J.put {-# INLINE modify_ #-}@@ -104,20 +104,20 @@ -- conflict resolution loop, it will throw a 'ResolutionFailure' -- exception. put :: (FromJSON c, ToJSON c, Resolvable c) =>-       Connection -> Bucket -> Key -> Maybe VClock -> c -> W -> DW+       Connection -> Maybe BucketType -> Bucket -> Key -> Maybe VClock -> c -> W -> DW     -> IO (c, VClock) put = R.put J.put {-# INLINE put #-}  -- | Store a single value indexed. putIndexed :: (FromJSON c, ToJSON c, Resolvable c)-           => Connection -> Bucket -> Key -> [IndexValue]+           => Connection -> Maybe BucketType -> Bucket -> Key -> [IndexValue]            -> Maybe VClock -> c -> W -> DW            -> IO (c, VClock)-putIndexed c b k ixs vc cont w' dw' =-    R.put (\conn bucket' key' mvclock val w dw ->-               J.putIndexed conn bucket' key' ixs mvclock val w dw)-          c b k vc cont w' dw'+putIndexed c bt b k ixs vc cont w' dw' =+    R.put (\conn btype bucket' key' mvclock val w dw ->+               J.putIndexed conn btype bucket' key' ixs mvclock val w dw)+          c bt b k vc cont w' dw' {-# INLINE putIndexed #-}  -- | Store a single value, automatically resolving any vector clock@@ -133,7 +133,7 @@ -- conflict resolution loop, it will throw a 'ResolutionFailure' -- exception. put_ :: (FromJSON c, ToJSON c, Resolvable c) =>-        Connection -> Bucket -> Key -> Maybe VClock -> c -> W -> DW+        Connection -> Maybe BucketType -> Bucket -> Key -> Maybe VClock -> c -> W -> DW      -> IO () put_ = R.put_ J.put {-# INLINE put_ #-}@@ -153,7 +153,7 @@ -- If this function gives up due to apparently being stuck in a loop, -- it will throw a 'ResolutionFailure' exception. putMany :: (FromJSON c, ToJSON c, Resolvable c) =>-           Connection -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW+           Connection -> Maybe BucketType -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW         -> IO [(c, VClock)] putMany = R.putMany J.putMany {-# INLINE putMany #-}@@ -170,7 +170,7 @@ -- If this function gives up due to apparently being stuck in a loop, -- it will throw a 'ResolutionFailure' exception. putMany_ :: (FromJSON c, ToJSON c, Resolvable c) =>-            Connection -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW+            Connection -> Maybe BucketType -> Bucket -> [(Key, Maybe VClock, c)] -> W -> DW          -> IO () putMany_ = R.putMany_ J.putMany {-# INLINE putMany_ #-}

@@ -98,8 +98,9 @@ {-# INLINE getServerInfo #-}  -- | Create a get request.  The bucket and key names are URL-escaped.-get :: Bucket -> Key -> R -> Get.GetRequest-get bucket key r = Get.GetRequest { Get.bucket = escape bucket+get :: Maybe BucketType -> Bucket -> Key -> R -> Get.GetRequest+get btype bucket key r = Get.GetRequest {+                                    Get.bucket = escape bucket                                   , Get.key = escape key                                   , Get.r = fromQuorum r                                   , Get.pr = Nothing@@ -111,7 +112,8 @@                                   , Get.timeout = Nothing                                   , Get.sloppy_quorum = Nothing                                   , Get.n_val = Nothing-                                  , Get.type' = Nothing+                                  , Get.type' = btype -- no escaping intentional+                                                      -- TODO don't escape anything                                   } {-# INLINE get #-} @@ -156,12 +158,26 @@ -- | Create a put request.  The bucket and key names are URL-escaped. -- Any 'Link' values inside the 'Content' are assumed to have been -- constructed with the 'link' function, and hence /not/ escaped.-put :: Bucket -> Key -> Maybe VClock -> Content -> W -> DW -> Bool+put :: Maybe BucketType -> Bucket -> Key -> Maybe VClock -> Content -> W -> DW -> Bool     -> Put.PutRequest-put bucket key mvclock cont mw mdw returnBody =-    Put.PutRequest (escape bucket) (Just $ escape key) (fromVClock <$> mvclock)-                   cont (fromQuorum mw) (fromQuorum mdw) (Just returnBody)-                   Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+put btype bucket key mvclock cont mw mdw returnBody =+    Put.PutRequest { Put.bucket = escape bucket,+                     Put.key = Just $ escape key,+                     Put.vclock = fromVClock <$> mvclock,+                     Put.content = cont,+                     Put.w = fromQuorum mw,+                     Put.dw = fromQuorum mdw,+                     Put.return_body = Just returnBody,+                     Put.pw = Nothing,+                     Put.if_not_modified = Nothing,+                     Put.if_none_match = Nothing,+                     Put.return_head = Nothing,+                     Put.timeout = Nothing,+                     Put.asis = Nothing,+                     Put.sloppy_quorum = Nothing,+                     Put.n_val = Nothing,+                     Put.type' = btype -- same as get+                   } {-# INLINE put #-}  -- | Create a link.  The bucket and key names are URL-escaped.@@ -170,10 +186,22 @@ {-# INLINE link #-}  -- | Create a delete request.  The bucket and key names are URL-escaped.-delete :: Bucket -> Key -> RW -> Del.DeleteRequest-delete bucket key rw = Del.DeleteRequest (escape bucket) (escape key)-                                         (fromQuorum rw) Nothing Nothing Nothing-                                         Nothing Nothing Nothing Nothing Nothing Nothing Nothing+delete :: Maybe BucketType -> Bucket -> Key -> RW -> Del.DeleteRequest+delete btype bucket key rw = Del.DeleteRequest {+                               Del.bucket = escape bucket,+                               Del.key = escape key,+                               Del.rw = fromQuorum rw,+                               Del.vclock = Nothing,+                               Del.r = Nothing,+                               Del.w = Nothing,+                               Del.pr = Nothing,+                               Del.pw = Nothing,+                               Del.dw = Nothing,+                               Del.timeout = Nothing,+                               Del.sloppy_quorum = Nothing,+                               Del.n_val = Nothing,+                               Del.type' = btype -- same as get+                             } {-# INLINE delete #-}  -- | Create a list-buckets request.

@@ -98,23 +98,25 @@     resolve _          b        = b     {-# INLINE resolve #-} -type Get a = Connection -> Bucket -> Key -> R -> IO (Maybe ([a], VClock))+type Get a = Connection -> Maybe BucketType -> 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+    -> (Connection -> Maybe BucketType -> Bucket -> Key -> R -> IO (Maybe (a, VClock)))+get doGet conn btype bucket' key' r =+    fmap (first resolveMany) `fmap` doGet conn btype 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+           (Connection -> Maybe BucketType -> Bucket -> [Key]+                       -> R -> IO [Maybe ([a], VClock)])+        -> Connection -> Maybe BucketType -> Bucket -> [Key]+        -> R -> IO [Maybe (a, VClock)]+getMany doGet conn bt b ks r =+    map (fmap (first resolveMany)) `fmap` doGet conn bt b ks r {-# INLINE getMany #-}  -- If Riak receives a put request with no vclock, and the given--- bucket+key already exists, it will treat the missing vclock as+-- type+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.@@ -122,17 +124,17 @@ -- 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+type Put a = Connection -> Maybe BucketType -> Bucket -> Key -> Maybe VClock -> a -> W -> DW            -> IO ([a], VClock)  put :: (Resolvable a) => Put a-    -> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW+    -> Connection -> Maybe BucketType -> Bucket -> Key -> Maybe VClock -> a -> W -> DW     -> IO (a, VClock)-put doPut conn bucket' key' mvclock0 val0 w dw = do+put doPut conn btype bucket' key' mvclock0 val0 w dw = do   let go !i val mvclock          | i == maxRetries = throwIO RetriesExceeded          | otherwise       = do-        (xs, vclock) <- doPut conn bucket' key' mvclock val w dw+        (xs, vclock) <- doPut conn btype bucket' key' mvclock val w dw         case xs of           [x] | i > 0 || isJust mvclock -> return (x, vclock)           (_:_) -> do debugValues "put" "conflict" xs@@ -148,45 +150,47 @@ {-# INLINE maxRetries #-}  put_ :: (Resolvable a) =>-        (Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW+        (Connection -> Maybe BucketType -> Bucket -> Key -> Maybe VClock -> a -> W -> DW                     -> IO ([a], VClock))-     -> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW+     -> Connection -> Maybe BucketType -> Bucket -> Key -> Maybe VClock -> a -> W -> DW      -> IO ()-put_ doPut conn bucket' key' mvclock0 val0 w dw =-    put doPut conn bucket' key' mvclock0 val0 w dw >> return ()+put_ doPut conn btype bucket' key' mvclock0 val0 w dw =+    put doPut conn btype bucket' key' mvclock0 val0 w dw >> return () {-# INLINE put_ #-}  modify :: (MonadIO m, Resolvable a) => Get a -> Put a-       -> Connection -> Bucket -> Key -> R -> W -> DW -> (Maybe a -> m (a,b))+       -> Connection -> Maybe BucketType -> Bucket+       -> Key -> R -> W -> DW -> (Maybe a -> m (a,b))        -> m (a,b)-modify doGet doPut conn bucket' key' r w dw act = do-  a0 <- liftIO $ get doGet conn bucket' key' r+modify doGet doPut conn btype bucket' key' r w dw act = do+  a0 <- liftIO $ get doGet conn btype bucket' key' r   (a,b) <- act (fst <$> a0)-  (a',_) <- liftIO $ put doPut conn bucket' key' (snd <$> a0) a w dw+  (a',_) <- liftIO $ put doPut conn btype bucket' key' (snd <$> a0) a w dw   return (a',b) {-# INLINE modify #-}  modify_ :: (MonadIO m, Resolvable a) => Get a -> Put a-        -> Connection -> Bucket -> Key -> R -> W -> DW -> (Maybe a -> m a)+        -> Connection -> Maybe BucketType -> Bucket+        -> Key -> R -> W -> DW -> (Maybe a -> m a)         -> m a-modify_ doGet doPut conn bucket' key' r w dw act = do-  a0 <- liftIO $ get doGet conn bucket' key' r+modify_ doGet doPut conn btype bucket' key' r w dw act = do+  a0 <- liftIO $ get doGet conn btype bucket' key' r   a <- act (fst <$> a0)-  liftIO $ fst <$> put doPut conn bucket' key' (snd <$> a0) a w dw+  liftIO $ fst <$> put doPut conn btype bucket' key' (snd <$> a0) a w dw {-# INLINE modify_ #-}  putMany :: (Resolvable a) =>-           (Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW+           (Connection -> Maybe BucketType -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW                        -> IO [([a], VClock)])-        -> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW+        -> Connection -> Maybe BucketType -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW         -> IO [(a, VClock)]-putMany doPut conn bucket' puts0 w dw = go (0::Int) [] . zip [(0::Int)..] $ puts0+putMany doPut conn btype 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+    rs <- doPut conn btype bucket' (map snd puts) w dw     let (conflicts, ok) = partitionEithers $ zipWith mush puts rs     unless (null conflicts) $       debugValues "putMany" "conflicts" conflicts@@ -200,11 +204,12 @@ {-# INLINE putMany #-}  putMany_ :: (Resolvable a) =>-            (Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW+            (Connection -> Maybe BucketType -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW                         -> IO [([a], VClock)])-         -> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW -> IO ()-putMany_ doPut conn bucket' puts0 w dw =-    putMany doPut conn bucket' puts0 w dw >> return ()+         -> Connection -> Maybe BucketType -> Bucket+         -> [(Key, Maybe VClock, a)] -> W -> DW -> IO ()+putMany_ doPut conn btype bucket' puts0 w dw =+    putMany doPut conn btype bucket' puts0 w dw >> return () {-# INLINE putMany_ #-}  resolveMany' :: (Resolvable a) => a -> [a] -> a

@@ -101,23 +101,24 @@ -- responsibility. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored.-put :: (IsContent c) => Connection -> Bucket -> Key -> Maybe VClock -> c+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored.+put :: (IsContent c) => Connection+    -> Maybe BucketType -> Bucket -> Key -> Maybe VClock -> c     -> W -> DW -> IO ([c], VClock)-put conn bucket key mvclock val w dw =+put conn btype bucket key mvclock val w dw =   putResp =<< exchange conn-              (Req.put bucket key mvclock (toContent val) w dw True)+              (Req.put btype bucket key mvclock (toContent val) w dw True)  -- | Store an indexed value.-putIndexed :: (IsContent c) => Connection -> Bucket -> Key+putIndexed :: (IsContent c) => Connection -> Maybe BucketType -> Bucket -> Key            -> [IndexValue]            -> Maybe VClock -> c            -> W -> DW -> IO ([c], VClock)-putIndexed conn b k inds mvclock val w dw =+putIndexed conn bt b k inds mvclock val w dw =     putResp =<< exchange conn-                  (Req.put b k mvclock (addIndexes inds (toContent val))+                  (Req.put bt b k mvclock (addIndexes inds (toContent val))                       w dw True)  -- | Store many values.  This may return multiple conflicting siblings@@ -125,13 +126,14 @@ -- value in each case, is your responsibility. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored.-putMany :: (IsContent c) => Connection -> Bucket -> [(Key, Maybe VClock, c)]+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored.+putMany :: (IsContent c) => Connection+        -> Maybe BucketType -> Bucket -> [(Key, Maybe VClock, c)]         -> W -> DW -> IO [([c], VClock)]-putMany conn b puts w dw =-  mapM putResp =<< pipeline conn (map (\(k,v,c) -> Req.put b k v (toContent c) w dw True) puts)+putMany conn bt b puts w dw =+  mapM putResp =<< pipeline conn (map (\(k,v,c) -> Req.put bt b k v (toContent c) w dw True) puts)  putResp :: (IsContent c) => PutResponse -> IO ([c], VClock) putResp PutResponse{..} = do@@ -145,31 +147,33 @@ -- resolution. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored, and you will not be notified.-put_ :: (IsContent c) => Connection -> Bucket -> Key -> Maybe VClock -> c-    -> W -> DW -> IO ()-put_ conn bucket key mvclock val w dw =-  exchange_ conn (Req.put bucket key mvclock (toContent val) w dw False)+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored, and you will not be notified.+put_ :: (IsContent c) => Connection+     -> Maybe BucketType -> Bucket -> Key -> Maybe VClock -> c+     -> W -> DW -> IO ()+put_ conn btype bucket key mvclock val w dw =+  exchange_ conn (Req.put btype bucket key mvclock (toContent val) w dw False)  -- | Store many values, without the possibility of conflict -- resolution. -- -- You should /only/ supply 'Nothing' as a 'T.VClock' if you are sure--- that the given bucket+key combination does not already exist.  If--- you omit a 'T.VClock' but the bucket+key /does/ exist, your value--- will not be stored, and you will not be notified.-putMany_ :: (IsContent c) => Connection -> Bucket -> [(Key, Maybe VClock, c)]+-- that the given type+bucket+key combination does not already exist.+-- If you omit a 'T.VClock' but the type+bucket+key /does/ exist, your+-- value will not be stored, and you will not be notified.+putMany_ :: (IsContent c) => Connection+         -> Maybe BucketType -> Bucket -> [(Key, Maybe VClock, c)]          -> W -> DW -> IO ()-putMany_ conn b puts w dw =-  pipeline_ conn . map (\(k,v,c) -> Req.put b k v (toContent c) w dw False) $ puts+putMany_ conn bt b puts w dw =+  pipeline_ conn . map (\(k,v,c) -> Req.put bt b k v (toContent c) w dw False) $ puts  -- | Retrieve a value.  This may return multiple conflicting siblings. -- Choosing among them is your responsibility.-get :: (IsContent c) => Connection -> Bucket -> Key -> R+get :: (IsContent c) => Connection -> Maybe BucketType -> Bucket -> Key -> R     -> IO (Maybe ([c], VClock))-get conn bucket key r = getResp =<< exchangeMaybe conn (Req.get bucket key r)+get conn btype bucket key r = getResp =<< exchangeMaybe conn (Req.get btype bucket key r)  -- | Retrieve list of keys matching some index query. getByIndex :: Connection -> Bucket -> IndexQuery@@ -177,10 +181,11 @@ getByIndex conn b indq =     getByIndexResp =<< exchangeMaybe conn (Req.getByIndex b indq) -getMany :: (IsContent c) => Connection -> Bucket -> [Key] -> R+getMany :: (IsContent c) => Connection+        -> Maybe BucketType -> Bucket -> [Key] -> R         -> IO [Maybe ([c], VClock)]-getMany conn b ks r =-    mapM getResp =<< pipelineMaybe conn (map (\k -> Req.get b k r) ks)+getMany conn bt b ks r =+    mapM getResp =<< pipelineMaybe conn (map (\k -> Req.get bt b k r) ks)  getResp :: (IsContent c) => Maybe GetResponse -> IO (Maybe ([c], VClock)) getResp resp =

@@ -41,13 +41,14 @@ -- | Retrieve a single value.  If conflicting values are returned, the -- 'Resolvable' is used to choose a winner. get :: (Resolvable a, V.IsContent a) =>-       Connection -> Bucket -> Key -> R -> IO (Maybe (a, VClock))+       Connection -> Maybe BucketType -> Bucket -> Key -> R -> IO (Maybe (a, VClock)) get = R.get V.get {-# INLINE get #-}  -- | Retrieve multiple values.  If conflicting values are returned for -- a key, the 'Resolvable' is used to choose a winner.-getMany :: (Resolvable a, V.IsContent a) => Connection -> Bucket -> [Key] -> R+getMany :: (Resolvable a, V.IsContent a) => Connection+        -> Maybe BucketType -> Bucket -> [Key] -> R         -> IO [Maybe (a, VClock)] getMany = R.getMany V.getMany {-# INLINE getMany #-}@@ -66,7 +67,7 @@ -- 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+          Connection -> Maybe BucketType -> Bucket -> Key -> R -> W -> DW        -> (Maybe a -> IO (a,b))        -- ^ Modification function.  Called with 'Just' the value if        -- the key is present, 'Nothing' otherwise.@@ -86,7 +87,7 @@ -- 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+           Connection -> Maybe BucketType -> Bucket -> Key -> R -> W -> DW         -> (Maybe a -> IO a) -> IO a modify_ = R.modify_ V.get V.put {-# INLINE modify_ #-}@@ -104,7 +105,8 @@ -- conflict resolution loop, it will throw a 'ResolutionFailure' -- exception. put :: (Resolvable a, V.IsContent a) =>-       Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW+       Connection -> Maybe BucketType -> Bucket -> Key+    -> Maybe VClock -> a -> W -> DW     -> IO (a, VClock) put = R.put V.put {-# INLINE put #-}@@ -122,7 +124,8 @@ -- conflict resolution loop, it will throw a 'ResolutionFailure' -- exception. put_ :: (Resolvable a, V.IsContent a) =>-        Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW+        Connection -> Maybe BucketType -> Bucket -> Key+     -> Maybe VClock -> a -> W -> DW      -> IO () put_ = R.put_ V.put {-# INLINE put_ #-}@@ -142,7 +145,7 @@ -- If this function gives up due to apparently being stuck in a loop, -- it will throw a 'ResolutionFailure' exception. putMany :: (Resolvable a, V.IsContent a) =>-           Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW+           Connection -> Maybe BucketType -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW         -> IO [(a, VClock)] putMany = R.putMany V.putMany {-# INLINE putMany #-}@@ -159,6 +162,7 @@ -- If this function gives up due to apparently being stuck in a loop, -- it will throw a 'ResolutionFailure' exception. putMany_ :: (Resolvable a, V.IsContent a) =>-            Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW -> IO ()+            Connection -> Maybe BucketType -> Bucket+         -> [(Key, Maybe VClock, a)] -> W -> DW -> IO () putMany_ = R.putMany_ V.putMany {-# INLINE putMany_ #-}

@@ -37,10 +37,10 @@     monadicIO $ assert . uncurry (==) =<< run act   where     act = withSomeConnection $ \c -> do-            p <- Just <$> B.put c b k Nothing (binary v) Default Default-            r <- B.get c b k Default+            p <- Just <$> B.put c btype b k Nothing (binary v) Default Default+            r <- B.get c btype b k Default             return (p,r)-+    btype = Nothing  put_delete_get :: QCBucket -> QCKey -> L.ByteString -> Property put_delete_get (QCBucket b) (QCKey k) v@@ -49,10 +49,10 @@         assert $ isNothing r     where       act = withSomeConnection $ \c -> do-              _ <- B.put c b k Nothing (binary v) Default Default-              B.delete c b k Default-              B.get c b k Default-+              _ <- B.put c bt b k Nothing (binary v) Default Default+              B.delete c bt b k Default+              B.get c bt b k Default+      bt = Nothing :: Maybe BucketType  tests :: [TestTree] tests = [

@@ -1,17 +1,22 @@ {-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp  #-}  module Main where  import           Control.Monad+import           Control.Applicative import qualified Data.Map                     as M import qualified Data.Set                     as S+import qualified Data.Sequence                as Seq import           Data.List.NonEmpty           (NonEmpty(..))+import           Data.Foldable                (toList) import           Data.Semigroup import           Data.Text                    (Text) import           Control.Concurrent           (threadDelay) import qualified Network.Riak                 as Riak import qualified Network.Riak.Basic           as B+import qualified Network.Riak.Content         as B import qualified Network.Riak.CRDT            as C import qualified Network.Riak.CRDT.Riak       as C import qualified Network.Riak.Search          as S@@ -33,7 +38,8 @@                            integrationalTests,                            ping'o'death,                            crdts,-                           searches+                           searches,+                           bucketTypes                           ] properties :: TestTree properties = testGroup "simple properties" Properties.tests@@ -67,10 +73,11 @@ testIndexedPutGet :: TestTree testIndexedPutGet = testCase "testIndexedPutGet" $ do     rc <- Riak.connectToCluster [Riak.defaultClient]-    let b = "riak-haskell-client-test"+    let bt = Nothing+        b = "riak-haskell-client-test"         k = "test"     keys <- Riak.inCluster rc $ \c -> do-      _ <- J.putIndexed c b k [(IndexInt "someindex" 135)] Nothing+      _ <- J.putIndexed c bt b k [(IndexInt "someindex" 135)] Nothing           (RM (M.fromList [("somekey", "someval")] :: M.Map Text Text))           Default Default       Riak.getByIndex c b (IndexQueryExactInt "someindex" 135)@@ -173,3 +180,25 @@              assertBool "all indeces" $ not (null all)              assertEqual "set index" 1 (length one) +bucketTypes :: TestTree+bucketTypes = testCase "bucketTypes" $ do+             conn <- Riak.connect Riak.defaultClient+             [p0,p1,p2] <- sequence [ B.put conn bt b k Nothing o Default Default+                                      | bt <- types | o <- [o0,o1,o2] ]+             [r0,r1,r2] <- sequence [ B.get conn bt b k Default | bt <- types ]++             assertBool "sound get Nothing"   (valok r0 o0)+             assertBool "sound get untyped-1" (valok r1 o1)+             assertBool "sound get untyped-2" (valok r2 o2)++             assertEqual "put=get Nothing"   (Just p0) r0+             assertEqual "put=get untyped-1" (Just p1) r1+             assertEqual "put=get untyped-2" (Just p2) r2+    where+      (b,k) = ("xxx","0") :: (Bucket,Key)+      types = [Nothing, Just "untyped-1", Just "untyped-2"] :: [Maybe BucketType]+      [o0,o1,o2] = B.binary <$> ["A","B","C"] :: [B.Content]++      valok :: Maybe (Seq.Seq B.Content, VClock) -> B.Content -> Bool+      valok (Just (rs,_)) o = B.value o `elem` map B.value (toList rs)+      valok _ _             = False