Replace IORefs with interruptibleFor
This commit is contained in:
parent
d9db9bca52
commit
c6bd17f1f4
1 changed files with 32 additions and 49 deletions
|
@ -651,19 +651,11 @@ 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)
|
||||||
errorDetected <- liftIO $ newIORef False
|
|
||||||
ctx <- ask
|
ctx <- ask
|
||||||
blocks <- forM (zip lSums chunks) $ \b -> liftIO $ do
|
blocks <- liftIO $ interruptibleFor ordered (zip lSums chunks) $ \b -> liftIO $ do
|
||||||
ed <- readIORef errorDetected
|
|
||||||
if ed && ordered
|
|
||||||
then return $ UpdateResult True 0 Nothing [] [] []
|
|
||||||
else do
|
|
||||||
ur <- runReaderT (updateBlock ordered col b) ctx
|
ur <- runReaderT (updateBlock ordered col b) ctx
|
||||||
when (failed ur) $ do
|
|
||||||
writeIORef errorDetected True
|
|
||||||
return ur
|
return ur
|
||||||
`catch` \(e :: SomeException) -> do
|
`catch` \(e :: SomeException) -> do
|
||||||
writeIORef errorDetected True
|
|
||||||
return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised
|
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
|
||||||
|
@ -720,14 +712,8 @@ 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 <- liftIO $
|
||||||
results <-
|
interruptibleFor ordered (zip [prevCount, (prevCount + 1) ..] docs) $ \(i, updateDoc) -> do
|
||||||
liftIO $ forM (zip [prevCount, (prevCount + 1) ..] docs) $ \(i, updateDoc) -> do
|
|
||||||
ed <- readIORef errorDetected
|
|
||||||
if ed && ordered
|
|
||||||
then do
|
|
||||||
return $ UpdateResult True 0 Nothing [] [] []
|
|
||||||
else do
|
|
||||||
let doc = (at "u" updateDoc) :: Document
|
let doc = (at "u" updateDoc) :: Document
|
||||||
let sel = (at "q" updateDoc) :: Document
|
let sel = (at "q" updateDoc) :: Document
|
||||||
let upsrt = if at "upsert" updateDoc then [Upsert] else []
|
let upsrt = if at "upsert" updateDoc then [Upsert] else []
|
||||||
|
@ -752,13 +738,10 @@ updateBlockLegacy ordered col (prevCount, docs) = do
|
||||||
let c = fromMaybe defaultCode eCode
|
let c = fromMaybe defaultCode eCode
|
||||||
if wtimeout
|
if wtimeout
|
||||||
then do
|
then do
|
||||||
writeIORef errorDetected True
|
|
||||||
return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV]
|
return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV]
|
||||||
else do
|
else do
|
||||||
writeIORef errorDetected True
|
|
||||||
return $ UpdateResult True 0 Nothing [] [WriteError i c errV] []
|
return $ UpdateResult True 0 Nothing [] [WriteError i c errV] []
|
||||||
`catch` \(e :: SomeException) -> do
|
`catch` \(e :: SomeException) -> do
|
||||||
writeIORef errorDetected True
|
|
||||||
return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] []
|
return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] []
|
||||||
return $ foldl1' mergeUpdateResults results
|
return $ foldl1' mergeUpdateResults results
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue