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

Keep write concern errors in list

Browse source
This commit is contained in:
Victor Denisov 2016-08-25 23:00:30 -07:00
parent b6fa6ea402
commit 74e8aa205d
1 changed files with 8 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
Database/MongoDB/Query.hs
View file

@ -155,7 +155,7 @@ data UpdateResult = UpdateResult
-- ^ Mongodb server before 2.6 doesn't allow to calculate this value. This field is nothing if we can't calculate the number of modified documents. -- ^ Mongodb server before 2.6 doesn't allow to calculate this value. This field is nothing if we can't calculate the number of modified documents.
, upserted :: [Upserted] , upserted :: [Upserted]
, writeErrors :: [WriteError] , writeErrors :: [WriteError]
, writeConcernError :: Maybe WriteConcernError , writeConcernErrors :: [WriteConcernError]
} deriving Show } deriving Show
data Upserted = Upserted data Upserted = Upserted
@ -649,9 +649,11 @@ update' ordered col updateDocs = do
if all isNothing $ map nModified blocks if all isNothing $ map nModified blocks
then Nothing then Nothing
else Just $ sum $ catMaybes $ map nModified blocks else Just $ sum $ catMaybes $ map nModified blocks
let totalWriteErrors = concat $ map writeErrors blocks
let totalWriteConcernErrors = concat $ map writeConcernErrors blocks
let upsertedTotal = concat $ map upserted blocks let upsertedTotal = concat $ map upserted blocks
return $ UpdateResult updatedTotal modifiedTotal upsertedTotal [] Nothing -- TODO change Nothing to Something return $ UpdateResult updatedTotal modifiedTotal upsertedTotal totalWriteErrors totalWriteConcernErrors
updateBlock :: (MonadIO m) updateBlock :: (MonadIO m)
=> Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult
@ -670,7 +672,7 @@ updateBlock ordered col (prevCount, docs) = do
let multi = if at "multi" updateDoc then [MultiUpdate] else [] let multi = if at "multi" updateDoc then [MultiUpdate] else []
mRes <- runReaderT (write (Update (db <.> col) (upsrt ++ multi) sel doc)) ctx mRes <- runReaderT (write (Update (db <.> col) (upsrt ++ multi) sel doc)) ctx
case mRes of case mRes of
Nothing -> return $ Right $ UpdateResult 0 Nothing [] [] Nothing Nothing -> return $ Right $ UpdateResult 0 Nothing [] [] []
Just resDoc -> do Just resDoc -> do
let em = lookup "err" resDoc let em = lookup "err" resDoc
case em of case em of
@ -679,7 +681,7 @@ updateBlock ordered col (prevCount, docs) = do
let ups = do let ups = do
upsValue <- lookup "upserted" resDoc upsValue <- lookup "upserted" resDoc
return $ Upserted i upsValue return $ Upserted i upsValue
return $ Right $ UpdateResult n Nothing (maybeToList ups) [] Nothing return $ Right $ UpdateResult n Nothing (maybeToList ups) [] [] -- TODO add wtimeout checking. if there is timeout field then we need to add a WRITE_CONCERN_ERROR.
Just errV -> do Just errV -> do
return $ Left $ WriteError i (at "code" resDoc) errV return $ Left $ WriteError i (at "code" resDoc) errV
`catch` \(e :: SomeException) -> do `catch` \(e :: SomeException) -> do
@ -689,7 +691,7 @@ updateBlock ordered col (prevCount, docs) = do
let onlyUpdates = rights results let onlyUpdates = rights results
let totalnMatched = sum $ map nMatched onlyUpdates let totalnMatched = sum $ map nMatched onlyUpdates
let totalUpserted = concat $ map upserted onlyUpdates let totalUpserted = concat $ map upserted onlyUpdates
return $ UpdateResult totalnMatched Nothing totalUpserted onlyErrors Nothing return $ UpdateResult totalnMatched Nothing totalUpserted onlyErrors []
else do else do
mode <- asks mongoWriteMode mode <- asks mongoWriteMode
let writeConcern = case mode of let writeConcern = case mode of
@ -697,7 +699,7 @@ updateBlock ordered col (prevCount, docs) = do
Confirm params -> params Confirm params -> params
doc <- runCommand $ updateCommandDocument col ordered docs writeConcern doc <- runCommand $ updateCommandDocument col ordered docs writeConcern
let writeConcernError = do let writeConcernError = maybeToList $ do
wceDoc <- doc !? "writeConcernError" wceDoc <- doc !? "writeConcernError"
return $ docToWriteConcernError wceDoc return $ docToWriteConcernError wceDoc