Implement bulk delete operation

This commit is contained in:
Victor Denisov 2016-06-18 13:33:24 -07:00
parent 15ba90784e
commit 0ceefaec73
2 changed files with 120 additions and 13 deletions

View file

@ -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

View file

@ -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 ()
-- ^ Delete all documents in selection unless 'SingleRemove' option is given then only delete first document in selection
delete' opts (Select sel col) = do
deleteHelper :: (MonadBaseControl IO m, MonadIO m)
=> [DeleteOption] -> Selection -> Action m ()
deleteHelper opts (Select sel col) = void $ delete' True col [(sel, opts)]
{-| 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