From 399e2c3443eafeb01cb0b418a508d44f90ba3950 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Wed, 20 Jul 2016 00:46:16 -0700 Subject: [PATCH 01/49] Return update result for old versions of mongodb --- Database/MongoDB/Query.hs | 92 ++++++++++++++++++++++++++++++--------- 1 file changed, 72 insertions(+), 20 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 1f580dc..c8a787e 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -50,7 +50,7 @@ import Prelude hiding (lookup) import Control.Exception (Exception, throwIO, throw) import Control.Monad (unless, replicateM, liftM, forM, forM_) import Data.Int (Int32, Int64) -import Data.Maybe (listToMaybe, catMaybes, isNothing) +import Data.Maybe (listToMaybe, catMaybes, isNothing, maybeToList) import Data.Word (Word32) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mappend) @@ -75,8 +75,10 @@ import Control.Monad.Trans.Control (MonadBaseControl(..)) import Data.Binary.Put (runPut) import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), Javascript, at, valueAt, lookup, look, genObjectId, (=:), - (=?), (!?), Val(..)) + (=?), (!?), Val(..), ObjectId) import Data.Bson.Binary (putDocument) +import Data.Either (lefts, rights) +import Data.Maybe (fromJust, isJust) import Data.Text (Text) import qualified Data.Text as T @@ -148,6 +150,22 @@ 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 for more options. data UpdateResult = UpdateResult + { nMatched :: Int + , nModified :: Maybe Int -- Mongodb server before 2.6 doesn't allow to calculate this value. It's Nothing if we fail to do so + , upserted :: [Upserted] + , writeErrors :: [WriteError] + } deriving Show + +data Upserted = Upserted + { upsertedIndex :: Int + , upsertedId :: ObjectId + } deriving Show + +data WriteError = WriteError + { errIndex :: Int + , errCode :: Int + , errMsg :: String + } deriving Show data DeleteResult = DeleteResult @@ -371,12 +389,13 @@ data WriteMode = | Confirm GetLastError -- ^ Receive an acknowledgment after every write, and raise exception if one says the write failed. This is acomplished by sending the getLastError command, with given 'GetLastError' parameters, after every write. deriving (Show, Eq) -write :: Notice -> Action IO () +write :: Notice -> Action IO (Maybe Document) -- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error. write notice = asks mongoWriteMode >>= \mode -> case mode of NoConfirm -> do pipe <- asks mongoPipe liftIOE ConnectionFailure $ P.send pipe [notice] + return Nothing Confirm params -> do let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd" pipe <- asks mongoPipe @@ -384,9 +403,7 @@ write notice = asks mongoWriteMode >>= \mode -> case mode of r <- queryRequest False q {limit = 1} rr <- liftIO $ request pipe [notice] r fulfill rr - case lookup "err" doc of - Nothing -> return () - Just err -> liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "code" doc) err + return $ Just doc -- ** Insert @@ -456,7 +473,11 @@ insertBlock opts col docs = do let sd = P.serverData p if (maxWireVersion sd < 2) then do - liftDB $ write (Insert (db <.> col) opts docs') + res <- liftDB $ write (Insert (db <.> col) opts docs') + when (isJust res) $ do + let jRes = fromJust res + let e = lookup "err" jRes + when (isJust e) $ liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "code" jRes) (fromJust e) return $ map (valueAt "_id") docs' else do mode <- asks mongoWriteMode @@ -612,33 +633,55 @@ update' ordered col updateDocs = do -- the overall size (maxWriteBatchSize sd) updates - forM_ chunks (updateBlock ordered col) - return UpdateResult + let lens = map length chunks + let lSums = 0 : (zipWith (+) lSums lens) + blocks <- forM (zip lSums chunks) (updateBlock ordered col) -- TODO update block can throw exception which will cause other blocks to fail. It's important when ordered is false + let updatedTotal = sum $ map nMatched blocks + let modifiedTotal = + if all isNothing $ map nModified blocks + then Nothing + else Just $ sum $ catMaybes $ map nModified blocks + + let upsertedTotal = concat $ map upserted blocks + return $ UpdateResult updatedTotal modifiedTotal upsertedTotal [] updateBlock :: (MonadIO m) - => Bool -> Collection -> [Document] -> Action m () -updateBlock ordered col docs = do + => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult +updateBlock ordered col (prevCount, docs) = do p <- asks mongoPipe let sd = P.serverData p if (maxWireVersion sd < 2) then do db <- thisDatabase ctx <- ask - errors <- - liftIO $ forM docs $ \updateDoc -> do + 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 [] - runReaderT (write (Update (db <.> col) (upsrt ++ multi) sel doc)) ctx - return Nothing + 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) [] + Just errV -> do + return $ Left $ WriteError i (at "code" resDoc) errV `catch` \(e :: SomeException) -> do when ordered $ liftIO $ throwIO e - return $ Just e - let onlyErrors = catMaybes errors - if not $ null onlyErrors - then liftIO $ throwIO $ WriteFailure 0 (show onlyErrors) - else return () + 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 else do mode <- asks mongoWriteMode let writeConcern = case mode of @@ -660,6 +703,15 @@ updateBlock ordered col docs = do (maybe 0 id $ lookup "ok" doc) (show err ++ show writeConcernErr) + let upsertedDocs = fromMaybe [] (doc !? "upserted") + return $ UpdateResult (at "n" doc) (at "nModified" doc) (map docToUpserted upsertedDocs) [] + +docToUpserted :: Document -> Upserted +docToUpserted doc = Upserted ind uid + where + ind = at "index" doc + uid = at "_id" doc + -- ** Delete delete :: (MonadIO m) From 58127532178bc36133d901d8032a6f20cb76bde3 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 22 Aug 2016 21:24:06 -0700 Subject: [PATCH 02/49] Add more documentation --- Database/MongoDB/Query.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index c8a787e..e8c316d 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -22,7 +22,7 @@ module Database.MongoDB.Query ( insert, insert_, insertMany, insertMany_, insertAll, insertAll_, -- ** Update save, replace, repsert, upsert, Modifier, modify, updateMany, updateAll, - UpdateResult, UpdateOption(..), + UpdateResult(..), UpdateOption(..), Upserted(..), -- ** Delete delete, deleteOne, deleteMany, deleteAll, DeleteResult, DeleteOption(..), -- * Read @@ -151,7 +151,8 @@ type GetLastError = Document data UpdateResult = UpdateResult { nMatched :: Int - , nModified :: Maybe Int -- Mongodb server before 2.6 doesn't allow to calculate this value. It's Nothing if we fail to do so + , 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] , writeErrors :: [WriteError] } deriving Show From 52547937679e500d4c0e93ed2e6f2cea4aae5997 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 22 Aug 2016 21:36:10 -0700 Subject: [PATCH 03/49] Throw exceptions in case of single document updates --- Database/MongoDB/Query.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index e8c316d..77a4049 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -574,8 +574,10 @@ update :: (MonadIO m) => [UpdateOption] -> Selection -> Document -> Action m () -- ^ Update first document in selection using updater document, unless 'MultiUpdate' option is supplied then update all documents in selection. If 'Upsert' option is supplied then treat updater as document and insert it if selection is empty. update opts (Select sel col) up = do - _ <- update' True col [(sel, up, opts)] - return () + res <- update' True col [(sel, up, opts)] + if not $ null $ writeErrors res + then liftIO $ throwIO $ WriteFailure 0 (show $ head $ writeErrors res) + else return () updateCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document updateCommandDocument col ordered updates writeConcern = From 10675a06733253e4798d14476a8260bc1c9b5a0f Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 22 Aug 2016 22:50:00 -0700 Subject: [PATCH 04/49] Report errors in UpdateResult instead of Exceptions --- Database/MongoDB/Query.hs | 33 ++++++++++++++++++--------------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 77a4049..797e6d3 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -599,9 +599,8 @@ updateMany :: (MonadIO m) updateMany = update' True {-| Bulk update operation. If one update fails it will proceed with the - - remaining documents. Current returned value is only a place holder. With - - mongodb server before 2.6 it will send update requests one by one. After 2.6 - - it will use bulk update feature in mongodb. + - remaining documents. With mongodb server before 2.6 it will send update + - requests one by one. After 2.6 it will use bulk update feature in mongodb. -} updateAll :: (MonadIO m) => Collection @@ -691,23 +690,20 @@ updateBlock ordered col (prevCount, docs) = do NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params doc <- runCommand $ updateCommandDocument col ordered docs writeConcern - case (look "writeErrors" doc, look "writeConcernError" doc) of - (Nothing, Nothing) -> return () - (Just err, Nothing) -> do + case look "writeConcernError" doc of + Nothing -> return () + Just err -> do liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "ok" doc) (show err) - (Nothing, Just err) -> do - liftIO $ throwIO $ WriteFailure - (maybe 0 id $ lookup "ok" doc) - (show err) - (Just err, Just writeConcernErr) -> do - liftIO $ throwIO $ WriteFailure - (maybe 0 id $ lookup "ok" doc) - (show err ++ show writeConcernErr) + let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors") let upsertedDocs = fromMaybe [] (doc !? "upserted") - return $ UpdateResult (at "n" doc) (at "nModified" doc) (map docToUpserted upsertedDocs) [] + return $ UpdateResult + (at "n" doc) + (at "nModified" doc) + (map docToUpserted upsertedDocs) + writeErrors docToUpserted :: Document -> Upserted docToUpserted doc = Upserted ind uid @@ -715,6 +711,13 @@ docToUpserted doc = Upserted ind uid ind = at "index" doc uid = at "_id" doc +docToWriteError :: Document -> WriteError +docToWriteError doc = WriteError ind code msg + where + ind = at "index" doc + code = at "code" doc + msg = at "errmsg" doc + -- ** Delete delete :: (MonadIO m) From b6fa6ea4025ed6a0a62daf4a5bd850015a17a3eb Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Tue, 23 Aug 2016 23:44:15 -0700 Subject: [PATCH 05/49] Add WriteConcernError to UpdateResult --- Database/MongoDB/Query.hs | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 797e6d3..44ef299 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -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. , upserted :: [Upserted] , writeErrors :: [WriteError] + , writeConcernError :: Maybe WriteConcernError } deriving Show data Upserted = Upserted @@ -162,6 +163,11 @@ data Upserted = Upserted , upsertedId :: ObjectId } deriving Show +data WriteConcernError = WriteConcernError + { wceCode :: Int + , wceErrMsg :: Int + } deriving Show + data WriteError = WriteError { errIndex :: Int , errCode :: Int @@ -645,7 +651,7 @@ update' ordered col updateDocs = do else Just $ sum $ catMaybes $ map nModified 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) => 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 [] mRes <- runReaderT (write (Update (db <.> col) (upsrt ++ multi) sel doc)) ctx case mRes of - Nothing -> return $ Right $ UpdateResult 0 Nothing [] [] + Nothing -> return $ Right $ UpdateResult 0 Nothing [] [] Nothing Just resDoc -> do let em = lookup "err" resDoc case em of @@ -673,7 +679,7 @@ updateBlock ordered col (prevCount, docs) = do let ups = do upsValue <- lookup "upserted" resDoc return $ Upserted i upsValue - return $ Right $ UpdateResult n Nothing (maybeToList ups) [] + return $ Right $ UpdateResult n Nothing (maybeToList ups) [] Nothing Just errV -> do return $ Left $ WriteError i (at "code" resDoc) errV `catch` \(e :: SomeException) -> do @@ -683,19 +689,17 @@ updateBlock ordered col (prevCount, docs) = do let onlyUpdates = rights results let totalnMatched = sum $ map nMatched onlyUpdates let totalUpserted = concat $ map upserted onlyUpdates - return $ UpdateResult totalnMatched Nothing totalUpserted onlyErrors + return $ UpdateResult totalnMatched Nothing totalUpserted onlyErrors Nothing else do mode <- asks mongoWriteMode let writeConcern = case mode of NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params doc <- runCommand $ updateCommandDocument col ordered docs writeConcern - case look "writeConcernError" doc of - Nothing -> return () - Just err -> do - liftIO $ throwIO $ WriteFailure - (maybe 0 id $ lookup "ok" doc) - (show err) + + let writeConcernError = do + wceDoc <- doc !? "writeConcernError" + return $ docToWriteConcernError wceDoc let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors") let upsertedDocs = fromMaybe [] (doc !? "upserted") @@ -704,6 +708,7 @@ updateBlock ordered col (prevCount, docs) = do (at "nModified" doc) (map docToUpserted upsertedDocs) writeErrors + writeConcernError docToUpserted :: Document -> Upserted docToUpserted doc = Upserted ind uid @@ -718,6 +723,12 @@ docToWriteError doc = WriteError ind code msg code = at "code" doc msg = at "errmsg" doc +docToWriteConcernError :: Document -> WriteConcernError +docToWriteConcernError doc = WriteConcernError code msg + where + code = at "code" doc + msg = at "errmsg" doc + -- ** Delete delete :: (MonadIO m) From 74e8aa205d52effabb8e46ff8e05029d50b3acaa Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Thu, 25 Aug 2016 23:00:30 -0700 Subject: [PATCH 06/49] Keep write concern errors in list --- Database/MongoDB/Query.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 44ef299..271aff8 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -155,7 +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. , upserted :: [Upserted] , writeErrors :: [WriteError] - , writeConcernError :: Maybe WriteConcernError + , writeConcernErrors :: [WriteConcernError] } deriving Show data Upserted = Upserted @@ -649,9 +649,11 @@ update' ordered col updateDocs = do if all isNothing $ map nModified blocks then Nothing else Just $ sum $ catMaybes $ map nModified blocks + let totalWriteErrors = concat $ map writeErrors blocks + let totalWriteConcernErrors = concat $ map writeConcernErrors blocks let upsertedTotal = concat $ map upserted blocks - return $ UpdateResult updatedTotal modifiedTotal upsertedTotal [] Nothing -- TODO change Nothing to Something + return $ UpdateResult updatedTotal modifiedTotal upsertedTotal totalWriteErrors totalWriteConcernErrors updateBlock :: (MonadIO m) => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult @@ -670,7 +672,7 @@ updateBlock ordered col (prevCount, docs) = do 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 [] [] Nothing + Nothing -> return $ Right $ UpdateResult 0 Nothing [] [] [] Just resDoc -> do let em = lookup "err" resDoc case em of @@ -679,7 +681,7 @@ updateBlock ordered col (prevCount, docs) = do let ups = do upsValue <- lookup "upserted" resDoc return $ Upserted i upsValue - return $ Right $ UpdateResult n Nothing (maybeToList ups) [] Nothing + 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 @@ -689,7 +691,7 @@ updateBlock ordered col (prevCount, docs) = do let onlyUpdates = rights results let totalnMatched = sum $ map nMatched onlyUpdates let totalUpserted = concat $ map upserted onlyUpdates - return $ UpdateResult totalnMatched Nothing totalUpserted onlyErrors Nothing + return $ UpdateResult totalnMatched Nothing totalUpserted onlyErrors [] else do mode <- asks mongoWriteMode let writeConcern = case mode of @@ -697,7 +699,7 @@ updateBlock ordered col (prevCount, docs) = do Confirm params -> params doc <- runCommand $ updateCommandDocument col ordered docs writeConcern - let writeConcernError = do + let writeConcernError = maybeToList $ do wceDoc <- doc !? "writeConcernError" return $ docToWriteConcernError wceDoc From 29286fa2e0d5e55c783abde1e14fe9cfbe396f92 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Thu, 8 Sep 2016 21:23:51 -0700 Subject: [PATCH 07/49] Implement more careful processing of error codes --- Database/MongoDB/Query.hs | 78 ++++++++++++++++++++++----------------- 1 file changed, 45 insertions(+), 33 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 271aff8..c3771cf 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -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 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 From da0441d454bf072ad8f62a2de09175f228e00159 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Tue, 13 Sep 2016 22:32:13 -0700 Subject: [PATCH 08/49] Process legacy command as in mongoc --- Database/MongoDB/Query.hs | 51 +++++++++++++++++++++++++-------------- 1 file changed, 33 insertions(+), 18 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index c3771cf..f39b6e2 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -48,8 +48,9 @@ module Database.MongoDB.Query ( import Prelude hiding (lookup) 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.List (foldl1') import Data.Maybe (listToMaybe, catMaybes, isNothing, maybeToList) import Data.Word (Word32) #if !MIN_VERSION_base(4,8,0) @@ -166,7 +167,7 @@ data Upserted = Upserted data WriteConcernError = WriteConcernError { wceCode :: Int - , wceErrMsg :: Int + , wceErrMsg :: String } deriving Show data WriteError = WriteError @@ -698,31 +699,45 @@ updateBlockLegacy ordered col (prevCount, docs) = do 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 [] [] [] + Nothing -> return $ 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 wtimeout = fromMaybe False $ lookup "wtimeout" resDoc + if isNothing em && isNothing eCode + then 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 + return $ UpdateResult False n Nothing (maybeToList ups) [] [] + else do + let defaultCode = if wtimeout then 64 else 24 + let errV = fromMaybe "unknown error" em + let c = fromMaybe defaultCode eCode + if wtimeout + 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 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 [] + return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] [] + return $ foldl1' mergeUpdateResults results + +mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult +mergeUpdateResults + (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 doc = Upserted ind uid From 1898928cf08b76202d803461185e76cd83a323de Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 10 Oct 2016 22:26:04 -0700 Subject: [PATCH 09/49] Calculate filed total of update command --- Database/MongoDB/Query.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index f39b6e2..1f5dfc2 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -78,7 +78,6 @@ import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), Javascript, at, valueAt, lookup, look, genObjectId, (=:), (=?), (!?), Val(..), ObjectId) import Data.Bson.Binary (putDocument) -import Data.Either (lefts, rights) import Data.Maybe (fromJust, isJust) import Data.Text (Text) import qualified Data.Text as T @@ -504,7 +503,7 @@ insertBlock opts col docs = do liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "ok" doc) (show err) - (Just err, Just writeConcernErr) -> do + (Just err, Just writeConcernErr) -> do -- TODO writeConcernError is not a failure liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "ok" doc) (show err ++ show writeConcernErr) @@ -646,6 +645,7 @@ update' ordered col updateDocs = do let lens = map length chunks let lSums = 0 : (zipWith (+) lSums lens) blocks <- forM (zip lSums chunks) (updateBlock ordered col) -- TODO update block can throw exception which will cause other blocks to fail. It's important when ordered is false + let failedTotal = or $ map failed blocks let updatedTotal = sum $ map nMatched blocks let modifiedTotal = if all isNothing $ map nModified blocks @@ -655,7 +655,7 @@ update' ordered col updateDocs = do let totalWriteConcernErrors = concat $ map writeConcernErrors blocks let upsertedTotal = concat $ map upserted blocks - return $ UpdateResult False updatedTotal modifiedTotal upsertedTotal totalWriteErrors totalWriteConcernErrors -- TODO first False should be calculated intelligently + return $ UpdateResult failedTotal updatedTotal modifiedTotal upsertedTotal totalWriteErrors totalWriteConcernErrors updateBlock :: (MonadIO m) => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult @@ -688,7 +688,6 @@ updateBlock ordered col (prevCount, docs) = do updateBlockLegacy :: (MonadIO m) => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult updateBlockLegacy ordered col (prevCount, docs) = do - p <- asks mongoPipe db <- thisDatabase ctx <- ask results <- From 6fe3cd982d75cc2e6129b2720f374175864b57c1 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 10 Oct 2016 23:36:22 -0700 Subject: [PATCH 10/49] Fix unit tests updateMany and updateAll don't throw exceptions. They return UpdateResult which reports errors. --- Database/MongoDB/Query.hs | 3 +-- test/QuerySpec.hs | 38 ++++++++++++++++++++------------------ 2 files changed, 21 insertions(+), 20 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 1f5dfc2..5c775a2 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -670,7 +670,6 @@ updateBlock ordered col (prevCount, docs) = do NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params doc <- runCommand $ updateCommandDocument col ordered docs writeConcern - let writeConcernError = maybeToList $ do wceDoc <- doc !? "writeConcernError" return $ docToWriteConcernError wceDoc @@ -678,7 +677,7 @@ 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 + ((not $ true1 "ok" doc) || (length writeErrors > 0)) (at "n" doc) (at "nModified" doc) (map docToUpserted upsertedDocs) diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index bf274ec..728fd01 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -250,15 +250,16 @@ spec = around withCleanDatabase $ do it "can process different updates" $ do _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American", "score" =: (Nothing :: Maybe Int)] _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB", "score" =: (1 :: Int)] - (db $ updateMany "team" [ ( ["name" =: "Yankees"] - , ["$inc" =: ["score" =: (1 :: Int)]] - , [] - ) - , ( ["name" =: "Giants"] - , ["$inc" =: ["score" =: (2 :: Int)]] - , [] - ) - ]) `shouldThrow` anyException + updateResult <- (db $ updateMany "team" [ ( ["name" =: "Yankees"] + , ["$inc" =: ["score" =: (1 :: Int)]] + , [] + ) + , ( ["name" =: "Giants"] + , ["$inc" =: ["score" =: (2 :: Int)]] + , [] + ) + ]) + failed updateResult `shouldBe` True updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (1 :: Int)] @@ -280,15 +281,16 @@ spec = around withCleanDatabase $ do it "can process different updates" $ do _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American", "score" =: (Nothing :: Maybe Int)] _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB", "score" =: (1 :: Int)] - (db $ updateAll "team" [ ( ["name" =: "Yankees"] - , ["$inc" =: ["score" =: (1 :: Int)]] - , [] - ) - , ( ["name" =: "Giants"] - , ["$inc" =: ["score" =: (2 :: Int)]] - , [] - ) - ]) `shouldThrow` anyException + updateResult <- (db $ updateAll "team" [ ( ["name" =: "Yankees"] + , ["$inc" =: ["score" =: (1 :: Int)]] + , [] + ) + , ( ["name" =: "Giants"] + , ["$inc" =: ["score" =: (2 :: Int)]] + , [] + ) + ]) + failed updateResult `shouldBe` True updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (3 :: Int)] From 692cdb94c7ccab0aa8aa7240b3756ce8dd524c00 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Tue, 11 Oct 2016 23:31:16 -0700 Subject: [PATCH 11/49] Mark update command as failed if there are write concern errors --- Database/MongoDB/Query.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 5c775a2..a9d60bb 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -677,7 +677,7 @@ updateBlock ordered col (prevCount, docs) = do let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors") let upsertedDocs = fromMaybe [] (doc !? "upserted") return $ UpdateResult - ((not $ true1 "ok" doc) || (length writeErrors > 0)) + ((not $ true1 "ok" doc) || (not $ null writeErrors) || (not $ null writeConcernErrors)) (at "n" doc) (at "nModified" doc) (map docToUpserted upsertedDocs) From f81d5ec42e8b1e5ff219447801e9d674224ffaff Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Fri, 21 Oct 2016 00:42:38 -0700 Subject: [PATCH 12/49] Handle exceptions in updateBlock --- Database/MongoDB/Query.hs | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index a9d60bb..140385f 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -78,6 +78,7 @@ import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), Javascript, at, valueAt, lookup, look, genObjectId, (=:), (=?), (!?), Val(..), ObjectId) import Data.Bson.Binary (putDocument) +import Data.IORef (newIORef, writeIORef, readIORef) import Data.Maybe (fromJust, isJust) import Data.Text (Text) import qualified Data.Text as T @@ -644,7 +645,17 @@ update' ordered col updateDocs = do updates let lens = map length chunks let lSums = 0 : (zipWith (+) lSums lens) - blocks <- forM (zip lSums chunks) (updateBlock ordered col) -- TODO update block can throw exception which will cause other blocks to fail. It's important when ordered is false + exceptionThrown <- liftIO $ newIORef False + blocks <- forM (zip lSums chunks) $ \b -> do + ctx <- ask + liftIO $ do + et <- readIORef exceptionThrown + if et && ordered + then return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised + else runReaderT (updateBlock ordered col b) ctx + `catch` \(e :: SomeException) -> do + writeIORef exceptionThrown True + return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised let failedTotal = or $ map failed blocks let updatedTotal = sum $ map nMatched blocks let modifiedTotal = @@ -670,7 +681,7 @@ updateBlock ordered col (prevCount, docs) = do NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params doc <- runCommand $ updateCommandDocument col ordered docs writeConcern - let writeConcernError = maybeToList $ do + let writeConcernErrors = maybeToList $ do wceDoc <- doc !? "writeConcernError" return $ docToWriteConcernError wceDoc @@ -682,7 +693,7 @@ updateBlock ordered col (prevCount, docs) = do (at "nModified" doc) (map docToUpserted upsertedDocs) writeErrors - writeConcernError + writeConcernErrors updateBlockLegacy :: (MonadIO m) => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult From 316ae02ecc0e76b62dd112c391013b0b62c75822 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 23 Oct 2016 21:52:10 -0700 Subject: [PATCH 13/49] Handle errors properly for ordered updates --- Database/MongoDB/Query.hs | 91 ++++++++++++++++++++++----------------- 1 file changed, 51 insertions(+), 40 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 140385f..612ff6d 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -645,17 +645,20 @@ update' ordered col updateDocs = do updates let lens = map length chunks let lSums = 0 : (zipWith (+) lSums lens) - exceptionThrown <- liftIO $ newIORef False - blocks <- forM (zip lSums chunks) $ \b -> do - ctx <- ask - liftIO $ do - et <- readIORef exceptionThrown - if et && ordered - then return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised - else runReaderT (updateBlock ordered col b) ctx - `catch` \(e :: SomeException) -> do - writeIORef exceptionThrown True - return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised + errorDetected <- liftIO $ newIORef False + ctx <- ask + blocks <- forM (zip lSums chunks) $ \b -> liftIO $ do + ed <- readIORef errorDetected + if ed && ordered + then return $ UpdateResult True 0 Nothing [] [] [] + else do + ur <- runReaderT (updateBlock ordered col b) ctx + when (failed ur) $ do + writeIORef errorDetected True + return ur + `catch` \(e :: SomeException) -> do + writeIORef errorDetected True + return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised let failedTotal = or $ map failed blocks let updatedTotal = sum $ map nMatched blocks let modifiedTotal = @@ -700,38 +703,46 @@ updateBlockLegacy :: (MonadIO m) updateBlockLegacy ordered col (prevCount, docs) = do db <- thisDatabase ctx <- ask + errorDetected <- liftIO $ newIORef False 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 $ UpdateResult False 0 Nothing [] [] [] - Just resDoc -> do - let em = lookup "err" resDoc - let eCode = lookup "code" resDoc - let wtimeout = fromMaybe False $ lookup "wtimeout" resDoc - if isNothing em && isNothing eCode - then do - let n = at "n" resDoc - let ups = do - upsValue <- lookup "upserted" resDoc - return $ Upserted i upsValue - return $ UpdateResult False n Nothing (maybeToList ups) [] [] - else do - let defaultCode = if wtimeout then 64 else 24 - let errV = fromMaybe "unknown error" em - let c = fromMaybe defaultCode eCode - if wtimeout + ed <- readIORef errorDetected + if ed && ordered + then do + return $ UpdateResult True 0 Nothing [] [] [] + else 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 $ UpdateResult False 0 Nothing [] [] [] + Just resDoc -> do + let em = lookup "err" resDoc + let eCode = lookup "code" resDoc + let wtimeout = fromMaybe False $ lookup "wtimeout" resDoc + if isNothing em && isNothing eCode then do - return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV] + let n = at "n" resDoc + let ups = do + upsValue <- lookup "upserted" resDoc + return $ Upserted i upsValue + return $ UpdateResult False n Nothing (maybeToList ups) [] [] else do - return $ UpdateResult True 0 Nothing [] [WriteError i c errV] [] - `catch` \(e :: SomeException) -> do - when ordered $ liftIO $ throwIO e - return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] [] + let defaultCode = if wtimeout then 64 else 24 + let errV = fromMaybe "unknown error" em + let c = fromMaybe defaultCode eCode + if wtimeout + then do + writeIORef errorDetected True + return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV] + else do + writeIORef errorDetected True + return $ UpdateResult True 0 Nothing [] [WriteError i c errV] [] + `catch` \(e :: SomeException) -> do + writeIORef errorDetected True + return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] [] return $ foldl1' mergeUpdateResults results mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult @@ -859,7 +870,7 @@ deleteBlock ordered col docs = do liftIO $ forM docs $ \deleteDoc -> do let sel = (at "q" deleteDoc) :: Document let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else [] - runReaderT (write (Delete (db <.> col) opts sel)) ctx + _ <- runReaderT (write (Delete (db <.> col) opts sel)) ctx return Nothing `catch` \(e :: SomeException) -> do when ordered $ liftIO $ throwIO e From d9db9bca526508ecef9d3188489469edb87b5926 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Tue, 1 Nov 2016 16:34:47 -0700 Subject: [PATCH 14/49] Add declaration of interruptibleFor function --- Database/MongoDB/Query.hs | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 612ff6d..cb57dae 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -1,6 +1,6 @@ -- | Query and update documents -{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, TypeFamilies, CPP, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, TypeFamilies, CPP, DeriveDataTypeable, ScopedTypeVariables, BangPatterns #-} module Database.MongoDB.Query ( -- * Monad @@ -150,6 +150,9 @@ data AccessMode = 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 for more options. +class Result a where + isFailed :: a -> Bool + data UpdateResult = UpdateResult { failed :: Bool , nMatched :: Int @@ -160,6 +163,9 @@ data UpdateResult = UpdateResult , writeConcernErrors :: [WriteConcernError] } deriving Show +instance Result UpdateResult where + isFailed = failed + data Upserted = Upserted { upsertedIndex :: Int , upsertedId :: ObjectId @@ -698,6 +704,17 @@ updateBlock ordered col (prevCount, docs) = do writeErrors writeConcernErrors + +interruptibleFor :: Result b => Bool -> [a] -> (a -> IO b) -> IO [b] +interruptibleFor ordered = go [] + where + go !res [] _ = return $ reverse res + go !res (x:xs) f = do + y <- f x + if isFailed y && ordered + then return $ reverse (y:res) + else go (y:res) xs f + updateBlockLegacy :: (MonadIO m) => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult updateBlockLegacy ordered col (prevCount, docs) = do From c6bd17f1f41d2d574ad43caff809eb7402ed9974 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Tue, 1 Nov 2016 22:53:27 -0700 Subject: [PATCH 15/49] Replace IORefs with interruptibleFor --- Database/MongoDB/Query.hs | 81 ++++++++++++++++----------------------- 1 file changed, 32 insertions(+), 49 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index cb57dae..71fe0a5 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -651,19 +651,11 @@ update' ordered col updateDocs = do updates let lens = map length chunks let lSums = 0 : (zipWith (+) lSums lens) - errorDetected <- liftIO $ newIORef False ctx <- ask - blocks <- forM (zip lSums chunks) $ \b -> liftIO $ do - ed <- readIORef errorDetected - if ed && ordered - then return $ UpdateResult True 0 Nothing [] [] [] - else do - ur <- runReaderT (updateBlock ordered col b) ctx - when (failed ur) $ do - writeIORef errorDetected True - return ur + blocks <- liftIO $ interruptibleFor ordered (zip lSums chunks) $ \b -> liftIO $ do + ur <- runReaderT (updateBlock ordered col b) ctx + return ur `catch` \(e :: SomeException) -> do - writeIORef errorDetected True return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised let failedTotal = or $ map failed blocks let updatedTotal = sum $ map nMatched blocks @@ -720,46 +712,37 @@ updateBlockLegacy :: (MonadIO m) updateBlockLegacy ordered col (prevCount, docs) = do db <- thisDatabase ctx <- ask - errorDetected <- liftIO $ newIORef False - results <- - liftIO $ forM (zip [prevCount, (prevCount + 1) ..] docs) $ \(i, updateDoc) -> do - ed <- readIORef errorDetected - if ed && ordered - then do - return $ UpdateResult True 0 Nothing [] [] [] - else 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 $ UpdateResult False 0 Nothing [] [] [] - Just resDoc -> do - let em = lookup "err" resDoc - let eCode = lookup "code" resDoc - let wtimeout = fromMaybe False $ lookup "wtimeout" resDoc - if isNothing em && isNothing eCode + results <- liftIO $ + interruptibleFor ordered (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 $ UpdateResult False 0 Nothing [] [] [] + Just resDoc -> do + let em = lookup "err" resDoc + let eCode = lookup "code" resDoc + let wtimeout = fromMaybe False $ lookup "wtimeout" resDoc + if isNothing em && isNothing eCode + then do + let n = at "n" resDoc + let ups = do + upsValue <- lookup "upserted" resDoc + return $ Upserted i upsValue + return $ UpdateResult False n Nothing (maybeToList ups) [] [] + else do + let defaultCode = if wtimeout then 64 else 24 + let errV = fromMaybe "unknown error" em + let c = fromMaybe defaultCode eCode + if wtimeout then do - let n = at "n" resDoc - let ups = do - upsValue <- lookup "upserted" resDoc - return $ Upserted i upsValue - return $ UpdateResult False n Nothing (maybeToList ups) [] [] + return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV] else do - let defaultCode = if wtimeout then 64 else 24 - let errV = fromMaybe "unknown error" em - let c = fromMaybe defaultCode eCode - if wtimeout - then do - writeIORef errorDetected True - return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV] - else do - writeIORef errorDetected True - return $ UpdateResult True 0 Nothing [] [WriteError i c errV] [] - `catch` \(e :: SomeException) -> do - writeIORef errorDetected True - return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] [] + return $ UpdateResult True 0 Nothing [] [WriteError i c errV] [] + `catch` \(e :: SomeException) -> do + return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] [] return $ foldl1' mergeUpdateResults results mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult From 460c7e735b99fedf0b44d19e1ec5f26006f8a44b Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 6 Nov 2016 14:39:04 -0800 Subject: [PATCH 16/49] User WriteFailure instead of WriteError --- Database/MongoDB/Query.hs | 45 +++++++++++++++++---------------------- Setup.lhs | 0 2 files changed, 19 insertions(+), 26 deletions(-) mode change 100755 => 100644 Setup.lhs diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 71fe0a5..3df39c8 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -78,7 +78,6 @@ import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), Javascript, at, valueAt, lookup, look, genObjectId, (=:), (=?), (!?), Val(..), ObjectId) import Data.Bson.Binary (putDocument) -import Data.IORef (newIORef, writeIORef, readIORef) import Data.Maybe (fromJust, isJust) import Data.Text (Text) import qualified Data.Text as T @@ -128,7 +127,7 @@ data Failure = ConnectionFailure IOError -- ^ TCP connection ('Pipeline') failed. May work if you try again on the same Mongo 'Connection' which will create a new Pipe. | CursorNotFoundFailure CursorId -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set) | QueryFailure ErrorCode String -- ^ Query failed for some reason as described in the string - | WriteFailure ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string + | WriteFailure Int ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string, index of failed document is the first argument | DocNotFound Selection -- ^ 'fetch' found no document matching selection | AggregateFailure String -- ^ 'aggregate' returned an error deriving (Show, Eq, Typeable) @@ -159,7 +158,7 @@ data UpdateResult = UpdateResult , 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] - , writeErrors :: [WriteError] + , writeErrors :: [Failure] , writeConcernErrors :: [WriteConcernError] } deriving Show @@ -176,12 +175,6 @@ data WriteConcernError = WriteConcernError , wceErrMsg :: String } deriving Show -data WriteError = WriteError - { errIndex :: Int - , errCode :: Int - , errMsg :: String - } deriving Show - data DeleteResult = DeleteResult master :: AccessMode @@ -492,7 +485,7 @@ insertBlock opts col docs = do when (isJust res) $ do let jRes = fromJust res let e = lookup "err" jRes - when (isJust e) $ liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "code" jRes) (fromJust e) + when (isJust e) $ liftIO $ throwIO $ WriteFailure 0 (maybe 0 id $ lookup "code" jRes) (fromJust e) -- Add proper index in the first argument return $ map (valueAt "_id") docs' else do mode <- asks mongoWriteMode @@ -503,15 +496,15 @@ insertBlock opts col docs = do case (look "writeErrors" doc, look "writeConcernError" doc) of (Nothing, Nothing) -> return $ map (valueAt "_id") docs' (Just err, Nothing) -> do - liftIO $ throwIO $ WriteFailure + liftIO $ throwIO $ WriteFailure 0 -- Add proper index (maybe 0 id $ lookup "ok" doc) (show err) (Nothing, Just err) -> do - liftIO $ throwIO $ WriteFailure + liftIO $ throwIO $ WriteFailure 0 -- Add proper index (maybe 0 id $ lookup "ok" doc) (show err) (Just err, Just writeConcernErr) -> do -- TODO writeConcernError is not a failure - liftIO $ throwIO $ WriteFailure + liftIO $ throwIO $ WriteFailure 0 -- Add proper index (maybe 0 id $ lookup "ok" doc) (show err ++ show writeConcernErr) @@ -526,7 +519,7 @@ splitAtLimit ordered maxSize maxCount list = chop (go 0 0 []) list then go curSize curCount [] xs -- Skip this document and insert the other documents. else - throw $ WriteFailure 0 "One document is too big for the message" + throw $ WriteFailure 0 0 "One document is too big for the message" -- TODO add proper index in the first argument go curSize curCount res (x:xs) = if ( ((curSize + (sizeOfDocument x) + 2 + curCount) > maxSize) -- we have ^ 2 brackets and curCount commas in @@ -590,7 +583,7 @@ update :: (MonadIO m) update opts (Select sel col) up = do res <- update' True col [(sel, up, opts)] if not $ null $ writeErrors res - then liftIO $ throwIO $ WriteFailure 0 (show $ head $ writeErrors res) + then liftIO $ throwIO $ WriteFailure 0 0 (show $ head $ writeErrors res) else return () updateCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document @@ -655,8 +648,8 @@ update' ordered col updateDocs = do blocks <- liftIO $ interruptibleFor ordered (zip lSums chunks) $ \b -> liftIO $ do ur <- runReaderT (updateBlock ordered col b) ctx return ur - `catch` \(e :: SomeException) -> do - return $ UpdateResult True 0 Nothing [] [] [] -- TODO probably should be revised + `catch` \(e :: Failure) -> do + return $ UpdateResult True 0 Nothing [] [e] [] -- TODO probably should be revised let failedTotal = or $ map failed blocks let updatedTotal = sum $ map nMatched blocks let modifiedTotal = @@ -740,9 +733,9 @@ updateBlockLegacy ordered col (prevCount, docs) = do 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 - return $ UpdateResult True 0 Nothing [] [WriteError i 0 (show e)] [] + return $ UpdateResult True 0 Nothing [] [WriteFailure i c errV] [] + `catch` \(e :: Failure) -> do + return $ UpdateResult True 0 Nothing [] [e] [] return $ foldl1' mergeUpdateResults results mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult @@ -765,8 +758,8 @@ docToUpserted doc = Upserted ind uid ind = at "index" doc uid = at "_id" doc -docToWriteError :: Document -> WriteError -docToWriteError doc = WriteError ind code msg +docToWriteError :: Document -> Failure +docToWriteError doc = WriteFailure ind code msg where ind = at "index" doc code = at "code" doc @@ -877,7 +870,7 @@ deleteBlock ordered col docs = do return $ Just e let onlyErrors = catMaybes errors if not $ null onlyErrors - then liftIO $ throwIO $ WriteFailure 0 (show onlyErrors) + then liftIO $ throwIO $ WriteFailure 0 0 (show onlyErrors) -- TODO add normal index (first argument) else return () else do mode <- asks mongoWriteMode @@ -888,15 +881,15 @@ deleteBlock ordered col docs = do case (look "writeErrors" doc, look "writeConcernError" doc) of (Nothing, Nothing) -> return () (Just err, Nothing) -> do - liftIO $ throwIO $ WriteFailure + liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index (maybe 0 id $ lookup "ok" doc) (show err) (Nothing, Just err) -> do - liftIO $ throwIO $ WriteFailure + liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index (maybe 0 id $ lookup "ok" doc) (show err) (Just err, Just writeConcernErr) -> do - liftIO $ throwIO $ WriteFailure + liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index (maybe 0 id $ lookup "ok" doc) (show err ++ show writeConcernErr) diff --git a/Setup.lhs b/Setup.lhs old mode 100755 new mode 100644 From e586fd51ccc13f8c93323d50d58e4081e28692c8 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 6 Nov 2016 18:41:33 -0800 Subject: [PATCH 17/49] some minor fixes --- Database/MongoDB/Query.hs | 77 ++++++++++++++++++++++----------------- 1 file changed, 44 insertions(+), 33 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 3df39c8..fdc8067 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -520,6 +520,8 @@ splitAtLimit ordered maxSize maxCount list = chop (go 0 0 []) list go curSize curCount [] xs -- Skip this document and insert the other documents. else throw $ WriteFailure 0 0 "One document is too big for the message" -- TODO add proper index in the first argument + -- TODO it shouldn't throw exceptions. otherwise no documents will be added to the list. + -- It should return UpdateResult with this document as failed. go curSize curCount res (x:xs) = if ( ((curSize + (sizeOfDocument x) + 2 + curCount) > maxSize) -- we have ^ 2 brackets and curCount commas in @@ -596,8 +598,11 @@ updateCommandDocument col ordered updates writeConcern = {-| Bulk update operation. If one update fails it will not update the remaining - documents. Current returned value is only a place holder. With mongodb server - - before 2.6 it will send update requests one by one. After 2.6 it will use - - bulk update feature in mongodb. + - before 2.6 it will send update requests one by one. In order to receive + - error messages in versions under 2.6 you need to user confirmed writes. + - Otherwise even if the errors had place the list of errors will be empty and + - the result will be success. After 2.6 it will use bulk update feature in + - mongodb. -} updateMany :: (MonadIO m) => Collection @@ -607,7 +612,10 @@ updateMany = update' True {-| Bulk update operation. If one update fails it will proceed with the - remaining documents. With mongodb server before 2.6 it will send update - - requests one by one. After 2.6 it will use bulk update feature in mongodb. + - requests one by one. In order to receive error messages in versions under + - 2.6 you need to user confirmed writes. Otherwise even if the errors had + - place the list of errors will be empty and the result will be success. + - After 2.6 it will use bulk update feature in mongodb. -} updateAll :: (MonadIO m) => Collection @@ -630,37 +638,40 @@ update' ordered col updateDocs = do updateDocs mode <- asks mongoWriteMode - let writeConcern = case mode of - NoConfirm -> ["w" =: (0 :: Int)] - Confirm params -> params - let docSize = sizeOfDocument $ updateCommandDocument col ordered [] writeConcern - let chunks = splitAtLimit - ordered - (maxBsonObjectSize sd - docSize) - -- size of auxiliary part of update - -- document should be subtracted from - -- the overall size - (maxWriteBatchSize sd) - updates - let lens = map length chunks - let lSums = 0 : (zipWith (+) lSums lens) ctx <- ask - blocks <- liftIO $ interruptibleFor ordered (zip lSums chunks) $ \b -> liftIO $ do - ur <- runReaderT (updateBlock ordered col b) ctx - return ur - `catch` \(e :: Failure) -> do - return $ UpdateResult True 0 Nothing [] [e] [] -- TODO probably should be revised - let failedTotal = or $ map failed blocks - let updatedTotal = sum $ map nMatched blocks - let modifiedTotal = - if all isNothing $ map nModified blocks - then Nothing - else Just $ sum $ catMaybes $ map nModified blocks - let totalWriteErrors = concat $ map writeErrors blocks - let totalWriteConcernErrors = concat $ map writeConcernErrors blocks + liftIO $ do + let writeConcern = case mode of + NoConfirm -> ["w" =: (0 :: Int)] + Confirm params -> params + let docSize = sizeOfDocument $ updateCommandDocument col ordered [] writeConcern + let chunks = splitAtLimit + ordered + (maxBsonObjectSize sd - docSize) + -- size of auxiliary part of update + -- document should be subtracted from + -- the overall size + (maxWriteBatchSize sd) + updates + let lens = map length chunks + let lSums = 0 : (zipWith (+) lSums lens) + blocks <- interruptibleFor ordered (zip lSums chunks) $ \b -> do + ur <- runReaderT (updateBlock ordered col b) ctx + return ur + `catch` \(e :: Failure) -> do + return $ UpdateResult True 0 Nothing [] [e] [] + let failedTotal = or $ map failed blocks + let updatedTotal = sum $ map nMatched blocks + let modifiedTotal = + if all isNothing $ map nModified blocks + then Nothing + else Just $ sum $ catMaybes $ map nModified blocks + let totalWriteErrors = concat $ map writeErrors blocks + let totalWriteConcernErrors = concat $ map writeConcernErrors blocks - let upsertedTotal = concat $ map upserted blocks - return $ UpdateResult failedTotal updatedTotal modifiedTotal upsertedTotal totalWriteErrors totalWriteConcernErrors + let upsertedTotal = concat $ map upserted blocks + return $ UpdateResult failedTotal updatedTotal modifiedTotal upsertedTotal totalWriteErrors totalWriteConcernErrors + + `catch` \(e :: Failure) -> return $ UpdateResult True 0 Nothing [] [e] [] updateBlock :: (MonadIO m) => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult @@ -747,7 +758,7 @@ mergeUpdateResults (nMatched1 + nMatched2) ((liftM2 (+)) nModified1 nModified2) (upserted1 ++ upserted2) - (writeErrors1 ++ writeErrors2) + (writeErrors1 ++ writeErrors2) -- TODO this should be rewritten with IO containers. Otherwise its N^2 complexity. (writeConcernErrors1 ++ writeConcernErrors2) ) From af49f43027c693809de0bf4da1aff12ec73698c8 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Thu, 17 Nov 2016 00:15:01 -0800 Subject: [PATCH 18/49] Fix splitAtLimit --- Database/MongoDB/Query.hs | 54 ++++++++++++++++++++++++--------------- 1 file changed, 33 insertions(+), 21 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index fdc8067..3cb451a 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -50,6 +50,7 @@ import Prelude hiding (lookup) import Control.Exception (Exception, throwIO, throw) import Control.Monad (unless, replicateM, liftM, forM, forM_, liftM2) import Data.Int (Int32, Int64) +import Data.Either (lefts, rights) import Data.List (foldl1') import Data.Maybe (listToMaybe, catMaybes, isNothing, maybeToList) import Data.Word (Word32) @@ -447,6 +448,12 @@ insertCommandDocument opts col docs writeConcern = , "writeConcern" =: writeConcern ] +takeRightsUpToLeft :: [Either a b] -> [b] +takeRightsUpToLeft l = go l [] + where + go ((Right x):xs) !res = go xs (x:res) + go ((Left x):xs) !res = res + insert' :: (MonadIO m) => [InsertOption] -> Collection -> [Document] -> Action m [Value] -- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied @@ -458,16 +465,21 @@ insert' opts col docs = do NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params let docSize = sizeOfDocument $ insertCommandDocument opts col [] writeConcern - chunks <- forM (splitAtLimit - (not (KeepGoing `elem` opts)) + let ordered = (not (KeepGoing `elem` opts)) + let preChunks = splitAtLimit (maxBsonObjectSize sd - docSize) -- size of auxiliary part of insert -- document should be subtracted from -- the overall size (maxWriteBatchSize sd) - docs) - (insertBlock opts col) - return $ concat chunks + docs + let chunks = + if ordered + then takeRightsUpToLeft preChunks + else rights preChunks + + chunkResults <- forM chunks (insertBlock opts col) + return $ concat chunkResults insertBlock :: (MonadIO m) => [InsertOption] -> Collection -> [Document] -> Action m [Value] @@ -508,20 +520,14 @@ insertBlock opts col docs = do (maybe 0 id $ lookup "ok" doc) (show err ++ show writeConcernErr) -splitAtLimit :: Bool -> Int -> Int -> [Document] -> [[Document]] -splitAtLimit ordered maxSize maxCount list = chop (go 0 0 []) list +splitAtLimit :: Int -> Int -> [Document] -> [Either Failure [Document]] +splitAtLimit maxSize maxCount list = chop (go 0 0 []) list where - go :: Int -> Int -> [Document] -> [Document] -> ([Document], [Document]) - go _ _ res [] = (reverse res, []) + go :: Int -> Int -> [Document] -> [Document] -> ((Either Failure [Document]), [Document]) + go _ _ res [] = (Right $ reverse res, []) go curSize curCount [] (x:xs) | ((curSize + (sizeOfDocument x) + 2 + curCount) > maxSize) = - if (not ordered) - then - go curSize curCount [] xs -- Skip this document and insert the other documents. - else - throw $ WriteFailure 0 0 "One document is too big for the message" -- TODO add proper index in the first argument - -- TODO it shouldn't throw exceptions. otherwise no documents will be added to the list. - -- It should return UpdateResult with this document as failed. + (Left $ WriteFailure 0 0 "One document is too big for the message", xs) go curSize curCount res (x:xs) = if ( ((curSize + (sizeOfDocument x) + 2 + curCount) > maxSize) -- we have ^ 2 brackets and curCount commas in @@ -529,7 +535,7 @@ splitAtLimit ordered maxSize maxCount list = chop (go 0 0 []) list -- account || ((curCount + 1) > maxCount)) then - (reverse res, x:xs) + (Right $ reverse res, x:xs) else go (curSize + (sizeOfDocument x)) (curCount + 1) (x:res) xs @@ -644,14 +650,17 @@ update' ordered col updateDocs = do NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params let docSize = sizeOfDocument $ updateCommandDocument col ordered [] writeConcern - let chunks = splitAtLimit - ordered + let preChunks = splitAtLimit (maxBsonObjectSize sd - docSize) -- size of auxiliary part of update -- document should be subtracted from -- the overall size (maxWriteBatchSize sd) updates + let chunks = + if ordered + then takeRightsUpToLeft preChunks + else rights preChunks let lens = map length chunks let lSums = 0 : (zipWith (+) lSums lens) blocks <- interruptibleFor ordered (zip lSums chunks) $ \b -> do @@ -850,14 +859,17 @@ delete' ordered col deleteDocs = do NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params let docSize = sizeOfDocument $ deleteCommandDocument col ordered [] writeConcern - let chunks = splitAtLimit - ordered + let preChunks = splitAtLimit (maxBsonObjectSize sd - docSize) -- size of auxiliary part of delete -- document should be subtracted from -- the overall size (maxWriteBatchSize sd) deletes + let chunks = + if ordered + then takeRightsUpToLeft preChunks + else rights preChunks forM_ chunks (deleteBlock ordered col) return DeleteResult From a828806940503f9a774de987f9597dc376c97fc4 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 19 Nov 2016 10:47:47 -0800 Subject: [PATCH 19/49] Indent several lines --- Database/MongoDB/Query.hs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 3cb451a..8649440 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -619,7 +619,7 @@ updateMany = update' True {-| Bulk update operation. If one update fails it will proceed with the - remaining documents. With mongodb server before 2.6 it will send update - requests one by one. In order to receive error messages in versions under - - 2.6 you need to user confirmed writes. Otherwise even if the errors had + - 2.6 you need to use confirmed writes. Otherwise even if the errors had - place the list of errors will be empty and the result will be success. - After 2.6 it will use bulk update feature in mongodb. -} @@ -649,7 +649,11 @@ update' ordered col updateDocs = do let writeConcern = case mode of NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params - let docSize = sizeOfDocument $ updateCommandDocument col ordered [] writeConcern + let docSize = sizeOfDocument $ updateCommandDocument + col + ordered + [] + writeConcern let preChunks = splitAtLimit (maxBsonObjectSize sd - docSize) -- size of auxiliary part of update @@ -678,7 +682,13 @@ update' ordered col updateDocs = do let totalWriteConcernErrors = concat $ map writeConcernErrors blocks let upsertedTotal = concat $ map upserted blocks - return $ UpdateResult failedTotal updatedTotal modifiedTotal upsertedTotal totalWriteErrors totalWriteConcernErrors + return $ UpdateResult + failedTotal + updatedTotal + modifiedTotal + upsertedTotal + totalWriteErrors + totalWriteConcernErrors `catch` \(e :: Failure) -> return $ UpdateResult True 0 Nothing [] [e] [] From 139a17248f6f6f9764ff6d277e3c3c7b92ee40e4 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 20 Nov 2016 13:55:40 -0800 Subject: [PATCH 20/49] Fix tests --- Database/MongoDB/Query.hs | 9 +++++++-- test/QuerySpec.hs | 4 ++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 8649440..3e3bc58 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -449,10 +449,11 @@ insertCommandDocument opts col docs writeConcern = ] takeRightsUpToLeft :: [Either a b] -> [b] -takeRightsUpToLeft l = go l [] +takeRightsUpToLeft l = reverse $ go l [] where + go [] !res = res go ((Right x):xs) !res = go xs (x:res) - go ((Left x):xs) !res = res + go ((Left _):_) !res = res insert' :: (MonadIO m) => [InsertOption] -> Collection -> [Document] -> Action m [Value] @@ -479,6 +480,10 @@ insert' opts col docs = do else rights preChunks chunkResults <- forM chunks (insertBlock opts col) + + let lchunks = lefts preChunks + when ((not $ null lchunks) && ordered) $ do + liftIO $ throwIO $ head lchunks return $ concat chunkResults insertBlock :: (MonadIO m) diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index 728fd01..c049ebb 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -110,8 +110,8 @@ spec = around withCleanDatabase $ do describe "insertAll" $ do it "inserts documents to the collection and returns their _ids" $ do (_id1:_id2:_) <- db $ insertAll "team" [ ["name" =: "Yankees", "league" =: "American"] - , ["name" =: "Dodgers", "league" =: "American"] - ] + , ["name" =: "Dodgers", "league" =: "American"] + ] result <- db $ rest =<< find (select [] "team") result `shouldBe` [["_id" =: _id1, "name" =: "Yankees", "league" =: "American"] ,["_id" =: _id2, "name" =: "Dodgers", "league" =: "American"] From 86f782db72f60325bbd5642aa2b0ee06d3d3b983 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 20 Nov 2016 16:18:49 -0800 Subject: [PATCH 21/49] Insert remaining values in insertAll and then throw exception --- Database/MongoDB/Query.hs | 44 ++++++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 15 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 3e3bc58..41df505 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -166,6 +166,10 @@ data UpdateResult = UpdateResult instance Result UpdateResult where isFailed = failed +instance Result (Either a b) where + isFailed (Left _) = True + isFailed _ = False + data Upserted = Upserted { upsertedIndex :: Int , upsertedId :: ObjectId @@ -418,7 +422,11 @@ write notice = asks mongoWriteMode >>= \mode -> case mode of insert :: (MonadIO m) => Collection -> Document -> Action m Value -- ^ Insert document into collection and return its \"_id\" value, which is created automatically if not supplied -insert col doc = head `liftM` insertBlock [] col [doc] +insert col doc = do + res <- insertBlock [] col [doc] + case res of + Left failure -> liftIO $ throwIO failure + Right r -> return $ head r insert_ :: (MonadIO m) => Collection -> Document -> Action m () -- ^ Same as 'insert' except don't return _id @@ -479,17 +487,20 @@ insert' opts col docs = do then takeRightsUpToLeft preChunks else rights preChunks - chunkResults <- forM chunks (insertBlock opts col) + chunkResults <- interruptibleFor ordered chunks $ insertBlock opts col let lchunks = lefts preChunks when ((not $ null lchunks) && ordered) $ do liftIO $ throwIO $ head lchunks - return $ concat chunkResults + + let lresults = lefts chunkResults + when (not $ null lresults) $ liftIO $ throwIO $ head lresults + return $ concat $ rights chunkResults insertBlock :: (MonadIO m) - => [InsertOption] -> Collection -> [Document] -> Action m [Value] + => [InsertOption] -> Collection -> [Document] -> Action m (Either Failure [Value]) -- ^ This will fail if the list of documents is bigger than restrictions -insertBlock _ _ [] = return [] +insertBlock _ _ [] = return $ Right [] insertBlock opts col docs = do db <- thisDatabase docs' <- liftIO $ mapM assignId docs @@ -499,11 +510,14 @@ insertBlock opts col docs = do if (maxWireVersion sd < 2) then do res <- liftDB $ write (Insert (db <.> col) opts docs') - when (isJust res) $ do - let jRes = fromJust res - let e = lookup "err" jRes - when (isJust e) $ liftIO $ throwIO $ WriteFailure 0 (maybe 0 id $ lookup "code" jRes) (fromJust e) -- Add proper index in the first argument - return $ map (valueAt "_id") docs' + let errorMessage = do + jRes <- res + em <- lookup "err" jRes + return $ WriteFailure 0 (maybe 0 id $ lookup "code" jRes) em -- Add proper index in the first argument + + case errorMessage of + Just failure -> return $ Left failure + Nothing -> return $ Right $ map (valueAt "_id") docs' else do mode <- asks mongoWriteMode let writeConcern = case mode of @@ -511,17 +525,17 @@ insertBlock opts col docs = do Confirm params -> params doc <- runCommand $ insertCommandDocument opts col docs' writeConcern case (look "writeErrors" doc, look "writeConcernError" doc) of - (Nothing, Nothing) -> return $ map (valueAt "_id") docs' + (Nothing, Nothing) -> return $ Right $ map (valueAt "_id") docs' (Just err, Nothing) -> do - liftIO $ throwIO $ WriteFailure 0 -- Add proper index + return $ Left $ WriteFailure 0 -- Add proper index (maybe 0 id $ lookup "ok" doc) (show err) (Nothing, Just err) -> do - liftIO $ throwIO $ WriteFailure 0 -- Add proper index + return $ Left $ WriteFailure 0 -- Add proper index (maybe 0 id $ lookup "ok" doc) (show err) (Just err, Just writeConcernErr) -> do -- TODO writeConcernError is not a failure - liftIO $ throwIO $ WriteFailure 0 -- Add proper index + return $ Left $ WriteFailure 0 -- Add proper index (maybe 0 id $ lookup "ok" doc) (show err ++ show writeConcernErr) @@ -725,7 +739,7 @@ updateBlock ordered col (prevCount, docs) = do writeConcernErrors -interruptibleFor :: Result b => Bool -> [a] -> (a -> IO b) -> IO [b] +interruptibleFor :: (Monad m, Result b) => Bool -> [a] -> (a -> m b) -> m [b] interruptibleFor ordered = go [] where go !res [] _ = return $ reverse res From bedaa744bafe28f8d237bf6326b127ee0c1036cc Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 20 Nov 2016 19:18:14 -0800 Subject: [PATCH 22/49] Add indexes to error reporting --- Database/MongoDB/Query.hs | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 41df505..381803d 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -423,7 +423,7 @@ write notice = asks mongoWriteMode >>= \mode -> case mode of insert :: (MonadIO m) => Collection -> Document -> Action m Value -- ^ Insert document into collection and return its \"_id\" value, which is created automatically if not supplied insert col doc = do - res <- insertBlock [] col [doc] + res <- insertBlock [] col (0, [doc]) case res of Left failure -> liftIO $ throwIO failure Right r -> return $ head r @@ -487,7 +487,10 @@ insert' opts col docs = do then takeRightsUpToLeft preChunks else rights preChunks - chunkResults <- interruptibleFor ordered chunks $ insertBlock opts col + let lens = map length chunks + let lSums = 0 : (zipWith (+) lSums lens) + + chunkResults <- interruptibleFor ordered (zip lSums chunks) $ insertBlock opts col let lchunks = lefts preChunks when ((not $ null lchunks) && ordered) $ do @@ -498,10 +501,10 @@ insert' opts col docs = do return $ concat $ rights chunkResults insertBlock :: (MonadIO m) - => [InsertOption] -> Collection -> [Document] -> Action m (Either Failure [Value]) + => [InsertOption] -> Collection -> (Int, [Document]) -> Action m (Either Failure [Value]) -- ^ This will fail if the list of documents is bigger than restrictions -insertBlock _ _ [] = return $ Right [] -insertBlock opts col docs = do +insertBlock _ _ (_, []) = return $ Right [] +insertBlock opts col (prevCount, docs) = do db <- thisDatabase docs' <- liftIO $ mapM assignId docs @@ -513,7 +516,9 @@ insertBlock opts col docs = do let errorMessage = do jRes <- res em <- lookup "err" jRes - return $ WriteFailure 0 (maybe 0 id $ lookup "code" jRes) em -- Add proper index in the first argument + return $ WriteFailure prevCount (maybe 0 id $ lookup "code" jRes) em + -- In older versions of ^^ the protocol we can't really say which document failed. + -- So we just report the accumulated number of documents in the previous blocks. case errorMessage of Just failure -> return $ Left failure @@ -527,15 +532,15 @@ insertBlock opts col docs = do case (look "writeErrors" doc, look "writeConcernError" doc) of (Nothing, Nothing) -> return $ Right $ map (valueAt "_id") docs' (Just err, Nothing) -> do - return $ Left $ WriteFailure 0 -- Add proper index + return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten (maybe 0 id $ lookup "ok" doc) (show err) (Nothing, Just err) -> do - return $ Left $ WriteFailure 0 -- Add proper index + return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten (maybe 0 id $ lookup "ok" doc) (show err) - (Just err, Just writeConcernErr) -> do -- TODO writeConcernError is not a failure - return $ Left $ WriteFailure 0 -- Add proper index + (Just err, Just writeConcernErr) -> do + return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten (maybe 0 id $ lookup "ok" doc) (show err ++ show writeConcernErr) From 80ebc6f756ca666b647f4b64caaead6d42d53619 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Thu, 24 Nov 2016 14:18:00 -0800 Subject: [PATCH 23/49] Throw exception when insertAll encounters big doc - insertAll should throw an exception if it encounters a document too big for one message. However all other documents will be inserted. - slightly edit docs --- Database/MongoDB/Query.hs | 13 ++++++++++--- test/QuerySpec.hs | 2 +- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 381803d..c05c110 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -433,7 +433,11 @@ insert_ :: (MonadIO m) => Collection -> Document -> Action m () insert_ col doc = insert col doc >> return () insertMany :: (MonadIO m) => Collection -> [Document] -> Action m [Value] --- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied. If a document fails to be inserted (eg. due to duplicate key) then remaining docs are aborted, and LastError is set. +-- ^ Insert documents into collection and return their \"_id\" values, +-- which are created automatically if not supplied. +-- If a document fails to be inserted (eg. due to duplicate key) +-- then remaining docs are aborted, and LastError is set. +-- An exception will be throw if any error occurs. insertMany = insert' [] insertMany_ :: (MonadIO m) => Collection -> [Document] -> Action m () @@ -441,7 +445,10 @@ insertMany_ :: (MonadIO m) => Collection -> [Document] -> Action m () insertMany_ col docs = insertMany col docs >> return () insertAll :: (MonadIO m) => Collection -> [Document] -> Action m [Value] --- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied. If a document fails to be inserted (eg. due to duplicate key) then remaining docs are still inserted. LastError is set if any doc fails, not just last one. +-- ^ Insert documents into collection and return their \"_id\" values, +-- which are created automatically if not supplied. If a document fails +-- to be inserted (eg. due to duplicate key) then remaining docs +-- are still inserted. insertAll = insert' [KeepGoing] insertAll_ :: (MonadIO m) => Collection -> [Document] -> Action m () @@ -493,7 +500,7 @@ insert' opts col docs = do chunkResults <- interruptibleFor ordered (zip lSums chunks) $ insertBlock opts col let lchunks = lefts preChunks - when ((not $ null lchunks) && ordered) $ do + when (not $ null lchunks) $ do liftIO $ throwIO $ head lchunks let lresults = lefts chunkResults diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index c049ebb..fb0712f 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -171,7 +171,7 @@ spec = around withCleanDatabase $ do liftIO $ (length returnedDocs) `shouldBe` 1000 it "skips one too big document" $ do - db $ insertAll_ "hugeDocCollection" [hugeDocument] + (db $ insertAll_ "hugeDocCollection" [hugeDocument]) `shouldThrow` anyException db $ do cur <- find $ (select [] "hugeDocCollection") {limit = 100000, batchSize = 100000} returnedDocs <- rest cur From eeb0c7981d5fafdac357cfab9d0d9a278e4524f1 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Thu, 24 Nov 2016 23:09:56 -0800 Subject: [PATCH 24/49] Edit comments slightly --- Database/MongoDB/Query.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index c05c110..d59724d 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -539,15 +539,15 @@ insertBlock opts col (prevCount, docs) = do case (look "writeErrors" doc, look "writeConcernError" doc) of (Nothing, Nothing) -> return $ Right $ map (valueAt "_id") docs' (Just err, Nothing) -> do - return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten + return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten since we can not really report meaningful result for every document (maybe 0 id $ lookup "ok" doc) (show err) (Nothing, Just err) -> do - return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten + return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten -----''------ (maybe 0 id $ lookup "ok" doc) (show err) (Just err, Just writeConcernErr) -> do - return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten + return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten -----''------ (maybe 0 id $ lookup "ok" doc) (show err ++ show writeConcernErr) From 569d8ccc085a55118cbcd7bf9e88469afe3ec417 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Fri, 25 Nov 2016 22:33:58 -0800 Subject: [PATCH 25/49] Fix list append complexity issue --- Database/MongoDB/Query.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index d59724d..4c7f830 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -807,9 +807,13 @@ mergeUpdateResults (failed1 || failed2) (nMatched1 + nMatched2) ((liftM2 (+)) nModified1 nModified2) - (upserted1 ++ upserted2) - (writeErrors1 ++ writeErrors2) -- TODO this should be rewritten with IO containers. Otherwise its N^2 complexity. - (writeConcernErrors1 ++ writeConcernErrors2) + -- 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. + -- So, changing the order of list concatenation allows us to keep linear complexity of the + -- whole list accumulation process. + (upserted2 ++ upserted1) + (writeErrors2 ++ writeErrors1) + (writeConcernErrors2 ++ writeConcernErrors1) ) From 09c05d4b69d62a9ed9810c47b2b65790e5421cce Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 7 Jan 2017 12:36:07 -0800 Subject: [PATCH 26/49] Rename UpdateResult to WriteResult 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. --- Database/MongoDB/Query.hs | 75 ++++++++++++++++++++------------------- 1 file changed, 38 insertions(+), 37 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 4c7f830..e2e8c37 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -22,9 +22,9 @@ module Database.MongoDB.Query ( insert, insert_, insertMany, insertMany_, insertAll, insertAll_, -- ** Update save, replace, repsert, upsert, Modifier, modify, updateMany, updateAll, - UpdateResult(..), UpdateOption(..), Upserted(..), + WriteResult(..), UpdateOption(..), Upserted(..), -- ** Delete - delete, deleteOne, deleteMany, deleteAll, DeleteResult, DeleteOption(..), + delete, deleteOne, deleteMany, deleteAll, DeleteOption(..), -- * Read -- ** Query Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), @@ -47,7 +47,7 @@ module Database.MongoDB.Query ( ) where 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 Data.Int (Int32, Int64) 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, (=:), (=?), (!?), Val(..), ObjectId) import Data.Bson.Binary (putDocument) -import Data.Maybe (fromJust, isJust) import Data.Text (Text) import qualified Data.Text as T @@ -153,17 +152,18 @@ type GetLastError = Document class Result a where isFailed :: a -> Bool -data UpdateResult = UpdateResult +data WriteResult = WriteResult { failed :: Bool , nMatched :: 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. , upserted :: [Upserted] , writeErrors :: [Failure] , writeConcernErrors :: [WriteConcernError] } deriving Show -instance Result UpdateResult where +instance Result WriteResult where isFailed = failed instance Result (Either a b) where @@ -180,8 +180,6 @@ data WriteConcernError = WriteConcernError , wceErrMsg :: String } deriving Show -data DeleteResult = DeleteResult - master :: AccessMode -- ^ Same as 'ConfirmWrites' [] master = ConfirmWrites [] @@ -644,7 +642,7 @@ updateCommandDocument col ordered updates writeConcern = updateMany :: (MonadIO m) => Collection -> [(Selector, Document, [UpdateOption])] - -> Action m UpdateResult + -> Action m WriteResult updateMany = update' True {-| Bulk update operation. If one update fails it will proceed with the @@ -657,14 +655,14 @@ updateMany = update' True updateAll :: (MonadIO m) => Collection -> [(Selector, Document, [UpdateOption])] - -> Action m UpdateResult + -> Action m WriteResult updateAll = update' False update' :: (MonadIO m) => Bool -> Collection -> [(Selector, Document, [UpdateOption])] - -> Action m UpdateResult + -> Action m WriteResult update' ordered col updateDocs = do p <- asks mongoPipe let sd = P.serverData p @@ -702,7 +700,7 @@ update' ordered col updateDocs = do ur <- runReaderT (updateBlock ordered col b) ctx return ur `catch` \(e :: Failure) -> do - return $ UpdateResult True 0 Nothing [] [e] [] + return $ WriteResult True 0 Nothing 0 [] [e] [] let failedTotal = or $ map failed blocks let updatedTotal = sum $ map nMatched blocks let modifiedTotal = @@ -713,18 +711,19 @@ update' ordered col updateDocs = do let totalWriteConcernErrors = concat $ map writeConcernErrors blocks let upsertedTotal = concat $ map upserted blocks - return $ UpdateResult + return $ WriteResult failedTotal updatedTotal modifiedTotal + 0 -- nRemoved upsertedTotal totalWriteErrors totalWriteConcernErrors - `catch` \(e :: Failure) -> return $ UpdateResult True 0 Nothing [] [e] [] + `catch` \(e :: Failure) -> return $ WriteResult True 0 Nothing 0 [] [e] [] updateBlock :: (MonadIO m) - => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult + => Bool -> Collection -> (Int, [Document]) -> Action m WriteResult updateBlock ordered col (prevCount, docs) = do p <- asks mongoPipe let sd = P.serverData p @@ -742,10 +741,11 @@ updateBlock ordered col (prevCount, docs) = do let writeErrors = map docToWriteError $ fromMaybe [] (doc !? "writeErrors") let upsertedDocs = fromMaybe [] (doc !? "upserted") - return $ UpdateResult + return $ WriteResult ((not $ true1 "ok" doc) || (not $ null writeErrors) || (not $ null writeConcernErrors)) (at "n" doc) (at "nModified" doc) + 0 (map docToUpserted upsertedDocs) writeErrors writeConcernErrors @@ -762,7 +762,7 @@ interruptibleFor ordered = go [] else go (y:res) xs f updateBlockLegacy :: (MonadIO m) - => Bool -> Collection -> (Int, [Document]) -> Action m UpdateResult + => Bool -> Collection -> (Int, [Document]) -> Action m WriteResult updateBlockLegacy ordered col (prevCount, docs) = do db <- thisDatabase ctx <- ask @@ -774,7 +774,7 @@ updateBlockLegacy ordered col (prevCount, docs) = do 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 $ UpdateResult False 0 Nothing [] [] [] + Nothing -> return $ WriteResult False 0 Nothing 0 [] [] [] Just resDoc -> do let em = lookup "err" resDoc let eCode = lookup "code" resDoc @@ -785,28 +785,29 @@ updateBlockLegacy ordered col (prevCount, docs) = do let ups = do upsValue <- lookup "upserted" resDoc return $ Upserted i upsValue - return $ UpdateResult False n Nothing (maybeToList ups) [] [] + return $ WriteResult False n Nothing 0 (maybeToList ups) [] [] else do let defaultCode = if wtimeout then 64 else 24 let errV = fromMaybe "unknown error" em let c = fromMaybe defaultCode eCode if wtimeout then do - return $ UpdateResult True 0 Nothing [] [] [WriteConcernError c errV] + return $ WriteResult True 0 Nothing 0 [] [] [WriteConcernError c errV] 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 - return $ UpdateResult True 0 Nothing [] [e] [] - return $ foldl1' mergeUpdateResults results + return $ WriteResult True 0 Nothing 0 [] [e] [] + return $ foldl1' mergeWriteResults results -mergeUpdateResults :: UpdateResult -> UpdateResult -> UpdateResult -mergeUpdateResults - (UpdateResult failed1 nMatched1 nModified1 upserted1 writeErrors1 writeConcernErrors1) - (UpdateResult failed2 nMatched2 nModified2 upserted2 writeErrors2 writeConcernErrors2) = - (UpdateResult +mergeWriteResults :: WriteResult -> WriteResult -> WriteResult +mergeWriteResults + (WriteResult failed1 nMatched1 nModified1 nDeleted1 upserted1 writeErrors1 writeConcernErrors1) + (WriteResult failed2 nMatched2 nModified2 nDeleted2 upserted2 writeErrors2 writeConcernErrors2) = + (WriteResult (failed1 || failed2) (nMatched1 + nMatched2) ((liftM2 (+)) nModified1 nModified2) + (nDeleted1 + nDeleted2) -- 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. -- 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) => Collection -> [(Selector, [DeleteOption])] - -> Action m DeleteResult + -> Action m WriteResult deleteMany = delete' True {-| Bulk delete operation. If one delete fails it will proceed with the @@ -873,7 +874,7 @@ deleteMany = delete' True deleteAll :: (MonadIO m) => Collection -> [(Selector, [DeleteOption])] - -> Action m DeleteResult + -> Action m WriteResult deleteAll = delete' False deleteCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document @@ -888,7 +889,7 @@ delete' :: (MonadIO m) => Bool -> Collection -> [(Selector, [DeleteOption])] - -> Action m DeleteResult + -> Action m WriteResult delete' ordered col deleteDocs = do p <- asks mongoPipe let sd = P.serverData p @@ -915,11 +916,11 @@ delete' ordered col deleteDocs = do if ordered then takeRightsUpToLeft preChunks else rights preChunks - forM_ chunks (deleteBlock ordered col) - return DeleteResult + blockResult <- forM chunks (deleteBlock ordered col) + return $ foldl1' mergeWriteResults blockResult deleteBlock :: (MonadIO m) - => Bool -> Collection -> [Document] -> Action m () + => Bool -> Collection -> [Document] -> Action m WriteResult deleteBlock ordered col docs = do p <- asks mongoPipe let sd = P.serverData p @@ -931,7 +932,7 @@ deleteBlock ordered col docs = do liftIO $ forM docs $ \deleteDoc -> do let sel = (at "q" deleteDoc) :: Document 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 `catch` \(e :: SomeException) -> do when ordered $ liftIO $ throwIO e @@ -939,7 +940,7 @@ deleteBlock ordered col docs = do let onlyErrors = catMaybes errors if not $ null onlyErrors 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 mode <- asks mongoWriteMode let writeConcern = case mode of @@ -947,7 +948,7 @@ deleteBlock ordered col docs = do Confirm params -> params doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern 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 liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index (maybe 0 id $ lookup "ok" doc) From 8db991bb5dc6c3970f3aac8ded3436a67b1d19fe Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 14 Jan 2017 18:39:43 -0800 Subject: [PATCH 27/49] Rewrite deleteBlock using WriteResult --- Database/MongoDB/Query.hs | 48 +++++++++++++++++++++++---------------- 1 file changed, 28 insertions(+), 20 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index e2e8c37..15261d2 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -928,39 +928,47 @@ deleteBlock ordered col docs = do then do db <- thisDatabase ctx <- ask - errors <- - liftIO $ forM docs $ \deleteDoc -> do + results <- + liftIO $ interruptibleFor ordered docs $ \deleteDoc -> do let sel = (at "q" deleteDoc) :: Document let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else [] res <- runReaderT (write (Delete (db <.> col) opts sel)) ctx - return Nothing - `catch` \(e :: SomeException) -> do - when ordered $ liftIO $ throwIO e - return $ Just e - let onlyErrors = catMaybes errors - if not $ null onlyErrors - then liftIO $ throwIO $ WriteFailure 0 0 (show onlyErrors) -- TODO add normal index (first argument) - else return $ WriteResult False 0 Nothing 0 [] [] [] -- TODO to be fixed + let n = fromMaybe 0 $ do + resDoc <- res + resDoc !? "n" + return $ WriteResult False 0 Nothing n [] [] [] + `catch` \(e :: Failure) -> do + return $ WriteResult True 0 Nothing 0 [] [e] [] + return $ foldl1' mergeWriteResults results else do mode <- asks mongoWriteMode let writeConcern = case mode of NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern + let n = fromMaybe 0 $ doc !? "n" case (look "writeErrors" doc, look "writeConcernError" doc) of - (Nothing, Nothing) -> return $ WriteResult False 0 Nothing 0 [] [] []-- TODO to be fixed + (Nothing, Nothing) -> return $ WriteResult False 0 Nothing n [] [] [] (Just err, Nothing) -> do - liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index + return $ WriteResult True 0 Nothing n [] [ + WriteFailure 0 -- TODO add normal index (maybe 0 id $ lookup "ok" doc) - (show err) - (Nothing, Just err) -> do - liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index + (show err)] [] + (Nothing, Just (Doc err)) -> do + return $ WriteResult True 0 Nothing n [] [] [ + WriteConcernError + (fromMaybe (-1) $ err !? "code") + (fromMaybe "" $ err !? "errmsg") + ] + (Just err, Just (Doc writeConcernErr)) -> do + return $ WriteResult True 0 Nothing n [] [ + WriteFailure 0 -- TODO add normal index (maybe 0 id $ lookup "ok" doc) - (show err) - (Just err, Just writeConcernErr) -> do - liftIO $ throwIO $ WriteFailure 0 -- TODO add normal index - (maybe 0 id $ lookup "ok" doc) - (show err ++ show writeConcernErr) + (show err)] [ + WriteConcernError + (fromMaybe (-1) $ writeConcernErr !? "code") + (fromMaybe "" $ writeConcernErr !? "errmsg") + ] -- * Read From 6013272c5d2380ae1f7e3fd389091d81e1d6f015 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 21 Jan 2017 15:03:14 -0800 Subject: [PATCH 28/49] Rewrite delete comand using interruptible for --- Database/MongoDB/Query.hs | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 15261d2..56f1959 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -48,7 +48,7 @@ module Database.MongoDB.Query ( import Prelude hiding (lookup) import Control.Exception (Exception, throwIO) -import Control.Monad (unless, replicateM, liftM, forM, forM_, liftM2) +import Control.Monad (unless, replicateM, liftM, forM, liftM2) import Data.Int (Int32, Int64) import Data.Either (lefts, rights) import Data.List (foldl1') @@ -67,7 +67,7 @@ import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer, readMVar, modifyMVar) #endif import Control.Applicative ((<$>)) -import Control.Exception (SomeException, catch) +import Control.Exception (catch) import Control.Monad (when) import Control.Monad.Base (MonadBase) import Control.Monad.Error (Error(..)) @@ -916,12 +916,19 @@ delete' ordered col deleteDocs = do if ordered then takeRightsUpToLeft preChunks else rights preChunks - blockResult <- forM chunks (deleteBlock ordered col) + ctx <- ask + let lens = map length chunks + let lSums = 0 : (zipWith (+) lSums lens) + blockResult <- liftIO $ interruptibleFor ordered (zip lSums chunks) $ \b -> do + dr <- runReaderT (deleteBlock ordered col b) ctx + return dr + `catch` \(e :: Failure) -> do + return $ WriteResult True 0 Nothing 0 [] [e] [] return $ foldl1' mergeWriteResults blockResult deleteBlock :: (MonadIO m) - => Bool -> Collection -> [Document] -> Action m WriteResult -deleteBlock ordered col docs = do + => Bool -> Collection -> (Int, [Document]) -> Action m WriteResult +deleteBlock ordered col (prevCount, docs) = do p <- asks mongoPipe let sd = P.serverData p if (maxWireVersion sd < 2) From 6a13bde01be72905c64eb089f8f7268546b18598 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 21 Jan 2017 15:25:28 -0800 Subject: [PATCH 29/49] Set proper index for exception --- Database/MongoDB/Query.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 56f1959..001a32f 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -926,6 +926,11 @@ delete' ordered col deleteDocs = do return $ WriteResult True 0 Nothing 0 [] [e] [] return $ foldl1' mergeWriteResults blockResult + +addFailureIndex :: Int -> Failure -> Failure +addFailureIndex i (WriteFailure ind code s) = WriteFailure i code s +addFailureIndex i f = f + deleteBlock :: (MonadIO m) => Bool -> Collection -> (Int, [Document]) -> Action m WriteResult deleteBlock ordered col (prevCount, docs) = do @@ -936,16 +941,16 @@ deleteBlock ordered col (prevCount, docs) = do db <- thisDatabase ctx <- ask results <- - liftIO $ interruptibleFor ordered docs $ \deleteDoc -> do + liftIO $ interruptibleFor ordered (zip [prevCount, prevCount + 1 ..] docs) $ \(i, deleteDoc) -> do let sel = (at "q" deleteDoc) :: Document let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else [] res <- runReaderT (write (Delete (db <.> col) opts sel)) ctx let n = fromMaybe 0 $ do resDoc <- res resDoc !? "n" - return $ WriteResult False 0 Nothing n [] [] [] + return $ WriteResult False 0 Nothing n [] [] [] -- TODO it's only ok when res ok is 1. Should be fixed `catch` \(e :: Failure) -> do - return $ WriteResult True 0 Nothing 0 [] [e] [] + return $ WriteResult True 0 Nothing 0 [] [addFailureIndex i e] [] return $ foldl1' mergeWriteResults results else do mode <- asks mongoWriteMode From d1d5f84b2265934c2323656d779d5d802e40d7d9 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 21 Jan 2017 17:16:59 -0800 Subject: [PATCH 30/49] Keep old behavior of update --- Database/MongoDB/Query.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 001a32f..91cfdeb 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -68,7 +68,7 @@ import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer, #endif import Control.Applicative ((<$>)) import Control.Exception (catch) -import Control.Monad (when) +import Control.Monad (when, void) import Control.Monad.Base (MonadBase) import Control.Monad.Error (Error(..)) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local) @@ -618,10 +618,9 @@ update :: (MonadIO m) => [UpdateOption] -> Selection -> Document -> Action m () -- ^ Update first document in selection using updater document, unless 'MultiUpdate' option is supplied then update all documents in selection. If 'Upsert' option is supplied then treat updater as document and insert it if selection is empty. update opts (Select sel col) up = do - res <- update' True col [(sel, up, opts)] - if not $ null $ writeErrors res - then liftIO $ throwIO $ WriteFailure 0 0 (show $ head $ writeErrors res) - else return () + db <- thisDatabase + ctx <- ask + liftIO $ runReaderT (void $ write (Update (db <.> col) opts sel up)) ctx updateCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document updateCommandDocument col ordered updates writeConcern = From dad19515de217a8fb6fca81a67641f8aeaab9c3d Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 21 Jan 2017 17:21:41 -0800 Subject: [PATCH 31/49] Keep old behavior of delete command --- Database/MongoDB/Query.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 91cfdeb..cec6cab 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -851,8 +851,9 @@ deleteOne = deleteHelper [SingleRemove] deleteHelper :: (MonadIO m) => [DeleteOption] -> Selection -> Action m () deleteHelper opts (Select sel col) = do - _ <- delete' True col [(sel, opts)] - return () + db <- thisDatabase + ctx <- ask + liftIO $ runReaderT (void $ write (Delete (db <.> col) opts sel)) ctx {-| Bulk delete operation. If one delete fails it will not delete the remaining - documents. Current returned value is only a place holder. With mongodb server From f57ac94a3b1c54f95d13be782717221efe5743ff Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 21 Jan 2017 17:27:24 -0800 Subject: [PATCH 32/49] Drop support of mongo 2.6 in updateMany and deleteMany --- Database/MongoDB/Query.hs | 56 ++------------------------------------- 1 file changed, 2 insertions(+), 54 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index cec6cab..fa0d6e3 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -727,7 +727,7 @@ updateBlock ordered col (prevCount, docs) = do p <- asks mongoPipe let sd = P.serverData p if (maxWireVersion sd < 2) - then updateBlockLegacy ordered col (prevCount, docs) + then liftIO $ ioError $ userError "updateMany doesn't support mongodb older than 2.6" else do mode <- asks mongoWriteMode let writeConcern = case mode of @@ -760,44 +760,6 @@ interruptibleFor ordered = go [] then return $ reverse (y:res) else go (y:res) xs f -updateBlockLegacy :: (MonadIO m) - => Bool -> Collection -> (Int, [Document]) -> Action m WriteResult -updateBlockLegacy ordered col (prevCount, docs) = do - db <- thisDatabase - ctx <- ask - results <- liftIO $ - interruptibleFor ordered (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 $ WriteResult False 0 Nothing 0 [] [] [] - Just resDoc -> do - let em = lookup "err" resDoc - let eCode = lookup "code" resDoc - let wtimeout = fromMaybe False $ lookup "wtimeout" resDoc - if isNothing em && isNothing eCode - then do - let n = at "n" resDoc - let ups = do - upsValue <- lookup "upserted" resDoc - return $ Upserted i upsValue - return $ WriteResult False n Nothing 0 (maybeToList ups) [] [] - else do - let defaultCode = if wtimeout then 64 else 24 - let errV = fromMaybe "unknown error" em - let c = fromMaybe defaultCode eCode - if wtimeout - then do - return $ WriteResult True 0 Nothing 0 [] [] [WriteConcernError c errV] - else do - return $ WriteResult True 0 Nothing 0 [] [WriteFailure i c errV] [] - `catch` \(e :: Failure) -> do - return $ WriteResult True 0 Nothing 0 [] [e] [] - return $ foldl1' mergeWriteResults results - mergeWriteResults :: WriteResult -> WriteResult -> WriteResult mergeWriteResults (WriteResult failed1 nMatched1 nModified1 nDeleted1 upserted1 writeErrors1 writeConcernErrors1) @@ -937,21 +899,7 @@ deleteBlock 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 $ interruptibleFor ordered (zip [prevCount, prevCount + 1 ..] docs) $ \(i, deleteDoc) -> do - let sel = (at "q" deleteDoc) :: Document - let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else [] - res <- runReaderT (write (Delete (db <.> col) opts sel)) ctx - let n = fromMaybe 0 $ do - resDoc <- res - resDoc !? "n" - return $ WriteResult False 0 Nothing n [] [] [] -- TODO it's only ok when res ok is 1. Should be fixed - `catch` \(e :: Failure) -> do - return $ WriteResult True 0 Nothing 0 [] [addFailureIndex i e] [] - return $ foldl1' mergeWriteResults results + then liftIO $ ioError $ userError "deleteMany doesn't support mongodb older than 2.6" else do mode <- asks mongoWriteMode let writeConcern = case mode of From e2e9f12af86134fb365093cb60d8e740c7ce1d1f Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 21 Jan 2017 22:25:27 -0800 Subject: [PATCH 33/49] Adjust index for updateBlock results --- Database/MongoDB/Query.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index fa0d6e3..b0ab134 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -48,7 +48,7 @@ module Database.MongoDB.Query ( import Prelude hiding (lookup) import Control.Exception (Exception, throwIO) -import Control.Monad (unless, replicateM, liftM, forM, liftM2) +import Control.Monad (unless, replicateM, liftM, liftM2) import Data.Int (Int32, Int64) import Data.Either (lefts, rights) import Data.List (foldl1') @@ -175,10 +175,8 @@ data Upserted = Upserted , upsertedId :: ObjectId } deriving Show -data WriteConcernError = WriteConcernError - { wceCode :: Int - , wceErrMsg :: String - } deriving Show +data WriteConcernError = WriteConcernError Int String + deriving Show master :: AccessMode -- ^ Same as 'ConfirmWrites' [] @@ -746,7 +744,7 @@ updateBlock ordered col (prevCount, docs) = do (at "nModified" doc) 0 (map docToUpserted upsertedDocs) - writeErrors + (map (addFailureIndex prevCount) writeErrors) writeConcernErrors @@ -890,8 +888,8 @@ delete' ordered col deleteDocs = do addFailureIndex :: Int -> Failure -> Failure -addFailureIndex i (WriteFailure ind code s) = WriteFailure i code s -addFailureIndex i f = f +addFailureIndex i (WriteFailure ind code s) = WriteFailure (ind + i) code s +addFailureIndex _ f = f deleteBlock :: (MonadIO m) => Bool -> Collection -> (Int, [Document]) -> Action m WriteResult From 173e90eb90adde6bca8cad5fd8d6f0de495efc09 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 22 Jan 2017 18:57:07 -0800 Subject: [PATCH 34/49] Don't run ...Many tests against mongo 2.4 --- Database/MongoDB/Query.hs | 22 ++-- test/QuerySpec.hs | 267 +++++++++++++++++++++----------------- 2 files changed, 157 insertions(+), 132 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index b0ab134..1d12379 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -43,7 +43,7 @@ module Database.MongoDB.Query ( MRResult, mapReduce, runMR, runMR', -- * Command Command, runCommand, runCommand1, - eval, retrieveServerData + eval, retrieveServerData, ServerData(..) ) where import Prelude hiding (lookup) @@ -77,7 +77,7 @@ import Control.Monad.Trans.Control (MonadBaseControl(..)) import Data.Binary.Put (runPut) import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), Javascript, at, valueAt, lookup, look, genObjectId, (=:), - (=?), (!?), Val(..), ObjectId) + (=?), (!?), Val(..), ObjectId, Value(..)) import Data.Bson.Binary (putDocument) import Data.Text (Text) import qualified Data.Text as T @@ -907,27 +907,25 @@ deleteBlock ordered col (prevCount, docs) = do let n = fromMaybe 0 $ doc !? "n" case (look "writeErrors" doc, look "writeConcernError" doc) of (Nothing, Nothing) -> return $ WriteResult False 0 Nothing n [] [] [] - (Just err, Nothing) -> do - return $ WriteResult True 0 Nothing n [] [ - WriteFailure 0 -- TODO add normal index - (maybe 0 id $ lookup "ok" doc) - (show err)] [] + (Just (Array err), Nothing) -> do + return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [] (Nothing, Just (Doc err)) -> do return $ WriteResult True 0 Nothing n [] [] [ WriteConcernError (fromMaybe (-1) $ err !? "code") (fromMaybe "" $ err !? "errmsg") ] - (Just err, Just (Doc writeConcernErr)) -> do - return $ WriteResult True 0 Nothing n [] [ - WriteFailure 0 -- TODO add normal index - (maybe 0 id $ lookup "ok" doc) - (show err)] [ + (Just (Array err), Just (Doc writeConcernErr)) -> do + return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [ WriteConcernError (fromMaybe (-1) $ writeConcernErr !? "code") (fromMaybe "" $ writeConcernErr !? "errmsg") ] +anyToWriteError :: Int -> Value -> Failure +anyToWriteError ind (Doc d) = docToWriteError d +anyToWriteError ind _ = WriteFailure ind (-1) "Unknown bson value" + -- * Read data ReadMode = diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index fb0712f..33232cc 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -5,7 +5,7 @@ module QuerySpec (spec) where import Data.String (IsString(..)) import TestImport import Control.Exception -import Control.Monad (forM_) +import Control.Monad (forM_, when) import System.Environment (getEnv) import System.IO.Error (catchIOError) import qualified Data.List as L @@ -23,6 +23,11 @@ db action = do close pipe return result +getWireVersion :: IO Int +getWireVersion = db $ do + sd <- retrieveServerData + return $ maxWireVersion sd + withCleanDatabase :: ActionWith () -> IO () withCleanDatabase action = dropDB >> action () >> dropDB >> return () where @@ -192,109 +197,125 @@ spec = around withCleanDatabase $ do describe "updateMany" $ do it "updates value" $ do - _id <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] - result <- db $ rest =<< find (select [] "team") - result `shouldBe` [["_id" =: _id, "name" =: "Yankees", "league" =: "American"]] - _ <- db $ updateMany "team" [([ "_id" =: _id] - , ["$set" =: ["league" =: "European"]] - , [])] - updatedResult <- db $ rest =<< find (select [] "team") - updatedResult `shouldBe` [["_id" =: _id, "name" =: "Yankees", "league" =: "European"]] + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _id <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] + result <- db $ rest =<< find (select [] "team") + result `shouldBe` [["_id" =: _id, "name" =: "Yankees", "league" =: "American"]] + _ <- db $ updateMany "team" [([ "_id" =: _id] + , ["$set" =: ["league" =: "European"]] + , [])] + updatedResult <- db $ rest =<< find (select [] "team") + updatedResult `shouldBe` [["_id" =: _id, "name" =: "Yankees", "league" =: "European"]] it "upserts value" $ do - c <- db $ count (select [] "team") - c `shouldBe` 0 - _ <- db $ updateMany "team" [( [] - , ["name" =: "Giants", "league" =: "MLB"] - , [Upsert] - )] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - map L.sort updatedResult `shouldBe` [["league" =: "MLB", "name" =: "Giants"]] + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + c <- db $ count (select [] "team") + c `shouldBe` 0 + _ <- db $ updateMany "team" [( [] + , ["name" =: "Giants", "league" =: "MLB"] + , [Upsert] + )] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + map L.sort updatedResult `shouldBe` [["league" =: "MLB", "name" =: "Giants"]] it "updates all documents with Multi enabled" $ do - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "MiLB"] - _ <- db $ updateMany "team" [( ["name" =: "Yankees"] - , ["$set" =: ["league" =: "MLB"]] - , [MultiUpdate] - )] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB", "name" =: "Yankees"] - , ["league" =: "MLB", "name" =: "Yankees"] - ] + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] + _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "MiLB"] + _ <- db $ updateMany "team" [( ["name" =: "Yankees"] + , ["$set" =: ["league" =: "MLB"]] + , [MultiUpdate] + )] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB", "name" =: "Yankees"] + , ["league" =: "MLB", "name" =: "Yankees"] + ] it "updates one document when there is no Multi option" $ do - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "MiLB"] - _ <- db $ updateMany "team" [( ["name" =: "Yankees"] - , ["$set" =: ["league" =: "MLB"]] - , [] - )] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB", "name" =: "Yankees"] - , ["league" =: "MiLB", "name" =: "Yankees"] - ] + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] + _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "MiLB"] + _ <- db $ updateMany "team" [( ["name" =: "Yankees"] + , ["$set" =: ["league" =: "MLB"]] + , [] + )] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB", "name" =: "Yankees"] + , ["league" =: "MiLB", "name" =: "Yankees"] + ] it "can process different updates" $ do - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] - _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB"] - _ <- db $ updateMany "team" [ ( ["name" =: "Yankees"] - , ["$set" =: ["league" =: "MiLB"]] - , [] - ) - , ( ["name" =: "Giants"] - , ["$set" =: ["league" =: "MLB"]] - , [] - ) - ] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB" , "name" =: "Giants"] - , ["league" =: "MiLB", "name" =: "Yankees"] - ] - it "can process different updates" $ do - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American", "score" =: (Nothing :: Maybe Int)] - _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB", "score" =: (1 :: Int)] - updateResult <- (db $ updateMany "team" [ ( ["name" =: "Yankees"] - , ["$inc" =: ["score" =: (1 :: Int)]] - , [] - ) - , ( ["name" =: "Giants"] - , ["$inc" =: ["score" =: (2 :: Int)]] - , [] - ) - ]) - failed updateResult `shouldBe` True - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] - , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (1 :: Int)] - ] - it "can handle big updates" $ do - let docs = (flip map) [0..20000] $ \i -> - ["name" =: (T.pack $ "name " ++ (show i))] - ids <- db $ insertAll "bigCollection" docs - let updateDocs = (flip map) ids (\i -> ( [ "_id" =: i] - , ["$set" =: ["name" =: ("name " ++ (show i))]] + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] + _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB"] + _ <- db $ updateMany "team" [ ( ["name" =: "Yankees"] + , ["$set" =: ["league" =: "MiLB"]] , [] - )) - _ <- db $ updateMany "team" updateDocs - updatedResult <- db $ rest =<< find (select [] "team") - forM_ updatedResult $ \r -> let (i :: ObjectId) = "_id" `at` r - in (("name" `at` r) :: String) `shouldBe` ("name" ++ (show i)) + ) + , ( ["name" =: "Giants"] + , ["$set" =: ["league" =: "MLB"]] + , [] + ) + ] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB" , "name" =: "Giants"] + , ["league" =: "MiLB", "name" =: "Yankees"] + ] + it "can process different updates" $ do + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American", "score" =: (Nothing :: Maybe Int)] + _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB", "score" =: (1 :: Int)] + updateResult <- (db $ updateMany "team" [ ( ["name" =: "Yankees"] + , ["$inc" =: ["score" =: (1 :: Int)]] + , [] + ) + , ( ["name" =: "Giants"] + , ["$inc" =: ["score" =: (2 :: Int)]] + , [] + ) + ]) + failed updateResult `shouldBe` True + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] + , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (1 :: Int)] + ] + it "can handle big updates" $ do + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + let docs = (flip map) [0..20000] $ \i -> + ["name" =: (T.pack $ "name " ++ (show i))] + ids <- db $ insertAll "bigCollection" docs + let updateDocs = (flip map) ids (\i -> ( [ "_id" =: i] + , ["$set" =: ["name" =: ("name " ++ (show i))]] + , [] + )) + _ <- db $ updateMany "team" updateDocs + updatedResult <- db $ rest =<< find (select [] "team") + forM_ updatedResult $ \r -> let (i :: ObjectId) = "_id" `at` r + in (("name" `at` r) :: String) `shouldBe` ("name" ++ (show i)) describe "updateAll" $ do it "can process different updates" $ do - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American", "score" =: (Nothing :: Maybe Int)] - _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB", "score" =: (1 :: Int)] - updateResult <- (db $ updateAll "team" [ ( ["name" =: "Yankees"] - , ["$inc" =: ["score" =: (1 :: Int)]] - , [] - ) - , ( ["name" =: "Giants"] - , ["$inc" =: ["score" =: (2 :: Int)]] - , [] - ) - ]) - failed updateResult `shouldBe` True - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] - , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (3 :: Int)] - ] + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American", "score" =: (Nothing :: Maybe Int)] + _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB", "score" =: (1 :: Int)] + updateResult <- (db $ updateAll "team" [ ( ["name" =: "Yankees"] + , ["$inc" =: ["score" =: (1 :: Int)]] + , [] + ) + , ( ["name" =: "Giants"] + , ["$inc" =: ["score" =: (2 :: Int)]] + , [] + ) + ]) + failed updateResult `shouldBe` True + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] + , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (3 :: Int)] + ] describe "delete" $ do it "actually deletes something" $ do @@ -336,34 +357,40 @@ spec = around withCleanDatabase $ do describe "deleteMany" $ do it "actually deletes something" $ do - _ <- db $ insert "team" ["name" =: ("Giants" :: String)] - _ <- db $ insert "team" ["name" =: ("Yankees" :: String)] - _ <- db $ deleteMany "team" [ (["name" =: ("Giants" :: String)], []) - , (["name" =: ("Yankees" :: String)], []) - ] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - length updatedResult `shouldBe` 0 + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "team" ["name" =: ("Giants" :: String)] + _ <- db $ insert "team" ["name" =: ("Yankees" :: String)] + _ <- db $ deleteMany "team" [ (["name" =: ("Giants" :: String)], []) + , (["name" =: ("Yankees" :: String)], []) + ] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + length updatedResult `shouldBe` 0 describe "deleteAll" $ do it "actually deletes something" $ do - _ <- db $ insert "team" [ "name" =: ("Giants" :: String) - , "score" =: (Nothing :: Maybe Int) - ] - _ <- db $ insert "team" [ "name" =: ("Yankees" :: String) - , "score" =: (1 :: Int) - ] - _ <- db $ deleteAll "team" [ (["name" =: ("Giants" :: String)], []) - , (["name" =: ("Yankees" :: String)], []) - ] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - length updatedResult `shouldBe` 0 + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "team" [ "name" =: ("Giants" :: String) + , "score" =: (Nothing :: Maybe Int) + ] + _ <- db $ insert "team" [ "name" =: ("Yankees" :: String) + , "score" =: (1 :: Int) + ] + _ <- db $ deleteAll "team" [ (["name" =: ("Giants" :: String)], []) + , (["name" =: ("Yankees" :: String)], []) + ] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + length updatedResult `shouldBe` 0 it "can handle big deletes" $ do - let docs = (flip map) [0..20000] $ \i -> - ["name" =: (T.pack $ "name " ++ (show i))] - _ <- db $ insertAll "bigCollection" docs - _ <- db $ deleteAll "bigCollection" $ map (\d -> (d, [])) docs - updatedResult <- db $ rest =<< find ((select [] "bigCollection") {project = ["_id" =: (0 :: Int)]}) - length updatedResult `shouldBe` 0 + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + let docs = (flip map) [0..20000] $ \i -> + ["name" =: (T.pack $ "name " ++ (show i))] + _ <- db $ insertAll "bigCollection" docs + _ <- db $ deleteAll "bigCollection" $ map (\d -> (d, [])) docs + updatedResult <- db $ rest =<< find ((select [] "bigCollection") {project = ["_id" =: (0 :: Int)]}) + length updatedResult `shouldBe` 0 describe "allCollections" $ do it "returns all collections in a database" $ do From b6078cc19dcfa806e27274f1524f382b413319bb Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 4 Feb 2017 14:47:33 -0800 Subject: [PATCH 35/49] Wrap lines --- Database/MongoDB/Query.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 1d12379..cf49d4c 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -535,15 +535,18 @@ insertBlock opts col (prevCount, docs) = do case (look "writeErrors" doc, look "writeConcernError" doc) of (Nothing, Nothing) -> return $ Right $ map (valueAt "_id") docs' (Just err, Nothing) -> do - return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten since we can not really report meaningful result for every document + return $ Left $ WriteFailure + prevCount -- TODO: insert error reporting should be rewritten since we can not really report meaningful result for every document (maybe 0 id $ lookup "ok" doc) (show err) (Nothing, Just err) -> do - return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten -----''------ + return $ Left $ WriteFailure + prevCount -- TODO: insert error reporting should be rewritten -----''------ (maybe 0 id $ lookup "ok" doc) (show err) (Just err, Just writeConcernErr) -> do - return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten -----''------ + return $ Left $ WriteFailure + prevCount -- TODO: insert error reporting should be rewritten -----''------ (maybe 0 id $ lookup "ok" doc) (show err ++ show writeConcernErr) From 7ae65ce487124573edf01097a41ee64dbfa6e80e Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 12 Feb 2017 11:59:15 -0800 Subject: [PATCH 36/49] Assign ids before insert block --- Database/MongoDB/Query.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index cf49d4c..46272b1 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -419,7 +419,8 @@ write notice = asks mongoWriteMode >>= \mode -> case mode of insert :: (MonadIO m) => Collection -> Document -> Action m Value -- ^ Insert document into collection and return its \"_id\" value, which is created automatically if not supplied insert col doc = do - res <- insertBlock [] col (0, [doc]) + doc' <- liftIO $ assignId doc + res <- insertBlock [] col (0, [doc']) case res of Left failure -> liftIO $ throwIO failure Right r -> return $ head r @@ -472,6 +473,7 @@ insert' :: (MonadIO m) insert' opts col docs = do p <- asks mongoPipe let sd = P.serverData p + docs' <- liftIO $ mapM assignId docs mode <- asks mongoWriteMode let writeConcern = case mode of NoConfirm -> ["w" =: (0 :: Int)] @@ -484,7 +486,7 @@ insert' opts col docs = do -- document should be subtracted from -- the overall size (maxWriteBatchSize sd) - docs + docs' let chunks = if ordered then takeRightsUpToLeft preChunks @@ -509,13 +511,12 @@ insertBlock :: (MonadIO m) insertBlock _ _ (_, []) = return $ Right [] insertBlock opts col (prevCount, docs) = do db <- thisDatabase - docs' <- liftIO $ mapM assignId docs p <- asks mongoPipe let sd = P.serverData p if (maxWireVersion sd < 2) then do - res <- liftDB $ write (Insert (db <.> col) opts docs') + res <- liftDB $ write (Insert (db <.> col) opts docs) let errorMessage = do jRes <- res em <- lookup "err" jRes @@ -525,15 +526,15 @@ insertBlock opts col (prevCount, docs) = do case errorMessage of Just failure -> return $ Left failure - Nothing -> return $ Right $ map (valueAt "_id") docs' + Nothing -> return $ Right $ map (valueAt "_id") docs else do mode <- asks mongoWriteMode let writeConcern = case mode of NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params - doc <- runCommand $ insertCommandDocument opts col docs' writeConcern + doc <- runCommand $ insertCommandDocument opts col docs writeConcern case (look "writeErrors" doc, look "writeConcernError" doc) of - (Nothing, Nothing) -> return $ Right $ map (valueAt "_id") docs' + (Nothing, Nothing) -> return $ Right $ map (valueAt "_id") docs (Just err, Nothing) -> do return $ Left $ WriteFailure prevCount -- TODO: insert error reporting should be rewritten since we can not really report meaningful result for every document From 48d8dba4e14c5c69cbad0350099be238e2aab2ae Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 5 Mar 2017 00:55:31 -0800 Subject: [PATCH 37/49] Add compound failure --- Database/MongoDB/Query.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 46272b1..5f30a92 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -130,6 +130,7 @@ data Failure = | WriteFailure Int ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string, index of failed document is the first argument | DocNotFound Selection -- ^ 'fetch' found no document matching selection | AggregateFailure String -- ^ 'aggregate' returned an error + | CompoundFailure [Failure] -- ^ When we need to aggregate several failures and report them. deriving (Show, Eq, Typeable) instance Exception Failure @@ -535,21 +536,22 @@ insertBlock opts col (prevCount, docs) = do doc <- runCommand $ insertCommandDocument opts col docs writeConcern case (look "writeErrors" doc, look "writeConcernError" doc) of (Nothing, Nothing) -> return $ Right $ map (valueAt "_id") docs - (Just err, Nothing) -> do - return $ Left $ WriteFailure - prevCount -- TODO: insert error reporting should be rewritten since we can not really report meaningful result for every document - (maybe 0 id $ lookup "ok" doc) - (show err) + (Just (Array errs), Nothing) -> do + let writeErrors = map (anyToWriteError prevCount) $ errs + let errorsWithFailureIndex = map (addFailureIndex prevCount) writeErrors + return $ Left $ CompoundFailure errorsWithFailureIndex (Nothing, Just err) -> do return $ Left $ WriteFailure - prevCount -- TODO: insert error reporting should be rewritten -----''------ + prevCount (maybe 0 id $ lookup "ok" doc) (show err) - (Just err, Just writeConcernErr) -> do - return $ Left $ WriteFailure - prevCount -- TODO: insert error reporting should be rewritten -----''------ + (Just (Array errs), Just writeConcernErr) -> do + let writeErrors = map (anyToWriteError prevCount) $ errs + let errorsWithFailureIndex = map (addFailureIndex prevCount) writeErrors + return $ Left $ CompoundFailure $ (WriteFailure + prevCount (maybe 0 id $ lookup "ok" doc) - (show err ++ show writeConcernErr) + (show writeConcernErr)) : errorsWithFailureIndex splitAtLimit :: Int -> Int -> [Document] -> [Either Failure [Document]] splitAtLimit maxSize maxCount list = chop (go 0 0 []) list From 2a5bfa44e26c68d11f67f8fdf5f05be1a9f13182 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 8 Apr 2017 12:31:24 -0700 Subject: [PATCH 38/49] Handle unknown documents in insertMany reply --- Database/MongoDB/Query.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 5f30a92..8940c0b 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -128,9 +128,11 @@ data Failure = | CursorNotFoundFailure CursorId -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set) | QueryFailure ErrorCode String -- ^ Query failed for some reason as described in the string | WriteFailure Int ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string, index of failed document is the first argument + -- | WriteConcernFailure Int String -- ^ Write concern error. It's reported only by insert, update, delete commands. Not by wire protocol. | DocNotFound Selection -- ^ 'fetch' found no document matching selection | AggregateFailure String -- ^ 'aggregate' returned an error | CompoundFailure [Failure] -- ^ When we need to aggregate several failures and report them. + | ProtocolFailure Int String -- ^ The structure of the returned documents doesn't match what we expected deriving (Show, Eq, Typeable) instance Exception Failure @@ -552,6 +554,11 @@ insertBlock opts col (prevCount, docs) = do prevCount (maybe 0 id $ lookup "ok" doc) (show writeConcernErr)) : errorsWithFailureIndex + (Just unknownValue, Nothing) -> do + return $ Left $ ProtocolFailure prevCount $ "Expected array of errors. Received: " ++ show unknownValue + (Just unknownValue, Just writeConcernErr) -> do + return $ Left $ CompoundFailure $ [ ProtocolFailure prevCount $ "Expected array of errors. Received: " ++ show unknownValue + , WriteFailure prevCount (maybe 0 id $ lookup "ok" doc) $ show writeConcernErr] splitAtLimit :: Int -> Int -> [Document] -> [Either Failure [Document]] splitAtLimit maxSize maxCount list = chop (go 0 0 []) list From d6419daa50740591f2f799204901009142dbfab6 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 8 Apr 2017 12:39:32 -0700 Subject: [PATCH 39/49] Move WriteConcernError to Failure --- Database/MongoDB/Query.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 8940c0b..0e36621 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -128,7 +128,7 @@ data Failure = | CursorNotFoundFailure CursorId -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set) | QueryFailure ErrorCode String -- ^ Query failed for some reason as described in the string | WriteFailure Int ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string, index of failed document is the first argument - -- | WriteConcernFailure Int String -- ^ Write concern error. It's reported only by insert, update, delete commands. Not by wire protocol. + | WriteConcernFailure Int String -- ^ Write concern error. It's reported only by insert, update, delete commands. Not by wire protocol. | DocNotFound Selection -- ^ 'fetch' found no document matching selection | AggregateFailure String -- ^ 'aggregate' returned an error | CompoundFailure [Failure] -- ^ When we need to aggregate several failures and report them. @@ -163,7 +163,7 @@ data WriteResult = WriteResult -- ^ 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] , writeErrors :: [Failure] - , writeConcernErrors :: [WriteConcernError] + , writeConcernErrors :: [Failure] } deriving Show instance Result WriteResult where @@ -178,9 +178,6 @@ data Upserted = Upserted , upsertedId :: ObjectId } deriving Show -data WriteConcernError = WriteConcernError Int String - deriving Show - master :: AccessMode -- ^ Same as 'ConfirmWrites' [] master = ConfirmWrites [] @@ -803,8 +800,8 @@ docToWriteError doc = WriteFailure ind code msg code = at "code" doc msg = at "errmsg" doc -docToWriteConcernError :: Document -> WriteConcernError -docToWriteConcernError doc = WriteConcernError code msg +docToWriteConcernError :: Document -> Failure +docToWriteConcernError doc = WriteConcernFailure code msg where code = at "code" doc msg = at "errmsg" doc @@ -924,13 +921,13 @@ deleteBlock ordered col (prevCount, docs) = do return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [] (Nothing, Just (Doc err)) -> do return $ WriteResult True 0 Nothing n [] [] [ - WriteConcernError + WriteConcernFailure (fromMaybe (-1) $ err !? "code") (fromMaybe "" $ err !? "errmsg") ] (Just (Array err), Just (Doc writeConcernErr)) -> do return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [ - WriteConcernError + WriteConcernFailure (fromMaybe (-1) $ writeConcernErr !? "code") (fromMaybe "" $ writeConcernErr !? "errmsg") ] From 1d6d6ca9c01c8dd63bbb2896e0db632b5cd760ba Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 9 Apr 2017 22:23:34 -0700 Subject: [PATCH 40/49] Rewrite deleteBlock --- Database/MongoDB/Query.hs | 57 ++++++++++++++++++++++++++++----------- 1 file changed, 41 insertions(+), 16 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 0e36621..9380a45 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -915,22 +915,47 @@ deleteBlock ordered col (prevCount, docs) = do Confirm params -> params doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern let n = fromMaybe 0 $ doc !? "n" - case (look "writeErrors" doc, look "writeConcernError" doc) of - (Nothing, Nothing) -> return $ WriteResult False 0 Nothing n [] [] [] - (Just (Array err), Nothing) -> do - return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [] - (Nothing, Just (Doc err)) -> do - return $ WriteResult True 0 Nothing n [] [] [ - WriteConcernFailure - (fromMaybe (-1) $ err !? "code") - (fromMaybe "" $ err !? "errmsg") - ] - (Just (Array err), Just (Doc writeConcernErr)) -> do - return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [ - WriteConcernFailure - (fromMaybe (-1) $ writeConcernErr !? "code") - (fromMaybe "" $ writeConcernErr !? "errmsg") - ] + let writeErrorsResults = + case look "writeErrors" doc of + Nothing -> WriteResult False 0 Nothing n [] [] [] + Just (Array err) -> WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [] + Just unknownErr -> WriteResult + True + 0 + Nothing + 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)] + return $ mergeWriteResults writeErrorsResults writeConcernResults anyToWriteError :: Int -> Value -> Failure anyToWriteError ind (Doc d) = docToWriteError d From 4855793dd7f3f926111cb50382a2dd623b973db5 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 1 May 2017 19:57:43 -0700 Subject: [PATCH 41/49] Rewrite updateBlock --- Database/MongoDB/Query.hs | 70 +++++++++++++++++++++++++++------------ 1 file changed, 48 insertions(+), 22 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 9380a45..35f862f 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -52,7 +52,7 @@ import Control.Monad (unless, replicateM, liftM, liftM2) import Data.Int (Int32, Int64) import Data.Either (lefts, rights) import Data.List (foldl1') -import Data.Maybe (listToMaybe, catMaybes, isNothing, maybeToList) +import Data.Maybe (listToMaybe, catMaybes, isNothing) import Data.Word (Word32) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mappend) @@ -742,20 +742,52 @@ updateBlock ordered col (prevCount, docs) = do NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params 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 upsertedDocs = fromMaybe [] (doc !? "upserted") - return $ WriteResult - ((not $ true1 "ok" doc) || (not $ null writeErrors) || (not $ null writeConcernErrors)) - (at "n" doc) - (at "nModified" doc) - 0 - (map docToUpserted upsertedDocs) - (map (addFailureIndex prevCount) writeErrors) - writeConcernErrors + let n = fromMaybe 0 $ doc !? "n" + let writeErrorsResults = + case look "writeErrors" doc of + Nothing -> WriteResult False 0 Nothing n [] [] [] + Just (Array err) -> WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [] + Just unknownErr -> WriteResult + True + 0 + Nothing + 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] @@ -800,12 +832,6 @@ docToWriteError doc = WriteFailure ind code msg code = at "code" doc msg = at "errmsg" doc -docToWriteConcernError :: Document -> Failure -docToWriteConcernError doc = WriteConcernFailure code msg - where - code = at "code" doc - msg = at "errmsg" doc - -- ** Delete delete :: (MonadIO m) @@ -958,8 +984,8 @@ deleteBlock ordered col (prevCount, docs) = do return $ mergeWriteResults writeErrorsResults writeConcernResults anyToWriteError :: Int -> Value -> Failure -anyToWriteError ind (Doc d) = docToWriteError d -anyToWriteError ind _ = WriteFailure ind (-1) "Unknown bson value" +anyToWriteError _ (Doc d) = docToWriteError d +anyToWriteError ind _ = ProtocolFailure ind "Unknown bson value" -- * Read From 4f5fa5bd3c86ea196d91096a9ab6488024d00349 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 6 May 2017 17:39:23 -0700 Subject: [PATCH 42/49] Update change log --- CHANGELOG.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index bfdb2f0..66a5163 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Package_versioning_policy). +## [2.3.0] - unreleased + +### Changed +- Update and delete results are squashed into one WriteResult type +- Functions insertMany, updateMany, deleteMany are rewritten to properly report + various errors + ## [2.2.0] - 2017-04-08 ### Added From 161ca964cb2875cd1848f0a5a0400c7a34380a50 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 21 May 2017 00:31:49 -0700 Subject: [PATCH 43/49] Fix wording in docs --- Database/MongoDB/Query.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 35f862f..c1b5751 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -160,7 +160,8 @@ data WriteResult = WriteResult , nMatched :: 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 meaningless if we can't calculate the number of modified documents. , upserted :: [Upserted] , writeErrors :: [Failure] , writeConcernErrors :: [Failure] From 2984a9b57aed3341965e21b593f6c25d38a9077f Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 21 May 2017 00:32:13 -0700 Subject: [PATCH 44/49] Rewrite function in a shorter way --- Database/MongoDB/Query.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index c1b5751..dd8a571 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -100,6 +100,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B +import qualified Data.Either as E import qualified Crypto.Hash.MD5 as MD5 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.MAC.HMAC as HMAC @@ -462,11 +463,7 @@ insertCommandDocument opts col docs writeConcern = ] takeRightsUpToLeft :: [Either a b] -> [b] -takeRightsUpToLeft l = reverse $ go l [] - where - go [] !res = res - go ((Right x):xs) !res = go xs (x:res) - go ((Left _):_) !res = res +takeRightsUpToLeft l = E.rights $ takeWhile E.isRight l insert' :: (MonadIO m) => [InsertOption] -> Collection -> [Document] -> Action m [Value] From 8dac250e10a565a6283ca7f2842aac0b664f3b1e Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 28 May 2017 12:38:34 -0700 Subject: [PATCH 45/49] Add test for correct delete count --- test/QuerySpec.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index 33232cc..d1213a4 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -392,6 +392,15 @@ spec = around withCleanDatabase $ do updatedResult <- db $ rest =<< find ((select [] "bigCollection") {project = ["_id" =: (0 :: Int)]}) length updatedResult `shouldBe` 0 + describe "deleteAll" $ do + it "returns correct result" $ do + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "testCollection" [ "myField" =: "myValue" ] + _ <- db $ insert "testCollection" [ "myField" =: "myValue" ] + res <- db $ deleteAll "testCollection" [ (["myField" =: "myValue"], []) ] + nRemoved res `shouldBe` 2 + describe "allCollections" $ do it "returns all collections in a database" $ do _ <- db $ insert "team1" ["name" =: "Yankees", "league" =: "American"] From 50b7fef240069d6078a55b0ad71d2f209c66baf7 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 28 May 2017 12:58:29 -0700 Subject: [PATCH 46/49] Fix delete count --- Database/MongoDB/Query.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index dd8a571..93ffb33 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -939,15 +939,18 @@ deleteBlock ordered col (prevCount, docs) = do Confirm params -> params doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern let n = fromMaybe 0 $ doc !? "n" + liftIO $ putStrLn $ "result of delete block: " ++ (show n) + + let successResults = WriteResult False 0 Nothing n [] [] [] let writeErrorsResults = case look "writeErrors" doc of - Nothing -> WriteResult False 0 Nothing n [] [] [] - Just (Array err) -> WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [] + Nothing -> WriteResult False 0 Nothing 0 [] [] [] + Just (Array err) -> WriteResult True 0 Nothing 0 [] (map (anyToWriteError prevCount) err) [] Just unknownErr -> WriteResult True 0 Nothing - n + 0 [] [ ProtocolFailure prevCount @@ -956,12 +959,12 @@ deleteBlock ordered col (prevCount, docs) = do [] let writeConcernResults = case look "writeConcernError" doc of - Nothing -> WriteResult False 0 Nothing n [] [] [] + Nothing -> WriteResult False 0 Nothing 0 [] [] [] Just (Doc err) -> WriteResult True 0 Nothing - n + 0 [] [] [ WriteConcernFailure @@ -972,14 +975,14 @@ deleteBlock ordered col (prevCount, docs) = do True 0 Nothing - n + 0 [] [] [ ProtocolFailure prevCount $ "Expected doc in writeConcernError, but received: " ++ (show unknownErr)] - return $ mergeWriteResults writeErrorsResults writeConcernResults + return $ foldl1' mergeWriteResults [successResults, writeErrorsResults, writeConcernResults] anyToWriteError :: Int -> Value -> Failure anyToWriteError _ (Doc d) = docToWriteError d From a1e19379f651535dcd55116d72f3439ee0f18b5d Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 29 May 2017 12:58:39 -0700 Subject: [PATCH 47/49] Add test and fix for updateMany nMatched and nModified --- Database/MongoDB/Query.hs | 22 ++++++++++++---------- test/QuerySpec.hs | 10 ++++++++-- 2 files changed, 20 insertions(+), 12 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 93ffb33..21fe06e 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -744,13 +744,13 @@ updateBlock ordered col (prevCount, docs) = do let n = fromMaybe 0 $ doc !? "n" let writeErrorsResults = case look "writeErrors" doc of - Nothing -> WriteResult False 0 Nothing n [] [] [] - Just (Array err) -> WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [] + Nothing -> WriteResult False 0 (Just 0) 0 [] [] [] + Just (Array err) -> WriteResult True 0 (Just 0) 0 [] (map (anyToWriteError prevCount) err) [] Just unknownErr -> WriteResult True 0 - Nothing - n + (Just 0) + 0 [] [ ProtocolFailure prevCount @@ -760,12 +760,12 @@ updateBlock ordered col (prevCount, docs) = do let writeConcernResults = case look "writeConcernError" doc of - Nothing -> WriteResult False 0 Nothing n [] [] [] + Nothing -> WriteResult False 0 (Just 0) 0 [] [] [] Just (Doc err) -> WriteResult True 0 - Nothing - n + (Just 0) + 0 [] [] [ WriteConcernFailure @@ -775,8 +775,8 @@ updateBlock ordered col (prevCount, docs) = do Just unknownErr -> WriteResult True 0 - Nothing - n + (Just 0) + 0 [] [] [ ProtocolFailure @@ -785,7 +785,9 @@ updateBlock ordered col (prevCount, docs) = do ++ (show unknownErr)] let upsertedList = map docToUpserted $ fromMaybe [] (doc !? "upserted") - return $ mergeWriteResults writeErrorsResults writeConcernResults {upserted = upsertedList, nModified = at "nModified" doc} + liftIO $ putStrLn $ show doc + let successResults = WriteResult False n (doc !? "nModified") 0 upsertedList [] [] + return $ foldl1' mergeWriteResults [writeErrorsResults, writeConcernResults, successResults] interruptibleFor :: (Monad m, Result b) => Bool -> [a] -> (a -> m b) -> m [b] diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index d1213a4..b2b1426 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -316,6 +316,14 @@ spec = around withCleanDatabase $ do (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (3 :: Int)] ] + it "returns correct number of matched and modified" $ do + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insertMany "testCollection" [["myField" =: "myValue"], ["myField2" =: "myValue2"]] + _ <- db $ insertMany "testCollection" [["myField" =: "myValue"], ["myField2" =: "myValue2"]] + res <- db $ updateMany "testCollection" [(["myField" =: "myValue"], ["$set" =: ["myField" =: "newValue"]], [MultiUpdate])] + nMatched res `shouldBe` 2 + nModified res `shouldBe` (Just 2) describe "delete" $ do it "actually deletes something" $ do @@ -391,8 +399,6 @@ spec = around withCleanDatabase $ do _ <- db $ deleteAll "bigCollection" $ map (\d -> (d, [])) docs updatedResult <- db $ rest =<< find ((select [] "bigCollection") {project = ["_id" =: (0 :: Int)]}) length updatedResult `shouldBe` 0 - - describe "deleteAll" $ do it "returns correct result" $ do wireVersion <- getWireVersion when (wireVersion > 1) $ do From 9bd0dff6eeb91409e4f161d575f9c1e7f6e14a06 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 29 May 2017 16:11:25 -0700 Subject: [PATCH 48/49] Add unit test for upserted --- test/QuerySpec.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index b2b1426..3dfb8c6 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -324,6 +324,11 @@ spec = around withCleanDatabase $ do res <- db $ updateMany "testCollection" [(["myField" =: "myValue"], ["$set" =: ["myField" =: "newValue"]], [MultiUpdate])] nMatched res `shouldBe` 2 nModified res `shouldBe` (Just 2) + it "returns correct number of upserted" $ do + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + res <- db $ updateMany "testCollection" [(["myField" =: "myValue"], ["$set" =: ["myfield" =: "newValue"]], [Upsert])] + (length $ upserted res) `shouldBe` 1 describe "delete" $ do it "actually deletes something" $ do From 571fe47d82ee68b2bc203842195acb2758b63b60 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 29 May 2017 16:34:35 -0700 Subject: [PATCH 49/49] Test for non multi update --- test/QuerySpec.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index 3dfb8c6..08a33fa 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -329,6 +329,14 @@ spec = around withCleanDatabase $ do when (wireVersion > 1) $ do res <- db $ updateMany "testCollection" [(["myField" =: "myValue"], ["$set" =: ["myfield" =: "newValue"]], [Upsert])] (length $ upserted res) `shouldBe` 1 + it "updates only one doc without multi update" $ do + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insertMany "testCollection" [["myField" =: "myValue"], ["myField2" =: "myValue2"]] + _ <- db $ insertMany "testCollection" [["myField" =: "myValue"], ["myField2" =: "myValue2"]] + res <- db $ updateMany "testCollection" [(["myField" =: "myValue"], ["$set" =: ["myField" =: "newValue"]], [])] + nMatched res `shouldBe` 1 + nModified res `shouldBe` (Just 1) describe "delete" $ do it "actually deletes something" $ do