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

Set proper index for exception

Browse source
This commit is contained in:
Victor Denisov 2017-01-21 15:25:28 -08:00
parent 6013272c5d
commit 6a13bde01b
1 changed files with 8 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
Database/MongoDB/Query.hs
View file

@ -926,6 +926,11 @@ delete' ordered col deleteDocs = do
return $ WriteResult True 0 Nothing 0 [] [e] [] return $ WriteResult True 0 Nothing 0 [] [e] []
return $ foldl1' mergeWriteResults blockResult return $ foldl1' mergeWriteResults blockResult
addFailureIndex :: Int -> Failure -> Failure
addFailureIndex i (WriteFailure ind code s) = WriteFailure i code s
addFailureIndex i f = f
deleteBlock :: (MonadIO m) deleteBlock :: (MonadIO m)
=> Bool -> Collection -> (Int, [Document]) -> Action m WriteResult => Bool -> Collection -> (Int, [Document]) -> Action m WriteResult
deleteBlock ordered col (prevCount, docs) = do deleteBlock ordered col (prevCount, docs) = do
@ -936,16 +941,16 @@ deleteBlock ordered col (prevCount, docs) = do
db <- thisDatabase db <- thisDatabase
ctx <- ask ctx <- ask
results <- results <-
liftIO $ interruptibleFor ordered docs $ \deleteDoc -> do liftIO $ interruptibleFor ordered (zip [prevCount, prevCount + 1 ..] docs) $ \(i, 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
let n = fromMaybe 0 $ do let n = fromMaybe 0 $ do
resDoc <- res resDoc <- res
resDoc !? "n" resDoc !? "n"
return $ WriteResult False 0 Nothing n [] [] [] return $ WriteResult False 0 Nothing n [] [] [] -- TODO it's only ok when res ok is 1. Should be fixed
`catch` \(e :: Failure) -> do `catch` \(e :: Failure) -> do
return $ WriteResult True 0 Nothing 0 [] [e] [] return $ WriteResult True 0 Nothing 0 [] [addFailureIndex i e] []
return $ foldl1' mergeWriteResults results return $ foldl1' mergeWriteResults results
else do else do
mode <- asks mongoWriteMode mode <- asks mongoWriteMode