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