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

Handle errors properly for ordered updates

Browse source
This commit is contained in:
Victor Denisov 2016-10-23 21:52:10 -07:00
parent f81d5ec42e
commit 316ae02ecc
1 changed files with 51 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

91
Database/MongoDB/Query.hs
View file

@ -645,17 +645,20 @@ update' ordered col updateDocs = do
updates updates
let lens = map length chunks let lens = map length chunks
let lSums = 0 : (zipWith (+) lSums lens) let lSums = 0 : (zipWith (+) lSums lens)
exceptionThrown <- liftIO $ newIORef False errorDetected <- liftIO $ newIORef False
blocks <- forM (zip lSums chunks) $ \b -> do ctx <- ask
ctx <- ask blocks <- forM (zip lSums chunks) $ \b -> liftIO $ do
liftIO $ do ed <- readIORef errorDetected
et <- readIORef exceptionThrown if ed && ordered
if et && ordered then return $ UpdateResult True 0 Nothing [] [] []
then return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised else do
else runReaderT (updateBlock ordered col b) ctx ur <- runReaderT (updateBlock ordered col b) ctx
`catch` \(e :: SomeException) -> do when (failed ur) $ do
writeIORef exceptionThrown True writeIORef errorDetected True
return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised return ur
`catch` \(e :: SomeException) -> do
writeIORef errorDetected True
return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised
let failedTotal = or $ map failed blocks let failedTotal = or $ map failed blocks
let updatedTotal = sum $ map nMatched blocks let updatedTotal = sum $ map nMatched blocks
let modifiedTotal = let modifiedTotal =
@ -700,38 +703,46 @@ updateBlockLegacy :: (MonadIO m)
updateBlockLegacy ordered col (prevCount, docs) = do updateBlockLegacy ordered col (prevCount, docs) = do
db <- thisDatabase db <- thisDatabase
ctx <- ask ctx <- ask
errorDetected <- liftIO $ newIORef False
results <- results <-
liftIO $ forM (zip [prevCount, (prevCount + 1) ..] docs) $ \(i, updateDoc) -> do liftIO $ forM (zip [prevCount, (prevCount + 1) ..] docs) $ \(i, updateDoc) -> do
let doc = (at "u" updateDoc) :: Document ed <- readIORef errorDetected
let sel = (at "q" updateDoc) :: Document if ed && ordered
let upsrt = if at "upsert" updateDoc then [Upsert] else [] then do
let multi = if at "multi" updateDoc then [MultiUpdate] else [] return $ UpdateResult True 0 Nothing [] [] []
mRes <- runReaderT (write (Update (db <.> col) (upsrt ++ multi) sel doc)) ctx else do
case mRes of let doc = (at "u" updateDoc) :: Document
Nothing -> return $ UpdateResult False 0 Nothing [] [] [] let sel = (at "q" updateDoc) :: Document
Just resDoc -> do let upsrt = if at "upsert" updateDoc then [Upsert] else []
let em = lookup "err" resDoc let multi = if at "multi" updateDoc then [MultiUpdate] else []
let eCode = lookup "code" resDoc mRes <- runReaderT (write (Update (db <.> col) (upsrt ++ multi) sel doc)) ctx
let wtimeout = fromMaybe False $ lookup "wtimeout" resDoc case mRes of
if isNothing em && isNothing eCode Nothing -> return $ UpdateResult False 0 Nothing [] [] []
then do Just resDoc -> do
let n = at "n" resDoc let em = lookup "err" resDoc
let ups = do let eCode = lookup "code" resDoc
upsValue <- lookup "upserted" resDoc let wtimeout = fromMaybe False $ lookup "wtimeout" resDoc
return $ Upserted i upsValue if isNothing em && isNothing eCode
return $ UpdateResult False n Nothing (maybeToList ups) [] []
else do
let defaultCode = if wtimeout then 64 else 24
let errV = fromMaybe "unknown error" em
let c = fromMaybe defaultCode eCode
if wtimeout
then do then do
return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV] let n = at "n" resDoc
let ups = do
upsValue <- lookup "upserted" resDoc
return $ Upserted i upsValue
return $ UpdateResult False n Nothing (maybeToList ups) [] []
else do else do
return $ UpdateResult True 0 Nothing [] [WriteError i c errV] [] let defaultCode = if wtimeout then 64 else 24
`catch` \(e :: SomeException) -> do let errV = fromMaybe "unknown error" em
when ordered $ liftIO $ throwIO e let c = fromMaybe defaultCode eCode
return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] [] if wtimeout
then do
writeIORef errorDetected True
return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV]
else do
writeIORef errorDetected True
return $ UpdateResult True 0 Nothing [] [WriteError i c errV] []
`catch` \(e :: SomeException) -> do
writeIORef errorDetected True
return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] []
return $ foldl1' mergeUpdateResults results return $ foldl1' mergeUpdateResults results
mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult
@ -859,7 +870,7 @@ deleteBlock ordered col docs = do
liftIO $ forM docs $ \deleteDoc -> do liftIO $ forM 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 []
runReaderT (write (Delete (db <.> col) opts sel)) ctx _ <- runReaderT (write (Delete (db <.> col) opts sel)) ctx
return Nothing return Nothing
`catch` \(e :: SomeException) -> do `catch` \(e :: SomeException) -> do
when ordered $ liftIO $ throwIO e when ordered $ liftIO $ throwIO e