Fix #832: repsertMany == mapM_ (uncurry repsert) and is atomic.

persistent-mysql/ChangeLog.md

@@ -1,3 +1,9 @@
+# Changelog for persistent-mysql
+
+## 2.9.2
+
+* Fix [832](https://github.com/yesodweb/persistent/issues/832): `repsertMany` now matches `mapM_ (uncurry repsert)` and is atomic.
+
 ## 2.9.1
 
 * Added support for SQL isolation levels to via SqlBackend. [#812]

persistent-mysql/Database/Persist/MySQL.hs

@@ -69,7 +69,7 @@ import qualified Data.Text.Encoding as T
 
 import Database.Persist.Sql
 import Database.Persist.Sql.Types.Internal (mkPersistBackend, makeIsolationLevelStatement)
-import Database.Persist.Sql.Util (commaSeparated, mkUpdateText', parenWrapped)
+import qualified Database.Persist.Sql.Util as Util
 import Data.Int (Int64)
 
 import qualified Database.MySQL.Simple        as MySQL
@@ -150,6 +150,7 @@ open' ci logFunc = do
         , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615"
         , connLogFunc    = logFunc
         , connMaxParams = Nothing
+        , connRepsertManySql = Just repsertManySql
         }
 
 -- | Prepare a query.  We don't support prepared statements, but
@@ -895,6 +896,8 @@ refName (DBName table) (DBName column) =
 
 ----------------------------------------------------------------------
 
+escape :: DBName -> Text
+escape = T.pack . escapeDBName
 
 -- | Escape a database name to be included on a query.
 escapeDBName :: DBName -> String
@@ -1044,7 +1047,9 @@ mockMigration mig = do
                              connLogFunc = undefined,
                              connUpsertSql = undefined,
                              connPutManySql = undefined,
-                             connMaxParams = Nothing}
+                             connMaxParams = Nothing,
+                             connRepsertManySql = Nothing
+                             }
       result = runReaderT . runWriterT . runWriterT $ mig
   resp <- result sqlbackend
   mapM_ T.putStrLn $ map snd $ snd resp
@@ -1255,7 +1260,7 @@ mkBulkInsertQuery records fieldValues updates =
     tableName = T.pack . escapeDBName . entityDB $ entityDef'
     copyUnlessValues = map snd fieldsToMaybeCopy
     recordValues = concatMap (map toPersistValue . toPersistFields) records
-    recordPlaceholders = commaSeparated $ map (parenWrapped . commaSeparated . map (const "?") . toPersistFields) records
+    recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) records
     mkCondFieldSet n _ = T.concat
         [ n
         , "=COALESCE("
@@ -1268,16 +1273,16 @@ mkBulkInsertQuery records fieldValues updates =
         ]
     condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy
     fieldSets = map (\n -> T.concat [n, "=VALUES(", n, ")"]) updateFieldNames
