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

Process legacy command as in mongoc

Browse source
This commit is contained in:
Victor Denisov 2016-09-13 22:32:13 -07:00
parent 29286fa2e0
commit da0441d454
1 changed files with 33 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
Database/MongoDB/Query.hs
View file

@ -48,8 +48,9 @@ module Database.MongoDB.Query (
import Prelude hiding (lookup) import Prelude hiding (lookup)
import Control.Exception (Exception, throwIO, throw) import Control.Exception (Exception, throwIO, throw)
import Control.Monad (unless, replicateM, liftM, forM, forM_) import Control.Monad (unless, replicateM, liftM, forM, forM_, liftM2)
import Data.Int (Int32, Int64) import Data.Int (Int32, Int64)
import Data.List (foldl1')
import Data.Maybe (listToMaybe, catMaybes, isNothing, maybeToList) import Data.Maybe (listToMaybe, catMaybes, isNothing, maybeToList)
import Data.Word (Word32) import Data.Word (Word32)
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -166,7 +167,7 @@ data Upserted = Upserted
data WriteConcernError = WriteConcernError data WriteConcernError = WriteConcernError
{ wceCode :: Int { wceCode :: Int
, wceErrMsg :: Int , wceErrMsg :: String
} deriving Show } deriving Show
data WriteError = WriteError data WriteError = WriteError
@ -698,31 +699,45 @@ updateBlockLegacy 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 False 0 Nothing [] [] [] Nothing -> return $ UpdateResult False 0 Nothing [] [] []
Just resDoc -> do Just resDoc -> do
let em = lookup "err" resDoc let em = lookup "err" resDoc
let eCode = lookup "code" resDoc let eCode = lookup "code" resDoc
case (em, eCode) of let wtimeout = fromMaybe False $ lookup "wtimeout" resDoc
(Nothing, Nothing) -> do if isNothing em && isNothing eCode
then do
let n = at "n" resDoc let n = at "n" resDoc
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 False n Nothing (maybeToList ups) [] [] -- TODO add wtimeout checking. if there is timeout field then we need to add a WRITE_CONCERN_ERROR. return $ UpdateResult False n Nothing (maybeToList ups) [] []
(Just errV, Nothing) -> do else do
return $ Left $ WriteError i 24 errV -- 24 - MONGOC_ERROR_COLLECTION_UPDATE_FAILED default error code let defaultCode = if wtimeout then 64 else 24
(Nothing, Just ec) -> do let errV = fromMaybe "unknown error" em
return $ Left $ WriteError i ec "unknown error" let c = fromMaybe defaultCode eCode
(Just errV, Just ec) -> do if wtimeout
return $ Left $ WriteError i ec errV then do
return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV]
else do
return $ UpdateResult True 0 Nothing [] [WriteError i c errV] []
`catch` \(e :: SomeException) -> do `catch` \(e :: SomeException) -> do
when ordered $ liftIO $ throwIO e when ordered $ liftIO $ throwIO e
return $ Left $ WriteError i 0 (show e) return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] []
let onlyErrors = lefts results return $ foldl1' mergeUpdateResults results
let onlyUpdates = rights results
let totalnMatched = sum $ map nMatched onlyUpdates mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult
let totalUpserted = concat $ map upserted onlyUpdates mergeUpdateResults
return $ UpdateResult (length onlyErrors > 0) totalnMatched Nothing totalUpserted onlyErrors [] (UpdateResult failed1 nMatched1 nModified1 upserted1 writeErrors1 writeConcernErrors1)
(UpdateResult failed2 nMatched2 nModified2 upserted2 writeErrors2 writeConcernErrors2) =
(UpdateResult
(failed1 || failed2)
(nMatched1 + nMatched2)
((liftM2 (+)) nModified1 nModified2)
(upserted1 ++ upserted2)
(writeErrors1 ++ writeErrors2)
(writeConcernErrors1 ++ writeConcernErrors2)
)
docToUpserted :: Document -> Upserted docToUpserted :: Document -> Upserted
docToUpserted doc = Upserted ind uid docToUpserted doc = Upserted ind uid