Implement bulk delete operation

Database/MongoDB/Admin.hs

@@ -204,7 +204,8 @@ addUser readOnly user pass = do
     let usr = merge ["readOnly" =: readOnly, "pwd" =: pwHash user pass] (maybe ["user" =: user] id mu)
     save "system.users" usr
 
-removeUser :: (MonadIO m) => Username -> Action m ()
+removeUser :: (MonadIO m, MonadBaseControl IO m)
+           => Username -> Action m ()
 removeUser user = delete (select ["user" =: user] "system.users")
 
 -- ** Database

Database/MongoDB/Query.hs

@@ -43,7 +43,8 @@ module Database.MongoDB.Query (
     -- * Command
     Command, runCommand, runCommand1,
     eval, retrieveServerData, updateMany, updateAll, UpdateResult,
-    UpdateOption(..)
+    UpdateOption(..),
+    deleteMany, deleteAll, DeleteResult, DeleteOption(..)
 ) where
 
 import Prelude hiding (lookup)
@@ -150,6 +151,8 @@ type GetLastError = Document
 
 data UpdateResult = UpdateResult
 
+data DeleteResult = DeleteResult
+
 master :: AccessMode
 -- ^ Same as 'ConfirmWrites' []
 master = ConfirmWrites []
@@ -440,7 +443,7 @@ insert' opts col docs = do
   chunks <- forM (splitAtLimit
                       (not (KeepGoing `elem` opts))
                       (maxBsonObjectSize sd - docSize)
-                                           -- ^ size of auxiliary part of insert
+                                           -- size of auxiliary part of insert
                                            -- document should be subtracted from
                                            -- the overall size
                       (maxWriteBatchSize sd)
@@ -609,7 +612,7 @@ update' ordered col updateDocs = do
   let chunks = splitAtLimit
                       ordered
                       (maxBsonObjectSize sd - docSize)
-                                           -- ^ size of auxiliary part of insert
+                                           -- size of auxiliary part of update
                                            -- document should be subtracted from
                                            -- the overall size
                       (maxWriteBatchSize sd)
@@ -663,19 +666,122 @@ updateBlock ordered col docs = do
 
 -- ** Delete
 
-delete :: (MonadIO m) => Selection -> Action m ()
+delete :: (MonadIO m, MonadBaseControl IO m)
+       => Selection -> Action m ()
 -- ^ Delete all documents in selection
-delete = delete' []
+delete = deleteHelper []
 
-deleteOne :: (MonadIO m) => Selection -> Action m ()
+deleteOne :: (MonadIO m, MonadBaseControl IO m)
+          => Selection -> Action m ()
 -- ^ Delete first document in selection
-deleteOne = delete' [SingleRemove]
+deleteOne = deleteHelper [SingleRemove]
 
-delete' :: (MonadIO m) => [DeleteOption] -> Selection -> Action m ()
+deleteHelper :: (MonadBaseControl IO m, MonadIO m)
--- ^ Delete all documents in selection unless 'SingleRemove' option is given then only delete first document in selection
+             => [DeleteOption] -> Selection -> Action m ()
-delete' opts (Select sel col) = do
+deleteHelper opts (Select sel col) = void $ delete' True col [(sel, opts)]
-    db <- thisDatabase
+
-    write (Delete (db <.> col) opts sel)
+{-| Bulk delete operation. If one delete fails it will not delete the remaining
+ - documents. Current returned value is only a place holder. With mongodb server
+ - before 2.6 it will send delete requests one by one. After 2.6 it will use
+ - bulk delete feature in mongodb.
+ -}
+deleteMany :: (MonadIO m, MonadBaseControl IO m)
+           => Collection
+           -> [(Selector, [DeleteOption])]
+           -> Action m DeleteResult
+deleteMany = delete' True
+
+{-| Bulk delete operation. If one delete fails it will proceed with the
+ - remaining documents. Current returned value is only a place holder. With
+ - mongodb server before 2.6 it will send delete requests one by one. After 2.6
+ - it will use bulk delete feature in mongodb.
+ -}
+deleteAll :: (MonadIO m, MonadBaseControl IO m)
+          => Collection
+          -> [(Selector, [DeleteOption])]
+          -> Action m DeleteResult
+deleteAll = delete' False
+
+deleteCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document
+deleteCommandDocument col ordered deletes writeConcern =
+  [ "delete"       =: col
+  , "ordered"      =: ordered
+  , "deletes"      =: deletes
+  , "writeConcern" =: writeConcern
+  ]
+
+delete' :: (MonadIO m, MonadBaseControl IO m)
+        => Bool
+        -> Collection
+        -> [(Selector, [DeleteOption])]
+        -> Action m DeleteResult
+delete' ordered col deleteDocs = do
+  p <- asks mongoPipe
+  let sd = P.serverData p
+  let deletes = map (\(s, os) -> [ "q"     =: s
+                                 , "limit" =: if SingleRemove `elem` os
+                                               then (1 :: Int) -- Remove only one matching
+                                               else (0 :: Int) -- Remove all matching
+                                 ])
+                    deleteDocs
+
+  mode <- asks mongoWriteMode
+  let writeConcern = case mode of
+                        NoConfirm -> ["w" =: (0 :: Int)]
+                        Confirm params -> params
+  let docSize = sizeOfDocument $ deleteCommandDocument col ordered [] writeConcern
+  let chunks = splitAtLimit
+                      ordered
+                      (maxBsonObjectSize sd - docSize)
+                                           -- size of auxiliary part of delete
+                                           -- document should be subtracted from
+                                           -- the overall size
+                      (maxWriteBatchSize sd)
+                      deletes
+  forM_ chunks (deleteBlock ordered col)
+  return DeleteResult
+
+deleteBlock :: (MonadIO m, MonadBaseControl IO m)
+            => Bool -> Collection -> [Document] -> Action m ()
+deleteBlock ordered col docs = do
+  p <- asks mongoPipe
+  let sd = P.serverData p
+  if (maxWireVersion sd < 2)
+    then do
+      db <- thisDatabase
+      errors <-
+        forM docs $ \deleteDoc -> do
+          let sel = (at "q" deleteDoc) :: Document
+          let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else []
+          write (Delete (db <.> col) opts sel)
+          return Nothing
+          `catch` \(e :: SomeException) -> do
+                     when ordered $ liftIO $ throwIO e
+                     return $ Just e
+      let onlyErrors = catMaybes errors
+      if not $ null onlyErrors
+        then liftIO $ throwIO $ WriteFailure 0 (show onlyErrors)
+        else return ()
+    else do
+      mode <- asks mongoWriteMode
+      let writeConcern = case mode of
+                          NoConfirm -> ["w" =: (0 :: Int)]
+                          Confirm params -> params
+      doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern
+      case (look "writeErrors" doc, look "writeConcernError" doc) of
+        (Nothing, Nothing) -> return ()
+        (Just err, Nothing) -> do
+          liftIO $ throwIO $ WriteFailure
+                                  (maybe 0 id $ lookup "ok" doc)
+                                  (show err)
+        (Nothing, Just err) -> do
+          liftIO $ throwIO $ WriteFailure
+                                  (maybe 0 id $ lookup "ok" doc)
+                                  (show err)
+        (Just err, Just writeConcernErr) -> do
+          liftIO $ throwIO $ WriteFailure
+                                  (maybe 0 id $ lookup "ok" doc)
+                                  (show err ++ show writeConcernErr)
 
 -- * Read