-    upds = map (mkUpdateText' (pack . escapeDBName) id) updates
+    upds = map (Util.mkUpdateText' (pack . escapeDBName) id) updates
     updsValues = map (\(Update _ val _) -> toPersistValue val) updates
     updateText = case fieldSets <> upds <> condFieldSets of
         [] -> T.concat [firstField, "=", firstField]
-        xs -> commaSeparated xs
+        xs -> Util.commaSeparated xs
     q = T.concat
         [ "INSERT INTO "
         , tableName
         , " ("
-        , commaSeparated entityFieldNames
+        , Util.commaSeparated entityFieldNames
         , ") "
         , " VALUES "
         , recordPlaceholders
@@ -1286,25 +1291,33 @@ mkBulkInsertQuery records fieldValues updates =
         ]
 
 putManySql :: EntityDef -> Int -> Text
-putManySql entityDef' numRecords
-  | numRecords > 0 = q
-  | otherwise = error "putManySql: numRecords MUST be greater than 0!"
+putManySql ent n = putManySql' fields ent n
   where
-    tableName = T.pack . escapeDBName . entityDB $ entityDef'
-    fieldDbToText = T.pack . escapeDBName . fieldDB
-    entityFieldNames = map fieldDbToText (entityFields entityDef')
-    recordPlaceholders= parenWrapped . commaSeparated
-                      $ map (const "?") (entityFields entityDef')
-    mkAssignment n = T.concat [n, "=VALUES(", n, ")"]
-    fieldSets = map (mkAssignment . fieldDbToText) (entityFields entityDef')
+    fields = entityFields ent
+
+repsertManySql :: EntityDef -> Int -> Text
+repsertManySql ent n = putManySql' fields ent n
+  where
+    fields = keyAndEntityFields ent
+
+putManySql' :: [FieldDef] -> EntityDef -> Int -> Text
+putManySql' fields ent n = q
+  where
+    fieldDbToText = escape . fieldDB
+    mkAssignment f = T.concat [f, "=VALUES(", f, ")"]
+
+    table = escape . entityDB $ ent
+    columns = Util.commaSeparated $ map fieldDbToText fields
+    placeholders = map (const "?") fields
+    updates = map (mkAssignment . fieldDbToText) fields
+
     q = T.concat
         [ "INSERT INTO "
-        , tableName
-        , " ("
-        , commaSeparated entityFieldNames
-        , ") "
+        , table
+        , Util.parenWrapped columns
         , " VALUES "
-        , commaSeparated (replicate numRecords recordPlaceholders)
+        , Util.commaSeparated . replicate n
+            . Util.parenWrapped . Util.commaSeparated $ placeholders
         , " ON DUPLICATE KEY UPDATE "
-        , commaSeparated fieldSets
-        ]
+        , Util.commaSeparated updates
+        ]

persistent-mysql/persistent-mysql.cabal

@@ -1,5 +1,5 @@
 name:            persistent-mysql
-version:         2.9.1
+version:         2.9.2
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa <felipe.lessa@gmail.com>, Michael Snoyman

persistent-postgresql/ChangeLog.md

@@ -1,3 +1,9 @@
+# Changelog for persistent-postgresql
+
+## 2.9.2
+
+* Fix [832](https://github.com/yesodweb/persistent/issues/832): `repsertMany` now matches `mapM_ (uncurry repsert)` and is atomic.
+
 ## 2.9.1
 
 * Added support for SQL isolation levels to via SqlBackend. [#812]

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -31,7 +31,7 @@ module Database.Persist.Postgresql
     ) where
 
 import Database.Persist.Sql
-import Database.Persist.Sql.Util (dbIdColumnsEsc, commaSeparated, parenWrapped)
+import qualified Database.Persist.Sql.Util as Util
 import Database.Persist.Sql.Types.Internal (mkPersistBackend)
 import Data.Fixed (Pico)
 
@@ -240,6 +240,7 @@ openSimpleConn logFunc conn = do
     serverVersion <- getServerVersion conn
     return $ createBackend logFunc serverVersion smap conn
 
+
 -- | Create the backend given a logging function, server version, mutable statement cell,
 -- and connection.
 createBackend :: IsSqlBackend backend => LogFunc -> Maybe Double
@@ -269,6 +270,7 @@ createBackend logFunc serverVersion smap conn = do
         , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL"
         , connLogFunc = logFunc
         , connMaxParams = Nothing
+        , connRepsertManySql = serverVersion >>= upsertFunction repsertManySql
         }
 
 prepare' :: PG.Connection -> Text -> IO Statement
@@ -337,7 +339,7 @@ insertManySql' ent valss =
                 , ") VALUES ("
                 , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (entityFields ent)
                 , ") RETURNING "
-                , commaSeparated $ dbIdColumnsEsc escape ent
+                , Util.commaSeparated $ Util.dbIdColumnsEsc escape ent
                 ]
   in ISRSingle sql
 
@@ -869,7 +871,7 @@ findAlters defs _tablename col@(Column name isNull sqltype def _defConstraintNam
                 refAdd Nothing = []
                 refAdd (Just (tname, a)) =
                     case find ((==tname) . entityDB) defs of
-                        Just refdef -> [(tname, AddReference a [name] (dbIdColumnsEsc escape refdef))]
+                        Just refdef -> [(tname, AddReference a [name] (Util.dbIdColumnsEsc escape refdef))]
                         Nothing -> error $ "could not find the entityDef for reftable[" ++ show tname ++ "]"
                 modRef =
                     if fmap snd ref == fmap snd ref'
@@ -914,7 +916,7 @@ getAddReference allDefs table reftable cname ref =
                             id_ = fromMaybe (error $ "Could not find ID of entity " ++ show reftable)
                                         $ do
                                           entDef <- find ((== reftable) . entityDB) allDefs
-                                          return $ dbIdColumnsEsc escape entDef
+                                          return $ Util.dbIdColumnsEsc escape entDef
 
 
 showColumn :: Column -> Text
@@ -1213,38 +1215,50 @@ mockMigration mig = do
                              connRDBMS = undefined,
                              connLimitOffset = undefined,
                              connLogFunc = undefined,
-                             connMaxParams = Nothing}
+                             connMaxParams = Nothing,
+                             connRepsertManySql = Nothing
+                             }
       result = runReaderT $ runWriterT $ runWriterT mig
   resp <- result sqlbackend
   mapM_ T.putStrLn $ map snd $ snd resp
 
 putManySql :: EntityDef -> Int -> Text
-putManySql entityDef' numRecords
-  | numRecords > 0 = q
-  | otherwise = error "putManySql: numRecords MUST be greater than 0!"
+putManySql ent n = putManySql' conflictColumns fields ent n
+  where
+    fields = entityFields ent
+    conflictColumns = concatMap (map (escape . snd) . uniqueFields) (entityUniques ent)
+
+repsertManySql :: EntityDef -> Int -> Text
+repsertManySql ent n = putManySql' conflictColumns fields ent n
+  where
+    fields = keyAndEntityFields ent
+    conflictColumns = escape . fieldDB <$> entityKeyFields ent
+
+putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
+putManySql' conflictColumns fields ent n = q
   where
-    tableName' = escape . entityDB $ entityDef'
     fieldDbToText = escape . fieldDB
-    entityFieldNames = map fieldDbToText (entityFields entityDef')
-    recordPlaceholders= parenWrapped . commaSeparated
-                      $ map (const "?") (entityFields entityDef')
-    mkAssignment n = T.concat [n, "=EXCLUDED.", n]
-    fieldSets = map (mkAssignment . fieldDbToText) (entityFields entityDef')
-    uniqueFields' = concat $ map (\x -> map escape (map snd $ uniqueFields x)) (entityUniques entityDef')
+    mkAssignment f = T.concat [f, "=EXCLUDED.", f]
+
+    table = escape . entityDB $ ent
+    columns = Util.commaSeparated $ map fieldDbToText fields
+    placeholders = map (const "?") fields
+    updates = map (mkAssignment . fieldDbToText) fields
+
     q = T.concat
         [ "INSERT INTO "
-        , tableName'
-        , " ("
-        , commaSeparated entityFieldNames
-        , ") "
+        , table
+        , Util.parenWrapped columns
         , " VALUES "
-        , commaSeparated (replicate numRecords recordPlaceholders)
-        , "  ON CONFLICT ("
-        , commaSeparated uniqueFields'
-        , ") DO UPDATE SET "
-        , commaSeparated fieldSets
+        , Util.commaSeparated . replicate n
+            . Util.parenWrapped . Util.commaSeparated $ placeholders
+        , " ON CONFLICT "
+        , Util.parenWrapped . Util.commaSeparated $ conflictColumns
+        , " DO UPDATE SET "
+        , Util.commaSeparated updates
         ]
 
+
 -- | Enable a Postgres extension. See https://www.postgresql.org/docs/current/static/contrib.html
 -- for a list.
 migrateEnableExtension :: Text -> Migration

persistent-postgresql/persistent-postgresql.cabal

@@ -1,5 +1,5 @@
 name:            persistent-postgresql
-version:         2.9.1.0
+version:         2.9.2
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa, Michael Snoyman <michael@snoyman.com>

persistent-sqlite/ChangeLog.md

@@ -1,5 +1,10 @@
 # Changelog for persistent-sqlite
 
+## 2.9.2
+
+* Update the vendored SQLite C library from 3.22.0 to 3.25.2. See [the SQLite changelog](https://sqlite.org/changes.html) for details.
+* Fix [832](https://github.com/yesodweb/persistent/issues/832): `repsertMany` now matches `mapM_ (uncurry repsert)` and is atomic.
+
 ## 2.9.1
 
 * Added support for SQL isolation levels to via SqlBackend. [#812] SQLite technically only supports Serializable.

persistent-sqlite/Database/Persist/Sqlite.hs

@@ -34,6 +34,7 @@ module Database.Persist.Sqlite
 
 import Database.Persist.Sql
 import Database.Persist.Sql.Types.Internal (mkPersistBackend)
+import qualified Database.Persist.Sql.Util as Util
 
 import qualified Database.Sqlite as Sqlite
 
@@ -160,7 +161,7 @@ wrapConnectionInfo connInfo conn logFunc = do
         , connStmtMap = smap
         , connInsertSql = insertSql'
         , connUpsertSql = Nothing
-        , connPutManySql = Nothing
+        , connPutManySql = Just putManySql
         , connInsertManySql = Nothing
         , connClose = Sqlite.close conn
         , connMigrateSql = migrate'
@@ -173,6 +174,7 @@ wrapConnectionInfo connInfo conn logFunc = do
         , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1"
         , connLogFunc = logFunc
         , connMaxParams = Just 999
+        , connRepsertManySql = Just repsertManySql
         }
   where
     helper t getter = do
@@ -355,6 +357,7 @@ mockMigration mig = do
                    , connUpsertSql = undefined
                    , connPutManySql = undefined
                    , connMaxParams = Just 999
+                   , connRepsertManySql = Nothing
                    }
       result = runReaderT . runWriterT . runWriterT $ mig
   resp <- result sqlbackend
@@ -496,6 +499,42 @@ escape (DBName s) =
     go '"' = "\"\""
     go c = T.singleton c
 
+putManySql :: EntityDef -> Int -> Text
+putManySql ent n = putManySql' conflictColumns fields ent n
+  where
+    fields = entityFields ent
+    conflictColumns = concatMap (map (escape . snd) . uniqueFields) (entityUniques ent)
+
+repsertManySql :: EntityDef -> Int -> Text
+repsertManySql ent n = putManySql' conflictColumns fields ent n
+  where
+    fields = keyAndEntityFields ent
+    conflictColumns = escape . fieldDB <$> entityKeyFields ent
+
+putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
+putManySql' conflictColumns fields ent n = q
+  where
+    fieldDbToText = escape . fieldDB
+    mkAssignment f = T.concat [f, "=EXCLUDED.", f]
+
+    table = escape . entityDB $ ent
+    columns = Util.commaSeparated $ map fieldDbToText fields
+    placeholders = map (const "?") fields
+    updates = map (mkAssignment . fieldDbToText) fields
+
+    q = T.concat
+        [ "INSERT INTO "
+        , table
+        , Util.parenWrapped columns
+        , " VALUES "
+        , Util.commaSeparated . replicate n
+            . Util.parenWrapped . Util.commaSeparated $ placeholders
+        , " ON CONFLICT "
+        , Util.parenWrapped . Util.commaSeparated $ conflictColumns
+        , " DO UPDATE SET "
+        , Util.commaSeparated updates
+        ]
+
 -- | Information required to setup a connection pool.
 data SqliteConf = SqliteConf
     { sqlDatabase :: Text