Vergara_Tech/mongodb
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Rewrite deleteBlock using WriteResult

Browse source
This commit is contained in:
Victor Denisov 2017-01-14 18:39:43 -08:00
parent 09c05d4b69
commit 8db991bb5d
1 changed files with 28 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
Database/MongoDB/Query.hs
View file

@ -928,39 +928,47 @@ deleteBlock ordered col docs = do
then do then do
db <- thisDatabase db <- thisDatabase
ctx <- ask ctx <- ask
errors <- results <-
liftIO $ forM docs $ \deleteDoc -> do liftIO $ interruptibleFor ordered docs $ \deleteDoc -> do
let sel = (at "q" deleteDoc) :: Document let sel = (at "q" deleteDoc) :: Document
let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else [] let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else []
res <- runReaderT (write (Delete (db <.> col) opts sel)) ctx res <- runReaderT (write (Delete (db <.> col) opts sel)) ctx
return Nothing let n = fromMaybe 0 $ do
`catch` \(e :: SomeException) -> do resDoc <- res
when ordered $ liftIO $ throwIO e resDoc !? "n"
return $ Just e return $ WriteResult False 0 Nothing n [] [] []
let onlyErrors = catMaybes errors `catch` \(e :: Failure) -> do
if not $ null onlyErrors return $ WriteResult True 0 Nothing 0 [] [e] []
then liftIO $ throwIO $ WriteFailure 0 0 (show onlyErrors) -- TODO add normal index (first argument) return $ foldl1' mergeWriteResults results
else return $ WriteResult False 0 Nothing 0 [] [] [] -- TODO to be fixed
else do else do
mode <- asks mongoWriteMode mode <- asks mongoWriteMode
let writeConcern = case mode of let writeConcern = case mode of
NoConfirm -> ["w" =: (0 :: Int)] NoConfirm -> ["w" =: (0 :: Int)]
Confirm params -> params Confirm params -> params
doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern
let n = fromMaybe 0 $ doc !? "n"
case (look "writeErrors" doc, look "writeConcernError" doc) of case (look "writeErrors" doc, look "writeConcernError" doc) of
(Nothing, Nothing) -> return $ WriteResult False 0 Nothing 0 [] [] []-- TODO to be fixed (Nothing, Nothing) -> return $ WriteResult False 0 Nothing n [] [] []
(Just err, Nothing) -> do (Just err, Nothing) -> do
liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index return $ WriteResult True 0 Nothing n [] [
WriteFailure 0 -- TODO add normal index
(maybe 0 id $ lookup "ok" doc) (maybe 0 id $ lookup "ok" doc)
(show err) (show err)] []
(Nothing, Just err) -> do (Nothing, Just (Doc err)) -> do
liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index return $ WriteResult True 0 Nothing n [] [] [
WriteConcernError
(fromMaybe (-1) $ err !? "code")
(fromMaybe "" $ err !? "errmsg")
]
(Just err, Just (Doc writeConcernErr)) -> do
return $ WriteResult True 0 Nothing n [] [
WriteFailure 0 -- TODO add normal index
(maybe 0 id $ lookup "ok" doc) (maybe 0 id $ lookup "ok" doc)
(show err) (show err)] [
(Just err, Just writeConcernErr) -> do WriteConcernError
liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index (fromMaybe (-1) $ writeConcernErr !? "code")
(maybe 0 id $ lookup "ok" doc) (fromMaybe "" $ writeConcernErr !? "errmsg")
(show err ++ show writeConcernErr) ]
-- * Read -- * Read