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

Add WriteConcernError to UpdateResult

Browse source
This commit is contained in:
Victor Denisov 2016-08-23 23:44:15 -07:00
parent 10675a0673
commit b6fa6ea402
1 changed files with 21 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
Database/MongoDB/Query.hs
View file

@ -155,6 +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
} deriving Show } deriving Show
data Upserted = Upserted data Upserted = Upserted
@ -162,6 +163,11 @@ data Upserted = Upserted
, upsertedId :: ObjectId , upsertedId :: ObjectId
} deriving Show } deriving Show
data WriteConcernError = WriteConcernError
{ wceCode :: Int
, wceErrMsg :: Int
} deriving Show
data WriteError = WriteError data WriteError = WriteError
{ errIndex :: Int { errIndex :: Int
, errCode :: Int , errCode :: Int
@ -645,7 +651,7 @@ update' ordered col updateDocs = do
else Just $ sum $ catMaybes $ map nModified blocks else Just $ sum $ catMaybes $ map nModified blocks
let upsertedTotal = concat $ map upserted blocks let upsertedTotal = concat $ map upserted blocks
return $ UpdateResult updatedTotal modifiedTotal upsertedTotal [] return $ UpdateResult updatedTotal modifiedTotal upsertedTotal [] Nothing -- TODO change Nothing to Something
updateBlock :: (MonadIO m) updateBlock :: (MonadIO m)
=> Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult
@ -664,7 +670,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 -> return $ Right $ UpdateResult 0 Nothing [] [] Nothing
Just resDoc -> do Just resDoc -> do
let em = lookup "err" resDoc let em = lookup "err" resDoc
case em of case em of
@ -673,7 +679,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) [] return $ Right $ UpdateResult n Nothing (maybeToList ups) [] Nothing
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
@ -683,19 +689,17 @@ 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 return $ UpdateResult totalnMatched Nothing totalUpserted onlyErrors Nothing
else do else do
mode <- asks mongoWriteMode mode <- asks mongoWriteMode
let writeConcern = case mode of let writeConcern = case mode of
NoConfirm -> ["w" =: (0 :: Int)] NoConfirm -> ["w" =: (0 :: Int)]
Confirm params -> params Confirm params -> params
doc <- runCommand $ updateCommandDocument col ordered docs writeConcern doc <- runCommand $ updateCommandDocument col ordered docs writeConcern
case look "writeConcernError" doc of
Nothing -> return () let writeConcernError = do
Just err -> do wceDoc <- doc !? "writeConcernError"
liftIO $ throwIO $ WriteFailure return $ docToWriteConcernError wceDoc
(maybe 0 id $ lookup "ok" doc)
(show err)
let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors") let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors")
let upsertedDocs = fromMaybe [] (doc !? "upserted") let upsertedDocs = fromMaybe [] (doc !? "upserted")
@ -704,6 +708,7 @@ updateBlock ordered col (prevCount, docs) = do
(at "nModified" doc) (at "nModified" doc)
(map docToUpserted upsertedDocs) (map docToUpserted upsertedDocs)
writeErrors writeErrors
writeConcernError
docToUpserted :: Document -> Upserted docToUpserted :: Document -> Upserted
docToUpserted doc = Upserted ind uid docToUpserted doc = Upserted ind uid
@ -718,6 +723,12 @@ docToWriteError doc = WriteError ind code msg
code = at "code" doc code = at "code" doc
msg = at "errmsg" doc msg = at "errmsg" doc
docToWriteConcernError :: Document -> WriteConcernError
docToWriteConcernError doc = WriteConcernError code msg
where
code = at "code" doc
msg = at "errmsg" doc
-- ** Delete -- ** Delete
delete :: (MonadIO m) delete :: (MonadIO m)