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

Rewrite updateBlock

Browse source
This commit is contained in:
Victor Denisov 2017-05-01 19:57:43 -07:00
parent 1d6d6ca9c0
commit 4855793dd7
1 changed files with 48 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
Database/MongoDB/Query.hs
View file

@ -52,7 +52,7 @@ import Control.Monad (unless, replicateM, liftM, liftM2)
import Data.Int (Int32, Int64) import Data.Int (Int32, Int64)
import Data.Either (lefts, rights) import Data.Either (lefts, rights)
import Data.List (foldl1') import Data.List (foldl1')
import Data.Maybe (listToMaybe, catMaybes, isNothing, maybeToList) import Data.Maybe (listToMaybe, catMaybes, isNothing)
import Data.Word (Word32) import Data.Word (Word32)
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mappend) import Data.Monoid (mappend)
@ -742,20 +742,52 @@ updateBlock ordered col (prevCount, docs) = do
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
let writeConcernErrors = maybeToList $ do
wceDoc <- doc !? "writeConcernError"
return $ docToWriteConcernError wceDoc
let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors") let n = fromMaybe 0 $ doc !? "n"
let upsertedDocs = fromMaybe [] (doc !? "upserted") let writeErrorsResults =
return $ WriteResult case look "writeErrors" doc of
((not $ true1 "ok" doc) || (not $ null writeErrors) || (not $ null writeConcernErrors)) Nothing -> WriteResult False 0 Nothing n [] [] []
(at "n" doc) Just (Array err) -> WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) []
(at "nModified" doc) Just unknownErr -> WriteResult
0 True
(map docToUpserted upsertedDocs) 0
(map (addFailureIndex prevCount) writeErrors) Nothing
writeConcernErrors n
[]
[ ProtocolFailure
prevCount
$ "Expected array of error docs, but received: "
++ (show unknownErr)]
[]
let writeConcernResults =
case look "writeConcernError" doc of
Nothing -> WriteResult False 0 Nothing n [] [] []
Just (Doc err) -> WriteResult
True
0
Nothing
n
[]
[]
[ WriteConcernFailure
(fromMaybe (-1) $ err !? "code")
(fromMaybe "" $ err !? "errmsg")
]
Just unknownErr -> WriteResult
True
0
Nothing
n
[]
[]
[ ProtocolFailure
prevCount
$ "Expected doc in writeConcernError, but received: "
++ (show unknownErr)]
let upsertedList = map docToUpserted $ fromMaybe [] (doc !? "upserted")
return $ mergeWriteResults writeErrorsResults writeConcernResults {upserted = upsertedList, nModified = at "nModified" doc}
interruptibleFor :: (Monad m, Result b) => Bool -> [a] -> (a -> m b) -> m [b] interruptibleFor :: (Monad m, Result b) => Bool -> [a] -> (a -> m b) -> m [b]
@ -800,12 +832,6 @@ docToWriteError doc = WriteFailure ind code msg
code = at "code" doc code = at "code" doc
msg = at "errmsg" doc msg = at "errmsg" doc
docToWriteConcernError :: Document -> Failure
docToWriteConcernError doc = WriteConcernFailure code msg
where
code = at "code" doc
msg = at "errmsg" doc
-- ** Delete -- ** Delete
delete :: (MonadIO m) delete :: (MonadIO m)
@ -958,8 +984,8 @@ deleteBlock ordered col (prevCount, docs) = do
return $ mergeWriteResults writeErrorsResults writeConcernResults return $ mergeWriteResults writeErrorsResults writeConcernResults
anyToWriteError :: Int -> Value -> Failure anyToWriteError :: Int -> Value -> Failure
anyToWriteError ind (Doc d) = docToWriteError d anyToWriteError _ (Doc d) = docToWriteError d
anyToWriteError ind _ = WriteFailure ind (-1) "Unknown bson value" anyToWriteError ind _ = ProtocolFailure ind "Unknown bson value"
-- * Read -- * Read