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

Replace IORefs with interruptibleFor

Browse source
This commit is contained in:
Victor Denisov 2016-11-01 22:53:27 -07:00
parent d9db9bca52
commit c6bd17f1f4
1 changed files with 32 additions and 49 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
Database/MongoDB/Query.hs
View file

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