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

Rename UpdateResult to WriteResult

Browse source 
Many fields of DeleteResult overlap with UpdateResult.
It's better to have only one result for all results, just
like it's done in c mongodb driver.
This commit is contained in:
Victor Denisov 2017-01-07 12:36:07 -08:00
parent 569d8ccc08
commit 09c05d4b69
1 changed files with 38 additions and 37 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

75
Database/MongoDB/Query.hs
View file

@ -22,9 +22,9 @@ module Database.MongoDB.Query (
insert, insert_, insertMany, insertMany_, insertAll, insertAll_, insert, insert_, insertMany, insertMany_, insertAll, insertAll_,
-- ** Update -- ** Update
save, replace, repsert, upsert, Modifier, modify, updateMany, updateAll, save, replace, repsert, upsert, Modifier, modify, updateMany, updateAll,
UpdateResult(..), UpdateOption(..), Upserted(..), WriteResult(..), UpdateOption(..), Upserted(..),
-- ** Delete -- ** Delete
delete, deleteOne, deleteMany, deleteAll, DeleteResult, DeleteOption(..), delete, deleteOne, deleteMany, deleteAll, DeleteOption(..),
-- * Read -- * Read
-- ** Query -- ** Query
Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial),
@ -47,7 +47,7 @@ module Database.MongoDB.Query (
) where ) where
import Prelude hiding (lookup) import Prelude hiding (lookup)
import Control.Exception (Exception, throwIO, throw) import Control.Exception (Exception, throwIO)
import Control.Monad (unless, replicateM, liftM, forM, forM_, liftM2) import Control.Monad (unless, replicateM, liftM, forM, forM_, liftM2)
import Data.Int (Int32, Int64) import Data.Int (Int32, Int64)
import Data.Either (lefts, rights) import Data.Either (lefts, rights)
@ -79,7 +79,6 @@ import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool),
Javascript, at, valueAt, lookup, look, genObjectId, (=:), Javascript, at, valueAt, lookup, look, genObjectId, (=:),
(=?), (!?), Val(..), ObjectId) (=?), (!?), Val(..), ObjectId)
import Data.Bson.Binary (putDocument) import Data.Bson.Binary (putDocument)
import Data.Maybe (fromJust, isJust)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -153,17 +152,18 @@ type GetLastError = Document
class Result a where class Result a where
isFailed :: a -> Bool isFailed :: a -> Bool
data UpdateResult = UpdateResult data WriteResult = WriteResult
{ failed :: Bool { failed :: Bool
, nMatched :: Int , nMatched :: Int
, nModified :: Maybe Int , nModified :: Maybe Int
, nRemoved :: 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. -- ^ 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 :: [Failure] , writeErrors :: [Failure]
, writeConcernErrors :: [WriteConcernError] , writeConcernErrors :: [WriteConcernError]
} deriving Show } deriving Show
instance Result UpdateResult where instance Result WriteResult where
isFailed = failed isFailed = failed
instance Result (Either a b) where instance Result (Either a b) where
@ -180,8 +180,6 @@ data WriteConcernError = WriteConcernError
, wceErrMsg :: String , wceErrMsg :: String
} deriving Show } deriving Show
data DeleteResult = DeleteResult
master :: AccessMode master :: AccessMode
-- ^ Same as 'ConfirmWrites' [] -- ^ Same as 'ConfirmWrites' []
master = ConfirmWrites [] master = ConfirmWrites []
@ -644,7 +642,7 @@ updateCommandDocument col ordered updates writeConcern =
updateMany :: (MonadIO m) updateMany :: (MonadIO m)
=> Collection => Collection
-> [(Selector, Document, [UpdateOption])] -> [(Selector, Document, [UpdateOption])]
-> Action m UpdateResult -> Action m WriteResult
updateMany = update' True updateMany = update' True
{-| Bulk update operation. If one update fails it will proceed with the {-| Bulk update operation. If one update fails it will proceed with the
@ -657,14 +655,14 @@ updateMany = update' True
updateAll :: (MonadIO m) updateAll :: (MonadIO m)
=> Collection => Collection
-> [(Selector, Document, [UpdateOption])] -> [(Selector, Document, [UpdateOption])]
-> Action m UpdateResult -> Action m WriteResult
updateAll = update' False updateAll = update' False
update' :: (MonadIO m) update' :: (MonadIO m)
=> Bool => Bool
-> Collection -> Collection
-> [(Selector, Document, [UpdateOption])] -> [(Selector, Document, [UpdateOption])]
-> Action m UpdateResult -> Action m WriteResult
update' ordered col updateDocs = do update' ordered col updateDocs = do
p <- asks mongoPipe p <- asks mongoPipe
let sd = P.serverData p let sd = P.serverData p
@ -702,7 +700,7 @@ update' ordered col updateDocs = do
ur <- runReaderT (updateBlock ordered col b) ctx ur <- runReaderT (updateBlock ordered col b) ctx
return ur return ur
`catch` \(e :: Failure) -> do `catch` \(e :: Failure) -> do
return $ UpdateResult True 0 Nothing [] [e] [] return $ WriteResult True 0 Nothing 0 [] [e] []
let failedTotal = or $ map failed blocks let failedTotal = or $ map failed blocks
let updatedTotal = sum $ map nMatched blocks let updatedTotal = sum $ map nMatched blocks
let modifiedTotal = let modifiedTotal =
@ -713,18 +711,19 @@ update' ordered col updateDocs = do
let totalWriteConcernErrors = concat $ map writeConcernErrors blocks let totalWriteConcernErrors = concat $ map writeConcernErrors blocks
let upsertedTotal = concat $ map upserted blocks let upsertedTotal = concat $ map upserted blocks
return $ UpdateResult return $ WriteResult
failedTotal failedTotal
updatedTotal updatedTotal
modifiedTotal modifiedTotal
0 -- nRemoved
upsertedTotal upsertedTotal
totalWriteErrors totalWriteErrors
totalWriteConcernErrors totalWriteConcernErrors
`catch` \(e :: Failure) -> return $ UpdateResult True 0 Nothing [] [e] [] `catch` \(e :: Failure) -> return $ WriteResult True 0 Nothing 0 [] [e] []
updateBlock :: (MonadIO m) updateBlock :: (MonadIO m)
=> Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult => Bool -> Collection -> (Int, [Document]) -> Action m WriteResult
updateBlock ordered col (prevCount, docs) = do updateBlock ordered col (prevCount, docs) = do
p <- asks mongoPipe p <- asks mongoPipe
let sd = P.serverData p let sd = P.serverData p
@ -742,10 +741,11 @@ updateBlock ordered col (prevCount, docs) = do
let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors") let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors")
let upsertedDocs = fromMaybe [] (doc !? "upserted") let upsertedDocs = fromMaybe [] (doc !? "upserted")
return $ UpdateResult return $ WriteResult
((not $ true1 "ok" doc) || (not $ null writeErrors) || (not $ null writeConcernErrors)) ((not $ true1 "ok" doc) || (not $ null writeErrors) || (not $ null writeConcernErrors))
(at "n" doc) (at "n" doc)
(at "nModified" doc) (at "nModified" doc)
0
(map docToUpserted upsertedDocs) (map docToUpserted upsertedDocs)
writeErrors writeErrors
writeConcernErrors writeConcernErrors
@ -762,7 +762,7 @@ interruptibleFor ordered = go []
else go (y:res) xs f else go (y:res) xs f
updateBlockLegacy :: (MonadIO m) updateBlockLegacy :: (MonadIO m)
=> Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult => Bool -> Collection -> (Int, [Document]) -> Action m WriteResult
updateBlockLegacy ordered col (prevCount, docs) = do updateBlockLegacy ordered col (prevCount, docs) = do
db <- thisDatabase db <- thisDatabase
ctx <- ask ctx <- ask
@ -774,7 +774,7 @@ 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 $ UpdateResult False 0 Nothing [] [] [] Nothing -> return $ WriteResult False 0 Nothing 0 [] [] []
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
@ -785,28 +785,29 @@ updateBlockLegacy 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 $ UpdateResult False n Nothing (maybeToList ups) [] [] return $ WriteResult False n Nothing 0 (maybeToList ups) [] []
else do else do
let defaultCode = if wtimeout then 64 else 24 let defaultCode = if wtimeout then 64 else 24
let errV = fromMaybe "unknown error" em let errV = fromMaybe "unknown error" em
let c = fromMaybe defaultCode eCode let c = fromMaybe defaultCode eCode
if wtimeout if wtimeout
then do then do
return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV] return $ WriteResult True 0 Nothing 0 [] [] [WriteConcernError c errV]
else do else do
return $ UpdateResult True 0 Nothing [] [WriteFailure i c errV] [] return $ WriteResult True 0 Nothing 0 [] [WriteFailure i c errV] []
`catch` \(e :: Failure) -> do `catch` \(e :: Failure) -> do
return $ UpdateResult True 0 Nothing [] [e] [] return $ WriteResult True 0 Nothing 0 [] [e] []
return $ foldl1' mergeUpdateResults results return $ foldl1' mergeWriteResults results
mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult mergeWriteResults :: WriteResult -> WriteResult -> WriteResult
mergeUpdateResults mergeWriteResults
(UpdateResult failed1 nMatched1 nModified1 upserted1 writeErrors1 writeConcernErrors1) (WriteResult failed1 nMatched1 nModified1 nDeleted1 upserted1 writeErrors1 writeConcernErrors1)
(UpdateResult failed2 nMatched2 nModified2 upserted2 writeErrors2 writeConcernErrors2) = (WriteResult failed2 nMatched2 nModified2 nDeleted2 upserted2 writeErrors2 writeConcernErrors2) =
(UpdateResult (WriteResult
(failed1 || failed2) (failed1 || failed2)
(nMatched1 + nMatched2) (nMatched1 + nMatched2)
((liftM2 (+)) nModified1 nModified2) ((liftM2 (+)) nModified1 nModified2)
(nDeleted1 + nDeleted2)
-- This function is used in foldl1' function. The first argument is the accumulator. -- This function is used in foldl1' function. The first argument is the accumulator.
-- The list in the accumulator is usually longer than the subsequent value which goes in the second argument. -- The list in the accumulator is usually longer than the subsequent value which goes in the second argument.
-- So, changing the order of list concatenation allows us to keep linear complexity of the -- So, changing the order of list concatenation allows us to keep linear complexity of the
@ -862,7 +863,7 @@ deleteHelper opts (Select sel col) = do
deleteMany :: (MonadIO m) deleteMany :: (MonadIO m)
=> Collection => Collection
-> [(Selector, [DeleteOption])] -> [(Selector, [DeleteOption])]
-> Action m DeleteResult -> Action m WriteResult
deleteMany = delete' True deleteMany = delete' True
{-| Bulk delete operation. If one delete fails it will proceed with the {-| Bulk delete operation. If one delete fails it will proceed with the
@ -873,7 +874,7 @@ deleteMany = delete' True
deleteAll :: (MonadIO m) deleteAll :: (MonadIO m)
=> Collection => Collection
-> [(Selector, [DeleteOption])] -> [(Selector, [DeleteOption])]
-> Action m DeleteResult -> Action m WriteResult
deleteAll = delete' False deleteAll = delete' False
deleteCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document deleteCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document
@ -888,7 +889,7 @@ delete' :: (MonadIO m)
=> Bool => Bool
-> Collection -> Collection
-> [(Selector, [DeleteOption])] -> [(Selector, [DeleteOption])]
-> Action m DeleteResult -> Action m WriteResult
delete' ordered col deleteDocs = do delete' ordered col deleteDocs = do
p <- asks mongoPipe p <- asks mongoPipe
let sd = P.serverData p let sd = P.serverData p
@ -915,11 +916,11 @@ delete' ordered col deleteDocs = do
if ordered if ordered
then takeRightsUpToLeft preChunks then takeRightsUpToLeft preChunks
else rights preChunks else rights preChunks
forM_ chunks (deleteBlock ordered col) blockResult <- forM chunks (deleteBlock ordered col)
return DeleteResult return $ foldl1' mergeWriteResults blockResult
deleteBlock :: (MonadIO m) deleteBlock :: (MonadIO m)
=> Bool -> Collection -> [Document] -> Action m () => Bool -> Collection -> [Document] -> Action m WriteResult
deleteBlock ordered col docs = do deleteBlock ordered col docs = do
p <- asks mongoPipe p <- asks mongoPipe
let sd = P.serverData p let sd = P.serverData p
@ -931,7 +932,7 @@ deleteBlock ordered col docs = do
liftIO $ forM docs $ \deleteDoc -> do liftIO $ forM docs $ \deleteDoc -> do
let sel = (at "q" deleteDoc) :: Document let sel = (at "q" deleteDoc) :: Document
let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else [] let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else []
_ <- runReaderT (write (Delete (db <.> col) opts sel)) ctx res <- runReaderT (write (Delete (db <.> col) opts sel)) ctx
return Nothing return Nothing
`catch` \(e :: SomeException) -> do `catch` \(e :: SomeException) -> do
when ordered $ liftIO $ throwIO e when ordered $ liftIO $ throwIO e
@ -939,7 +940,7 @@ deleteBlock ordered col docs = do
let onlyErrors = catMaybes errors let onlyErrors = catMaybes errors
if not $ null onlyErrors if not $ null onlyErrors
then liftIO $ throwIO $ WriteFailure 0 0 (show onlyErrors) -- TODO add normal index (first argument) then liftIO $ throwIO $ WriteFailure 0 0 (show onlyErrors) -- TODO add normal index (first argument)
else return () else return $ WriteResult False 0 Nothing 0 [] [] [] -- TODO to be fixed
else do else do
mode <- asks mongoWriteMode mode <- asks mongoWriteMode
let writeConcern = case mode of let writeConcern = case mode of
@ -947,7 +948,7 @@ deleteBlock ordered col docs = do
Confirm params -> params Confirm params -> params
doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern
case (look "writeErrors" doc, look "writeConcernError" doc) of case (look "writeErrors" doc, look "writeConcernError" doc) of
(Nothing, Nothing) -> return () (Nothing, Nothing) -> return $ WriteResult False 0 Nothing 0 [] [] []-- TODO to be fixed
(Just err, Nothing) -> do (Just err, Nothing) -> do
liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index
(maybe 0 id $ lookup "ok" doc) (maybe 0 id $ lookup "ok" doc)