Implement more careful processing of error codes
This commit is contained in:
Victor Denisov
parent
74e8aa205d
commit
29286fa2e0
1 changed files with 45 additions and 33 deletions
|
|
@ -150,7 +150,8 @@ type GetLastError = Document
|
|||
-- ^ Parameters for getLastError command. For example @[\"w\" =: 2]@ tells the server to wait for the write to reach at least two servers in replica set before acknowledging. See <http://www.mongodb.org/display/DOCS/Last+Error+Commands> for more options.
|
||||
|
||||
data UpdateResult = UpdateResult
|
||||
{ nMatched :: Int
|
||||
{ failed :: Bool
|
||||
, nMatched :: Int
|
||||
, nModified :: Maybe Int
|
||||
-- ^ 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]
|
||||
|
|
@ -653,7 +654,7 @@ update' ordered col updateDocs = do
|
|||
let totalWriteConcernErrors = concat $ map writeConcernErrors blocks
|
||||
|
||||
let upsertedTotal = concat $ map upserted blocks
|
||||
return $ UpdateResult updatedTotal modifiedTotal upsertedTotal totalWriteErrors totalWriteConcernErrors
|
||||
return $ UpdateResult False updatedTotal modifiedTotal upsertedTotal totalWriteErrors totalWriteConcernErrors -- TODO first False should be calculated intelligently
|
||||
|
||||
updateBlock :: (MonadIO m)
|
||||
=> Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult
|
||||
|
|
@ -661,37 +662,7 @@ updateBlock ordered col (prevCount, docs) = do
|
|||
p <- asks mongoPipe
|
||||
let sd = P.serverData p
|
||||
if (maxWireVersion sd < 2)
|
||||
then do
|
||||
db <- thisDatabase
|
||||
ctx <- ask
|
||||
results <-
|
||||
liftIO $ forM (zip [prevCount, (prevCount + 1) ..] docs) $ \(i, updateDoc) -> do
|
||||
let doc = (at "u" updateDoc) :: Document
|
||||
let sel = (at "q" updateDoc) :: Document
|
||||
let upsrt = if at "upsert" updateDoc then [Upsert] else []
|
||||
let multi = if at "multi" updateDoc then [MultiUpdate] else []
|
||||
mRes <- runReaderT (write (Update (db <.> col) (upsrt ++ multi) sel doc)) ctx
|
||||
case mRes of
|
||||
Nothing -> return $ Right $ UpdateResult 0 Nothing [] [] []
|
||||
Just resDoc -> do
|
||||
let em = lookup "err" resDoc
|
||||
case em of
|
||||
Nothing -> do
|
||||
let n = at "n" resDoc
|
||||
let ups = do
|
||||
upsValue <- lookup "upserted" resDoc
|
||||
return $ Upserted i upsValue
|
||||
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
|
||||
return $ Left $ WriteError i (at "code" resDoc) errV
|
||||
`catch` \(e :: SomeException) -> do
|
||||
when ordered $ liftIO $ throwIO e
|
||||
return $ Left $ WriteError i 0 (show e)
|
||||
let onlyErrors = lefts results
|
||||
let onlyUpdates = rights results
|
||||
let totalnMatched = sum $ map nMatched onlyUpdates
|
||||
let totalUpserted = concat $ map upserted onlyUpdates
|
||||
return $ UpdateResult totalnMatched Nothing totalUpserted onlyErrors []
|
||||
then updateBlockLegacy ordered col (prevCount, docs)
|
||||
else do
|
||||
mode <- asks mongoWriteMode
|
||||
let writeConcern = case mode of
|
||||
|
|
@ -706,12 +677,53 @@ updateBlock ordered col (prevCount, docs) = do
|
|||
let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors")
|
||||
let upsertedDocs = fromMaybe [] (doc !? "upserted")
|
||||
return $ UpdateResult
|
||||
False -- TODO it should be changed accordingly
|
||||
(at "n" doc)
|
||||
(at "nModified" doc)
|
||||
(map docToUpserted upsertedDocs)
|
||||
writeErrors
|
||||
writeConcernError
|
||||
|
||||
updateBlockLegacy :: (MonadIO m)
|
||||
=> Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult
|
||||
updateBlockLegacy ordered col (prevCount, docs) = do
|
||||
p <- asks mongoPipe
|
||||
db <- thisDatabase
|
||||
ctx <- ask
|
||||
results <-
|
||||
liftIO $ forM (zip [prevCount, (prevCount + 1) ..] docs) $ \(i, updateDoc) -> do
|
||||
let doc = (at "u" updateDoc) :: Document
|
||||
let sel = (at "q" updateDoc) :: Document
|
||||
let upsrt = if at "upsert" updateDoc then [Upsert] else []
|
||||
let multi = if at "multi" updateDoc then [MultiUpdate] else []
|
||||
mRes <- runReaderT (write (Update (db <.> col) (upsrt ++ multi) sel doc)) ctx
|
||||
case mRes of
|
||||
Nothing -> return $ Right $ UpdateResult False 0 Nothing [] [] []
|
||||
Just resDoc -> do
|
||||
let em = lookup "err" resDoc
|
||||
let eCode = lookup "code" resDoc
|
||||
case (em, eCode) of
|
||||
(Nothing, Nothing) -> do
|
||||
let n = at "n" resDoc
|
||||
let ups = do
|
||||
upsValue <- lookup "upserted" resDoc
|
||||
return $ Upserted i upsValue
|
||||
return $ Right $ UpdateResult False n Nothing (maybeToList ups) [] [] -- TODO add wtimeout checking. if there is timeout field then we need to add a WRITE_CONCERN_ERROR.
|
||||
(Just errV, Nothing) -> do
|
||||
return $ Left $ WriteError i 24 errV -- 24 - MONGOC_ERROR_COLLECTION_UPDATE_FAILED default error code
|
||||
(Nothing, Just ec) -> do
|
||||
return $ Left $ WriteError i ec "unknown error"
|
||||
(Just errV, Just ec) -> do
|
||||
return $ Left $ WriteError i ec errV
|
||||
`catch` \(e :: SomeException) -> do
|
||||
when ordered $ liftIO $ throwIO e
|
||||
return $ Left $ WriteError i 0 (show e)
|
||||
let onlyErrors = lefts results
|
||||
let onlyUpdates = rights results
|
||||
let totalnMatched = sum $ map nMatched onlyUpdates
|
||||
let totalUpserted = concat $ map upserted onlyUpdates
|
||||
return $ UpdateResult (length onlyErrors > 0) totalnMatched Nothing totalUpserted onlyErrors []
|
||||
|
||||
docToUpserted :: Document -> Upserted
|
||||
docToUpserted doc = Upserted ind uid
|
||||
where
|
||||
|
|
|
|||
Loading…
Reference in a new issue