From e6a0a9f464bdef96443c9bd0647edcd4b250d90b Mon Sep 17 00:00:00 2001 From: Dary Cabrera Date: Fri, 6 Sep 2024 16:13:55 -0600 Subject: [PATCH] Update mongoDB backend mongoDB driver interface (#1545) * Remove deprecated mongo snapshot query option This flag was deprecated since Mongo Server 3.7.4. Its presence in queries produce failures in the mongoDB driver when interfacing against Mongo Servers >= version 6.0. * Update mongo deletion calls Replace the mongo driver's delete calls with deleteMany to restore correct behavior with Mongo 6.0 while preserving compatibility with Mongo 5.0. * Update mongo update and upsert calls Replace the mongo driver's modify(update) calls with updateMany to restore correct behavior in Mongo 6.0 and above. The key change here is that the writeConcern is now back to being set based on environment context rather than being hardcoded to "0". * Update mongoDB lib version constraint Match the current stack snapshot at version 2.7.1.2. * Remove obsolete GHC CI builds Co-authored-by: Matt Parsons * persistent-mongoDB-2.13.0.2 --------- Co-authored-by: Matt Parsons --- .github/workflows/haskell.yml | 2 - persistent-mongoDB/ChangeLog.md | 4 ++ .../Database/Persist/MongoDB.hs | 57 ++++++++----------- persistent-mongoDB/persistent-mongoDB.cabal | 4 +- 4 files changed, 31 insertions(+), 36 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 4bdab79f1..6ca754c22 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -47,8 +47,6 @@ jobs: matrix: cabal: ["3.10"] ghc: - - "8.4.4" - - "8.6.5" - "8.8.4" - "8.10.7" - "9.0.2" diff --git a/persistent-mongoDB/ChangeLog.md b/persistent-mongoDB/ChangeLog.md index 607d748fa..7bf562515 100644 --- a/persistent-mongoDB/ChangeLog.md +++ b/persistent-mongoDB/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent-mongoDB +## 2.13.0.2 + +* Fix behavioral compatibility with MongoDB Driver for MongoDB >= 6.0 [#1545](https://github.com/yesodweb/persistent/pull/1545) + ## 2.13.0.1 * [#1367](https://github.com/yesodweb/persistent/pull/1367), diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs index d232fea10..71cd23557 100644 --- a/persistent-mongoDB/Database/Persist/MongoDB.hs +++ b/persistent-mongoDB/Database/Persist/MongoDB.hs @@ -114,7 +114,7 @@ module Database.Persist.MongoDB ) where import Control.Exception (throw, throwIO) -import Control.Monad (forM_, liftM, unless, (>=>)) +import Control.Monad (forM_, liftM, unless, (>=>), void) import Control.Monad.IO.Class (liftIO) import qualified Control.Monad.IO.Class as Trans import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) @@ -562,16 +562,15 @@ instance PersistStoreWrite DB.MongoContext where return () delete k = - DB.deleteOne DB.Select { - DB.coll = collectionNameFromKey k - , DB.selector = keyToMongoDoc k - } + void $ DB.deleteMany + (collectionNameFromKey k) + [(keyToMongoDoc k, [DB.SingleRemove])] update _ [] = return () update key upds = - DB.modify - (DB.Select (keyToMongoDoc key) (collectionNameFromKey key)) - $ updatesToDoc upds + void $ DB.updateMany + (collectionNameFromKey key) + [(keyToMongoDoc key, updatesToDoc upds, [DB.MultiUpdate])] updateGet key upds = do context <- ask @@ -608,10 +607,9 @@ instance PersistUniqueRead DB.MongoContext where instance PersistUniqueWrite DB.MongoContext where deleteBy uniq = - DB.delete DB.Select { - DB.coll = collectionName $ dummyFromUnique uniq - , DB.selector = toUniquesDoc uniq - } + void $ DB.deleteMany + (collectionName $ dummyFromUnique uniq) + [(toUniquesDoc uniq, [DB.SingleRemove])] upsert newRecord upds = do uniq <- onlyUnique newRecord @@ -630,12 +628,14 @@ instance PersistUniqueWrite DB.MongoContext where upsertBy uniq newRecord upds = do let uniqueDoc = toUniquesDoc uniq :: [DB.Field] let uniqKeys = map DB.label uniqueDoc :: [DB.Label] - let insDoc = DB.exclude uniqKeys $ toInsertDoc newRecord :: DB.Document - let selection = DB.select uniqueDoc $ collectionName newRecord :: DB.Selection mdoc <- getBy uniq - case mdoc of - Nothing -> unless (null upds) (DB.upsert selection ["$setOnInsert" DB.=: insDoc]) - Just _ -> unless (null upds) (DB.modify selection $ DB.exclude uniqKeys $ updatesToDoc upds) + let updateOrUpsert = case mdoc of + Nothing -> + let insDoc = DB.exclude uniqKeys $ toInsertDoc newRecord :: DB.Document + in [(uniqueDoc, ["$setOnInsert" DB.=: insDoc], [DB.Upsert])] + Just _ -> + [(uniqueDoc, DB.exclude uniqKeys $ updatesToDoc upds, [DB.MultiUpdate])] + unless (null upds) . void $ DB.updateMany (collectionName newRecord) updateOrUpsert newMdoc <- getBy uniq case newMdoc of Nothing -> err "possible race condition: getBy found Nothing" @@ -698,16 +698,14 @@ projectionFromRecord = projectionFromEntityDef . entityDef . Just instance PersistQueryWrite DB.MongoContext where updateWhere _ [] = return () updateWhere filts upds = - DB.modify DB.Select { - DB.coll = collectionName $ dummyFromFilts filts - , DB.selector = filtersToDoc filts - } $ updatesToDoc upds + void $ DB.updateMany + (collectionName $ dummyFromFilts filts) + [(filtersToDoc filts, updatesToDoc upds, [DB.MultiUpdate])] - deleteWhere filts = do - DB.delete DB.Select { - DB.coll = collectionName $ dummyFromFilts filts - , DB.selector = filtersToDoc filts - } + deleteWhere filts = + void $ DB.deleteMany + (collectionName $ dummyFromFilts filts) + [ (filtersToDoc filts, [])] instance PersistQueryRead DB.MongoContext where count filts = do @@ -722,7 +720,6 @@ instance PersistQueryRead DB.MongoContext where pure (cnt > 0) -- | uses cursor option NoCursorTimeout - -- If there is no sorting, it will turn the $snapshot option on -- and explicitly closes the cursor when done selectSourceRes filts opts = do context <- ask @@ -732,9 +729,7 @@ instance PersistQueryRead DB.MongoContext where close context cursor = runReaderT (DB.closeCursor cursor) context open :: DB.MongoContext -> IO DB.Cursor open = runReaderT (DB.find (makeQuery filts opts) - -- it is an error to apply $snapshot when sorting - { DB.snapshot = noSort - , DB.options = [DB.NoCursorTimeout] + { DB.options = [DB.NoCursorTimeout] }) pullCursor context cursor = do mdoc <- liftIO $ runReaderT (DB.nextBatch cursor) context @@ -744,8 +739,6 @@ instance PersistQueryRead DB.MongoContext where forM_ docs $ fromPersistValuesThrow t >=> yield pullCursor context cursor t = entityDef $ Just $ dummyFromFilts filts - (_, _, orders) = limitOffsetOrder opts - noSort = null orders selectFirst filts opts = DB.findOne (makeQuery filts opts) >>= Traversable.mapM (fromPersistValuesThrow t) diff --git a/persistent-mongoDB/persistent-mongoDB.cabal b/persistent-mongoDB/persistent-mongoDB.cabal index dcefd7d78..2c6de362b 100644 --- a/persistent-mongoDB/persistent-mongoDB.cabal +++ b/persistent-mongoDB/persistent-mongoDB.cabal @@ -1,5 +1,5 @@ name: persistent-mongoDB -version: 2.13.0.1 +version: 2.13.0.2 license: MIT license-file: LICENSE author: Greg Weber @@ -27,7 +27,7 @@ library , cereal >= 0.5 , conduit >= 1.2 , http-api-data >= 0.3.7 && < 0.7 - , mongoDB >= 2.3 && < 2.8 + , mongoDB >= 2.7.1.2 && < 2.8 , network >= 2.6 , path-pieces >= 0.2 , resource-pool >= 0.2 && < 0.5