persistent-mongoDB 2.13.0.1 → 2.13.0.2

raw patch · 5 files changed

+47/−43 lines, 5 filesdep ~mongoDBPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: mongoDB

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Database/Persist/MongoDB.hs +28/−34
• persistent-mongoDB.cabal +4/−4
• test/EmbedTestMongo.hs +2/−0
• test/main.hs +9/−5

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

@@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' -- | Use persistent-mongodb the same way you would use other persistent@@ -113,7 +114,7 @@     ) 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)@@ -561,16 +562,15 @@         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@@ -578,7 +578,7 @@         either err instantiate result       where         instantiate doc = do-            Entity _ rec <- fromPersistValuesThrow t doc+            rec <- entityVal <$> fromPersistValuesThrow t doc             return rec         err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg         t = entityDefFromKey key@@ -589,7 +589,7 @@             case d of               Nothing -> return Nothing               Just doc -> do-                Entity _ ent <- fromPersistValuesThrow t doc+                ent <- entityVal <$> fromPersistValuesThrow t doc                 return $ Just ent           where             t = entityDefFromKey k@@ -607,10 +607,9 @@  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@@ -629,12 +628,14 @@     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"@@ -697,16 +698,14 @@ 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@@ -721,7 +720,6 @@         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@@ -731,9 +729,7 @@         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@@ -743,8 +739,6 @@                     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)

@@ -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 <greg@gregweber.info>@@ -26,11 +26,11 @@                    , bytestring                    , cereal             >= 0.5                    , conduit            >= 1.2-                   , http-api-data      >= 0.3.7     && < 0.5-                   , mongoDB            >= 2.3       && < 2.8+                   , http-api-data      >= 0.3.7     && < 0.7+                   , mongoDB            >= 2.7.1.2   && < 2.8                    , network            >= 2.6                    , path-pieces        >= 0.2-                   , resource-pool      >= 0.2       && < 0.3+                   , resource-pool      >= 0.2       && < 0.5                    , resourcet          >= 1.1                    , text               >= 1.2                    , time

@@ -10,6 +10,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-unused-top-binds -Wno-orphans -O0 #-} module EmbedTestMongo (specs) where@@ -428,6 +429,7 @@     it "re-orders json inserted from another source" $ db $ do+    liftIO $ pendingWith "mongoimport fails on GitHub CI"     let cname = T.unpack $ collectionName (error "ListEmbed" :: ListEmbed)     liftIO $ putStrLn =<< readProcess "mongoimport" ["-d", T.unpack dbName, "-c", cname] "{ \"nested\": [{ \"one\": 1, \"two\": 2 }, { \"two\": 2, \"one\": 1}], \"two\": 2, \"one\": 1, \"_id\" : { \"$oid\" : \"50184f5a92d7ae0000001e89\" } }" 

@@ -1,15 +1,17 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE DataKinds, ExistentialQuantification #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}  import qualified Data.ByteString as BS@@ -17,8 +19,8 @@ import qualified Data.Text as T import Data.Time import Database.MongoDB (runCommand1)-import Text.Blaze.Html import Test.QuickCheck+import Text.Blaze.Html  -- FIXME: should this be added? (RawMongoHelpers module wasn't used) -- import qualified RawMongoHelpers@@ -53,6 +55,7 @@ import qualified Recursive import qualified RenameTest import qualified SumTypeTest+import qualified TypeLitFieldDefsTest import qualified UpsertTest  type Tuple = (,)@@ -130,6 +133,7 @@         (db' (deleteWhere ([] :: [Filter (LargeNumberTest.NumberGeneric backend)])))     MaxLenTest.specsWith dbNoCleanup     MaybeFieldDefsTest.specsWith dbNoCleanup+    TypeLitFieldDefsTest.specsWith dbNoCleanup     Recursive.specsWith (db' Recursive.cleanup)      SumTypeTest.specsWith (dbNoCleanup) Nothing