Update mongoDB backend mongoDB driver interface

.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