Update mongoDB backend mongoDB driver interface

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)