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 <[email protected]>

* persistent-mongoDB-2.13.0.2

---------

Co-authored-by: Matt Parsons <[email protected]>

.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"

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),

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)

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 <[email protected]>
@@ -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