From 3c1ee71a13b2c0475c7c1c587f4a045634f3de77 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 1 Sep 2017 13:31:25 -0600 Subject: [PATCH 01/17] Add support for conditional copying --- persistent-mysql/Database/Persist/MySQL.hs | 48 ++++++++++++++++++---- 1 file changed, 40 insertions(+), 8 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 3f16b9078..6ff67a8c7 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -18,6 +18,8 @@ module Database.Persist.MySQL , insertOnDuplicateKeyUpdate , insertManyOnDuplicateKeyUpdate , SomeField(..) + , copyUnlessNull + , copyUnlessEmpty ) where import Control.Arrow @@ -27,11 +29,11 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.Writer (runWriterT) +import Data.Either (partitionEithers) import Data.Monoid ((<>)) import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString) -import Data.Either (partitionEithers) import Data.Fixed (Pico) import Data.Function (on) import Data.IORef @@ -1034,10 +1036,25 @@ insertOnDuplicateKeyUpdate insertOnDuplicateKeyUpdate record = insertManyOnDuplicateKeyUpdate [record] [] --- | This wraps values of an Entity's 'EntityField', making them have the same --- type. This allows them to be put in lists. +-- | This type is used to determine how to update rows using MySQL's +-- @INSERT ON DUPLICATE KEY UPDATE@ functionality, exposed via +-- 'insertManyOnDuplicateKeyUpdate' in the library. data SomeField record where SomeField :: EntityField record typ -> SomeField record + -- ^ Copy the field directly from the record. + CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> SomeField record + -- ^ Only copy the field if it is not equal to the provided value. + +-- | Copy the field into the database only if the value in the +-- corresponding record is non-@NULL@. +copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> SomeField record +copyUnlessNull field = CopyUnlessEq field Nothing + +-- | Copy the field into the database only if the value in the +-- corresponding record is non-empty, where "empty" means the Monoid +-- definition for 'mempty'. Useful for 'Text', 'String', 'ByteString', etc. +copyUnlessEmpty :: (Monoid typ, PersistField typ) => EntityField record typ -> SomeField record +copyUnlessEmpty field = CopyUnlessEq field mempty -- | Do a bulk insert on the given records in the first parameter. In the event -- that a key conflicts with a record currently in the database, the second and @@ -1074,15 +1091,30 @@ mkBulkInsertQuery -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted. -> (Text, [PersistValue]) mkBulkInsertQuery records fieldValues updates = - (q, recordValues <> updsValues) + (q, recordValues <> updsValues <> copyUnlessValues) where - fieldDefs = map (\x -> case x of SomeField rec -> persistFieldDef rec) fieldValues - updateFieldNames = map (T.pack . escapeDBName . fieldDB) fieldDefs + mfieldDef x = case x of + SomeField rec -> Right (fieldDbToText (persistFieldDef rec)) + CopyUnlessEq rec val -> Left (fieldDbToText (persistFieldDef rec), toPersistValue val) + (fieldsToMaybeCopy, updateFieldNames) = partitionEithers $ map mfieldDef fieldValues + fieldDbToText = T.pack . escapeDBName . fieldDB entityDef' = entityDef records - entityFieldNames = map (T.pack . escapeDBName . fieldDB) (entityFields entityDef') + entityFieldNames = map fieldDbToText (entityFields entityDef') 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 + mkCondFieldSet n _ = T.concat + [ n + , "=COALESCE(" + , "NULLIF(" + , "VALUES(", n, ")" + , "?" + , ")," + , n + , ")" + ] + condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy fieldSets = map (\n -> T.concat [n, "=VALUES(", n, ")"]) updateFieldNames upds = map mkUpdateText updates updsValues = map (\(Update _ val _) -> toPersistValue val) updates @@ -1095,7 +1127,7 @@ mkBulkInsertQuery records fieldValues updates = , " VALUES " , recordPlaceholders , " ON DUPLICATE KEY UPDATE " - , commaSeparated (fieldSets <> upds) + , commaSeparated (fieldSets <> upds <> condFieldSets) ] -- | Vendored from @persistent@. From 8d451cd095124627f41257811f37c255db7d7df4 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 1 Sep 2017 14:53:42 -0600 Subject: [PATCH 02/17] fix typo --- persistent-mysql/Database/Persist/MySQL.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 6ff67a8c7..4bbb0ffa9 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -34,6 +34,7 @@ import Data.Monoid ((<>)) import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString) +import Data.Either (partitionEithers) import Data.Fixed (Pico) import Data.Function (on) import Data.IORef @@ -1108,7 +1109,7 @@ mkBulkInsertQuery records fieldValues updates = [ n , "=COALESCE(" , "NULLIF(" - , "VALUES(", n, ")" + , "VALUES(", n, ")," , "?" , ")," , n From be7e1f0feb237b9c3ca1fde8759cf5b65bdde968 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 1 Sep 2017 14:59:15 -0600 Subject: [PATCH 03/17] add import for older ghc --- persistent-mysql/Database/Persist/MySQL.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 4bbb0ffa9..369785f0d 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -34,11 +34,11 @@ import Data.Monoid ((<>)) import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString) -import Data.Either (partitionEithers) import Data.Fixed (Pico) import Data.Function (on) import Data.IORef import Data.List (find, intercalate, sort, groupBy) +import Data.Monoid (Monoid(..)) import Data.Pool (Pool) import Data.Text (Text, pack) import qualified Data.Text.IO as T From 38c16bdb7a2617187760da36572f7983c47f2ee8 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 1 Sep 2017 15:52:06 -0600 Subject: [PATCH 04/17] import fix --- persistent-mysql/Database/Persist/MySQL.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 369785f0d..8d2d4d9a3 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -30,7 +30,7 @@ import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.Writer (runWriterT) import Data.Either (partitionEithers) -import Data.Monoid ((<>)) +import Data.Monoid ((<>), Monoid(..)) import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString) @@ -38,7 +38,6 @@ import Data.Fixed (Pico) import Data.Function (on) import Data.IORef import Data.List (find, intercalate, sort, groupBy) -import Data.Monoid (Monoid(..)) import Data.Pool (Pool) import Data.Text (Text, pack) import qualified Data.Text.IO as T From cdc513f7fda39561d39a4bf539fe4384613cb638 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Sat, 2 Sep 2017 17:28:54 -0600 Subject: [PATCH 05/17] Add changelog, comment, and version bump --- persistent-mysql/ChangeLog.md | 4 + persistent-mysql/Database/Persist/MySQL.hs | 93 +++++++++++++++++++++- persistent-mysql/persistent-mysql.cabal | 2 +- 3 files changed, 95 insertions(+), 4 deletions(-) diff --git a/persistent-mysql/ChangeLog.md b/persistent-mysql/ChangeLog.md index 56b3f2020..45823abc2 100644 --- a/persistent-mysql/ChangeLog.md +++ b/persistent-mysql/ChangeLog.md @@ -1,3 +1,7 @@ +## 2.6.2 + +* Extend the `SomeField` constructor to allow `insertManyOnDuplicateKeyUpdate` to conditionally copy values. + ## 2.6.1 * Add functions `insertOnDuplicateKeyUpdate`, `insertManyOnDuplicateKeyUpdate` to `Database.Persist.MySQL` module. diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 8d2d4d9a3..b98af1481 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -67,6 +67,8 @@ import qualified Database.MySQL.Base.Types as MySQLBase import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Resource (runResourceT) +import Prelude + -- | Create a MySQL connection pool and run the given action. -- The pool is properly released after the action finishes using -- it. Note that you should not use the given 'ConnectionPool' @@ -1044,15 +1046,23 @@ data SomeField record where -- ^ Copy the field directly from the record. CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> SomeField record -- ^ Only copy the field if it is not equal to the provided value. + -- /Since 2.6.2/ -- | Copy the field into the database only if the value in the -- corresponding record is non-@NULL@. +-- +-- /since 2.6.2/ copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> SomeField record copyUnlessNull field = CopyUnlessEq field Nothing -- | Copy the field into the database only if the value in the -- corresponding record is non-empty, where "empty" means the Monoid -- definition for 'mempty'. Useful for 'Text', 'String', 'ByteString', etc. +-- +-- The resulting 'SomeField' type is useful for the +-- 'insertManyOnDuplicateKeyUpdate' function. +-- +-- /since 2.6.2/ copyUnlessEmpty :: (Monoid typ, PersistField typ) => EntityField record typ -> SomeField record copyUnlessEmpty field = CopyUnlessEq field mempty @@ -1061,19 +1071,96 @@ copyUnlessEmpty field = CopyUnlessEq field mempty -- third parameters determine what will happen. -- -- The second parameter is a list of fields to copy from the original value. --- This allows you to specify that, when a collision occurs, you'll just update --- the value in the database with the field values that you inserted. +-- This allows you to specify which fields to copy from the record you're trying +-- to insert into the database to the preexisting row. -- -- The third parameter is a list of updates to perform that are independent of -- the value that is provided. You can use this to increment a counter value. -- These updates only occur if the original record is present in the database. +-- +-- === __More details on 'SomeField' usage__ +-- +-- The @['SomeField']@ parameter allows you to specify which fields (and +-- under which conditions) will be copied from the inserted rows. For +-- a brief example, consider the following data model and existing data set: +-- +-- @ +-- Item +-- name Text +-- description Text +-- price Double Maybe +-- quantity Int Maybe +-- +-- Primary name +-- @ +-- +-- > items: +-- > +------+-------------+-------+----------+ +-- > | name | description | price | quantity | +-- > +------+-------------+-------+----------+ +-- > | foo | very good | | 3 | +-- > | bar | | 3.99 | | +-- > +------+-------------+-------+----------+ +-- +-- This record type has a single natural key on @itemName@. Let's suppose +-- that we download a CSV of new items to store into the database. Here's +-- our CSV: +-- +-- > name,description,price,quantity +-- > foo,,2.50,6 +-- > bar,even better,,5 +-- > yes,wow,, +-- +-- We parse that into a list of Haskell records: +-- +-- @ +-- records = +-- [ Item { itemName = "foo", itemDescription = "" +-- , itemPrice = Just 2.50, itemQuantity = Just 6 +-- } +-- , Item "bar" "even better" Nothing (Just 5) +-- , Item "yes" "wow" Nothing Nothing +-- ] +-- @ +-- +-- The new CSV data is partial. It only includes __updates__ from the +-- upstream vendor. Our CSV library parses the missing description field as +-- an empty string. We don't want to override the existing description. So +-- we can use the 'copyUnlessEmpty' function to say: "Don't update when the +-- value is empty." +-- +-- Likewise, the new row for @bar@ includes a quantity, but no price. We do +-- not want to overwrite the existing price in the database with a @NULL@ +-- value. So we can use 'copyUnlessNull' to only copy the existing values +-- in. +-- +-- The final code looks like this: +-- @ +-- 'insertManyOnDuplicateKeyUpdate' records +-- [ 'copyUnlessEmpty' ItemDescription +-- , 'copyUnlessNull' ItemPrice +-- , 'copyUnlessNull' ItemQuantity +-- ] +-- [] +-- @ +-- +-- Once we run that code on the datahase, the new data set looks like this: +-- +-- > items: +-- > +------+-------------+-------+----------+ +-- > | name | description | price | quantity | +-- > +------+-------------+-------+----------+ +-- > | foo | very good | 2.50 | 6 | +-- > | bar | even better | 3.99 | 5 | +-- > | yes | wow | | | +-- > +------+-------------+-------+----------+ insertManyOnDuplicateKeyUpdate :: ( PersistEntityBackend record ~ SqlBackend , PersistEntity record , MonadIO m ) => [record] -- ^ A list of the records you want to insert, or update - -> [SomeField record] -- ^ A list of the fields you want to copy over. + -> [SomeField record] -- ^ A list of updates to perform based on the record being inserted. -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted. -> SqlPersistT m () insertManyOnDuplicateKeyUpdate [] _ _ = return () diff --git a/persistent-mysql/persistent-mysql.cabal b/persistent-mysql/persistent-mysql.cabal index 1b00f1170..dc3ee054b 100644 --- a/persistent-mysql/persistent-mysql.cabal +++ b/persistent-mysql/persistent-mysql.cabal @@ -1,5 +1,5 @@ name: persistent-mysql -version: 2.6.1 +version: 2.6.2 license: MIT license-file: LICENSE author: Felipe Lessa , Michael Snoyman From 2af38f843ad6ab25ba5f6c16cc77b6386d217aa2 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Sat, 2 Sep 2017 18:33:18 -0600 Subject: [PATCH 06/17] trick the warnings --- persistent-mysql/Database/Persist/MySQL.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index b98af1481..c559f0e1f 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -30,7 +30,8 @@ import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.Writer (runWriterT) import Data.Either (partitionEithers) -import Data.Monoid ((<>), Monoid(..)) +import Data.Monoid ((<>)) +import qualified Data.Monoid as Monoid import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString) @@ -1063,8 +1064,8 @@ copyUnlessNull field = CopyUnlessEq field Nothing -- 'insertManyOnDuplicateKeyUpdate' function. -- -- /since 2.6.2/ -copyUnlessEmpty :: (Monoid typ, PersistField typ) => EntityField record typ -> SomeField record -copyUnlessEmpty field = CopyUnlessEq field mempty +copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> SomeField record +copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty -- | Do a bulk insert on the given records in the first parameter. In the event -- that a key conflicts with a record currently in the database, the second and From 22d9c8987569f3a297e5e7f8a4cf424de06b8ad8 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Sat, 2 Sep 2017 18:34:36 -0600 Subject: [PATCH 07/17] typo --- persistent-mysql/ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-mysql/ChangeLog.md b/persistent-mysql/ChangeLog.md index 45823abc2..2a2dd3c8c 100644 --- a/persistent-mysql/ChangeLog.md +++ b/persistent-mysql/ChangeLog.md @@ -1,6 +1,6 @@ ## 2.6.2 -* Extend the `SomeField` constructor to allow `insertManyOnDuplicateKeyUpdate` to conditionally copy values. +* Extend the `SomeField` type to allow `insertManyOnDuplicateKeyUpdate` to conditionally copy values. ## 2.6.1 From 8d50adb388cdcc91f1803864f3d659c025940748 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Tue, 5 Sep 2017 11:49:02 -0600 Subject: [PATCH 08/17] use appropriate since --- persistent-mysql/Database/Persist/MySQL.hs | 6 +++--- persistent-test/persistent-test.cabal | 1 + persistent-test/test/main.hs | 3 +++ 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index c559f0e1f..cc32a7229 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -1047,12 +1047,12 @@ data SomeField record where -- ^ Copy the field directly from the record. CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> SomeField record -- ^ Only copy the field if it is not equal to the provided value. - -- /Since 2.6.2/ + -- @since 2.6.2 -- | Copy the field into the database only if the value in the -- corresponding record is non-@NULL@. -- --- /since 2.6.2/ +-- @since 2.6.2 copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> SomeField record copyUnlessNull field = CopyUnlessEq field Nothing @@ -1063,7 +1063,7 @@ copyUnlessNull field = CopyUnlessEq field Nothing -- The resulting 'SomeField' type is useful for the -- 'insertManyOnDuplicateKeyUpdate' function. -- --- /since 2.6.2/ +-- @since 2.6.2 copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> SomeField record copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index c4a19b736..40b4993fe 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -76,6 +76,7 @@ library CustomPersistField CustomPersistFieldTest CustomPrimaryKeyReferenceTest + InsertDuplicateUpdate hs-source-dirs: src, test diff --git a/persistent-test/test/main.hs b/persistent-test/test/main.hs index f47e284fb..bc44498bc 100644 --- a/persistent-test/test/main.hs +++ b/persistent-test/test/main.hs @@ -19,6 +19,7 @@ import qualified PrimaryTest import qualified Recursive import qualified RenameTest import qualified SumTypeTest +import qualified InsertDuplicateUpdate import qualified UniqueTest #ifndef WITH_NOSQL @@ -53,6 +54,7 @@ main = do [ PersistentTest.testMigrate , PersistentTest.noPrefixMigrate , EmbedTest.embedMigrate + , InsertDuplicateUpdate.duplicateMigrate , EmbedOrderTest.embedOrderMigrate , LargeNumberTest.numberMigrate , UniqueTest.uniqueMigrate @@ -92,6 +94,7 @@ main = do PrimaryTest.specs CustomPersistFieldTest.specs CustomPrimaryKeyReferenceTest.specs + InsertDuplicateUpdate.specs #ifdef WITH_SQLITE MigrationTest.specs From 04b1f5133f0bda8f9309d77a7f6ddc443ef05f06 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Tue, 5 Sep 2017 11:49:07 -0600 Subject: [PATCH 09/17] Add test --- persistent-test/src/InsertDuplicateUpdate.hs | 81 ++++++++++++++++++++ 1 file changed, 81 insertions(+) create mode 100644 persistent-test/src/InsertDuplicateUpdate.hs diff --git a/persistent-test/src/InsertDuplicateUpdate.hs b/persistent-test/src/InsertDuplicateUpdate.hs new file mode 100644 index 000000000..60dac1e25 --- /dev/null +++ b/persistent-test/src/InsertDuplicateUpdate.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} + +module InsertDuplicateUpdate where + +import Init +import Data.List (sort) + +share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| + Item + name Text + description Text + price Double Maybe + quantity Int Maybe + + Primary name + deriving Eq Show Ord + +|] + +#ifdef WITH_MYSQL +specs :: Spec +specs = describe "DuplicateKeyUpdate" $ do + let item1 = Item "item1" "" (Just 3) Nothing + item2 = Item "item2" "hello world" Nothing (Just 2) + items = [item1, item2] + describe "insertOnDuplicateKeyUpdate" $ do + it "inserts appropriately" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertOnDuplicateKeyUpdate item1 [ItemDescription =. "i am item 1"] + Just item <- get (ItemKey "item1") + item @== item1 + + it "performs only updates given if record already exists" $ db $ do + deleteWhere ([] :: [Filter Item]) + let newDescription = "I am a new description" + _ <- insert item1 + insertOnDuplicateKeyUpdate + (Item "item1" "i am a description" (Just 1) (Just 2)) + [ItemDescription =. newDescription] + Just item <- get (ItemKey "item1") + item @== Item "item1" newDescription Nothing Nothing + + describe "insertManyOnDuplicateKeyUpdate" $ do + it "inserts fresh records" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItem = Item "item3" "fresh" Nothing Nothing + insertManyOnDuplicateKeyUpdate + (newItem : items) + [SomeField ItemDescription] + [] + dbItems <- map entityVal <$> selectList [] [] + sort dbItems @== sort (newItem : items) + it "updates existing records" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + insertManyOnDuplicateKeyUpdate + items + [] + [ItemQuantity +=. 1] + it "only copies passing values" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items + postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items + insertManyOnDuplicateKeyUpdate + newItems + [ CopyUnlessEq ItemQuantity (Just 0) + , SomeField ItemPrice + ] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort postUpdate +#else +spec :: Spec +spec = describe "DuplicateKeyUpdate" $ do + it "Is only supported on MySQL currently." $ do + True `shouldBe` True +#endif From a0ff3e9224746e7ba23a24a796ab103a016dc0f9 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Tue, 5 Sep 2017 16:13:04 -0600 Subject: [PATCH 10/17] Remove the constructor from the public interface. --- persistent-mysql/Database/Persist/MySQL.hs | 14 +++++++++- persistent-test/src/InsertDuplicateUpdate.hs | 28 +++++++++++++------- 2 files changed, 32 insertions(+), 10 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index cc32a7229..851dc8161 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -17,9 +17,10 @@ module Database.Persist.MySQL , mockMigration , insertOnDuplicateKeyUpdate , insertManyOnDuplicateKeyUpdate - , SomeField(..) + , SomeField(SomeField) , copyUnlessNull , copyUnlessEmpty + , copyUnlessEq ) where import Control.Arrow @@ -1067,6 +1068,17 @@ copyUnlessNull field = CopyUnlessEq field Nothing copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> SomeField record copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty +-- | Copy the field into the database only if the field is not equal to the +-- provided value. This is useful to avoid copying weird nullary data into +-- the database. +-- +-- The resulting 'SomeField' type is useful for the +-- 'insertManyOnDuplicateKeyUpdate' function. +-- +-- @since 2.6.2 +copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> SomeField record +copyUnlessEq = CopyUnlessEq + -- | Do a bulk insert on the given records in the first parameter. In the event -- that a key conflicts with a record currently in the database, the second and -- third parameters determine what will happen. diff --git a/persistent-test/src/InsertDuplicateUpdate.hs b/persistent-test/src/InsertDuplicateUpdate.hs index 60dac1e25..377942a8e 100644 --- a/persistent-test/src/InsertDuplicateUpdate.hs +++ b/persistent-test/src/InsertDuplicateUpdate.hs @@ -1,11 +1,21 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module InsertDuplicateUpdate where -import Init -import Data.List (sort) +import Data.List (sort) +import Init share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| Item @@ -16,7 +26,7 @@ share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| Primary name deriving Eq Show Ord - + |] #ifdef WITH_MYSQL @@ -36,7 +46,7 @@ specs = describe "DuplicateKeyUpdate" $ do deleteWhere ([] :: [Filter Item]) let newDescription = "I am a new description" _ <- insert item1 - insertOnDuplicateKeyUpdate + insertOnDuplicateKeyUpdate (Item "item1" "i am a description" (Just 1) (Just 2)) [ItemDescription =. newDescription] Just item <- get (ItemKey "item1") @@ -47,7 +57,7 @@ specs = describe "DuplicateKeyUpdate" $ do deleteWhere ([] :: [Filter Item]) insertMany_ items let newItem = Item "item3" "fresh" Nothing Nothing - insertManyOnDuplicateKeyUpdate + insertManyOnDuplicateKeyUpdate (newItem : items) [SomeField ItemDescription] [] @@ -56,7 +66,7 @@ specs = describe "DuplicateKeyUpdate" $ do it "updates existing records" $ db $ do deleteWhere ([] :: [Filter Item]) insertMany_ items - insertManyOnDuplicateKeyUpdate + insertManyOnDuplicateKeyUpdate items [] [ItemQuantity +=. 1] @@ -67,7 +77,7 @@ specs = describe "DuplicateKeyUpdate" $ do postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items insertManyOnDuplicateKeyUpdate newItems - [ CopyUnlessEq ItemQuantity (Just 0) + [ copyUnlessEq ItemQuantity (Just 0) , SomeField ItemPrice ] [] From d25a5e602f11e9aea9bae470911179cb026d85f2 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 15 Sep 2017 16:38:43 -0600 Subject: [PATCH 11/17] fix build --- persistent-test/src/InsertDuplicateUpdate.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/persistent-test/src/InsertDuplicateUpdate.hs b/persistent-test/src/InsertDuplicateUpdate.hs index 377942a8e..37cadba4c 100644 --- a/persistent-test/src/InsertDuplicateUpdate.hs +++ b/persistent-test/src/InsertDuplicateUpdate.hs @@ -14,7 +14,6 @@ module InsertDuplicateUpdate where -import Data.List (sort) import Init share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| @@ -84,8 +83,8 @@ specs = describe "DuplicateKeyUpdate" $ do dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort postUpdate #else -spec :: Spec -spec = describe "DuplicateKeyUpdate" $ do +specs :: Spec +specs = describe "DuplicateKeyUpdate" $ do it "Is only supported on MySQL currently." $ do True `shouldBe` True #endif From 1c1851e0e81050317bef2b301566babf5d1583fd Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 15 Sep 2017 17:32:04 -0600 Subject: [PATCH 12/17] fix tests --- persistent-test/src/InsertDuplicateUpdate.hs | 12 +++++++----- persistent-test/test/main.hs | 2 ++ 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/persistent-test/src/InsertDuplicateUpdate.hs b/persistent-test/src/InsertDuplicateUpdate.hs index 37cadba4c..f78aee133 100644 --- a/persistent-test/src/InsertDuplicateUpdate.hs +++ b/persistent-test/src/InsertDuplicateUpdate.hs @@ -15,10 +15,13 @@ module InsertDuplicateUpdate where import Init +#ifdef WITH_MYSQL +import Database.Persist.MySQL +import Data.List (sort) share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| Item - name Text + name Text sqltype=varchar(80) description Text price Double Maybe quantity Int Maybe @@ -28,7 +31,6 @@ share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| |] -#ifdef WITH_MYSQL specs :: Spec specs = describe "DuplicateKeyUpdate" $ do let item1 = Item "item1" "" (Just 3) Nothing @@ -46,10 +48,10 @@ specs = describe "DuplicateKeyUpdate" $ do let newDescription = "I am a new description" _ <- insert item1 insertOnDuplicateKeyUpdate - (Item "item1" "i am a description" (Just 1) (Just 2)) + (Item "item1" "i am inserted description" (Just 1) (Just 2)) [ItemDescription =. newDescription] Just item <- get (ItemKey "item1") - item @== Item "item1" newDescription Nothing Nothing + item @== item1 { itemDescription = newDescription } describe "insertManyOnDuplicateKeyUpdate" $ do it "inserts fresh records" $ db $ do @@ -68,7 +70,7 @@ specs = describe "DuplicateKeyUpdate" $ do insertManyOnDuplicateKeyUpdate items [] - [ItemQuantity +=. 1] + [ItemQuantity +=. Just 1] it "only copies passing values" $ db $ do deleteWhere ([] :: [Filter Item]) insertMany_ items diff --git a/persistent-test/test/main.hs b/persistent-test/test/main.hs index bc44498bc..889276fb0 100644 --- a/persistent-test/test/main.hs +++ b/persistent-test/test/main.hs @@ -69,6 +69,8 @@ main = do , CustomPersistFieldTest.customFieldMigrate # ifndef WITH_MYSQL , PrimaryTest.migration +# else + , InsertDuplicateUpdate.duplicateMigrate # endif , CustomPrimaryKeyReferenceTest.migration ] From 3c42fc0c92eae56ec9df729898021ab1ba24e36f Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 15 Sep 2017 18:07:18 -0600 Subject: [PATCH 13/17] derp --- persistent-test/test/main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/persistent-test/test/main.hs b/persistent-test/test/main.hs index 889276fb0..8b04ce5d1 100644 --- a/persistent-test/test/main.hs +++ b/persistent-test/test/main.hs @@ -69,7 +69,8 @@ main = do , CustomPersistFieldTest.customFieldMigrate # ifndef WITH_MYSQL , PrimaryTest.migration -# else +# endif +# ifdef WITH_MYSQL , InsertDuplicateUpdate.duplicateMigrate # endif , CustomPrimaryKeyReferenceTest.migration From 5ff24edfcce358b235bf38d40336f6e219effebd Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 15 Sep 2017 23:26:39 -0600 Subject: [PATCH 14/17] remove duplicate --- persistent-test/test/main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/persistent-test/test/main.hs b/persistent-test/test/main.hs index 8b04ce5d1..702da322c 100644 --- a/persistent-test/test/main.hs +++ b/persistent-test/test/main.hs @@ -54,7 +54,6 @@ main = do [ PersistentTest.testMigrate , PersistentTest.noPrefixMigrate , EmbedTest.embedMigrate - , InsertDuplicateUpdate.duplicateMigrate , EmbedOrderTest.embedOrderMigrate , LargeNumberTest.numberMigrate , UniqueTest.uniqueMigrate From 4ac6db80777f961631ef86f154b1d3d15dde14f3 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 15 Sep 2017 23:38:36 -0600 Subject: [PATCH 15/17] make datatype test more consistent --- persistent-test/src/DataTypeTest.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/persistent-test/src/DataTypeTest.hs b/persistent-test/src/DataTypeTest.hs index f26e192dd..df0761ff5 100644 --- a/persistent-test/src/DataTypeTest.hs +++ b/persistent-test/src/DataTypeTest.hs @@ -82,7 +82,7 @@ specs = describe "data type specs" $ check "day" dataTypeTableDay #ifndef WITH_NOSQL check' "pico" dataTypeTablePico - check "time" (roundTime . dataTypeTableTime) + check "time" (truncateTimeOfDay . dataTypeTableTime) #endif #if !(defined(WITH_NOSQL)) || (defined(WITH_NOSQL) && defined(HIGH_PRECISION_DATE)) check "utc" (roundUTCTime . dataTypeTableUtc) @@ -132,7 +132,7 @@ instance Arbitrary DataTypeTable where <*> arbitrary -- day #ifndef WITH_NOSQL <*> arbitrary -- pico - <*> (truncateTimeOfDay =<< arbitrary) -- time + <*> (fmap truncateTimeOfDay arbitrary) -- time #endif <*> (truncateUTCTime =<< arbitrary) -- utc @@ -154,9 +154,9 @@ truncateToMicro p = let p' = fromRational . toRational $ p :: Micro in fromRational . toRational $ p' :: Pico -truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay +truncateTimeOfDay :: TimeOfDay -> TimeOfDay truncateTimeOfDay (TimeOfDay h m s) = - return $ TimeOfDay h m $ truncateToMicro s + TimeOfDay h m $ truncateToMicro s truncateUTCTime :: UTCTime -> Gen UTCTime truncateUTCTime (UTCTime d dift) = do From d5d555130ee84fdafa70a67bb373d6399de8dd86 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Sat, 16 Sep 2017 09:31:00 -0600 Subject: [PATCH 16/17] round time --- persistent-test/src/DataTypeTest.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent-test/src/DataTypeTest.hs b/persistent-test/src/DataTypeTest.hs index df0761ff5..9301f0f02 100644 --- a/persistent-test/src/DataTypeTest.hs +++ b/persistent-test/src/DataTypeTest.hs @@ -82,7 +82,7 @@ specs = describe "data type specs" $ check "day" dataTypeTableDay #ifndef WITH_NOSQL check' "pico" dataTypeTablePico - check "time" (truncateTimeOfDay . dataTypeTableTime) + check "time" (roundTime . dataTypeTableTime) #endif #if !(defined(WITH_NOSQL)) || (defined(WITH_NOSQL) && defined(HIGH_PRECISION_DATE)) check "utc" (roundUTCTime . dataTypeTableUtc) @@ -100,7 +100,7 @@ specs = describe "data type specs" $ roundTime :: TimeOfDay -> TimeOfDay #ifdef WITH_MYSQL -roundTime (TimeOfDay h m s) = TimeOfDay h m (fromIntegral (truncate s :: Integer)) +roundTime (TimeOfDay h m s) = TimeOfDay h m (fromIntegral (round s :: Integer)) #else roundTime = id #endif From 0f14f796c3b071a5387adc578140a17a11972d71 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Sat, 16 Sep 2017 10:49:58 -0600 Subject: [PATCH 17/17] revert datatype test changes --- persistent-test/src/DataTypeTest.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/persistent-test/src/DataTypeTest.hs b/persistent-test/src/DataTypeTest.hs index 9301f0f02..f26e192dd 100644 --- a/persistent-test/src/DataTypeTest.hs +++ b/persistent-test/src/DataTypeTest.hs @@ -100,7 +100,7 @@ specs = describe "data type specs" $ roundTime :: TimeOfDay -> TimeOfDay #ifdef WITH_MYSQL -roundTime (TimeOfDay h m s) = TimeOfDay h m (fromIntegral (round s :: Integer)) +roundTime (TimeOfDay h m s) = TimeOfDay h m (fromIntegral (truncate s :: Integer)) #else roundTime = id #endif @@ -132,7 +132,7 @@ instance Arbitrary DataTypeTable where <*> arbitrary -- day #ifndef WITH_NOSQL <*> arbitrary -- pico - <*> (fmap truncateTimeOfDay arbitrary) -- time + <*> (truncateTimeOfDay =<< arbitrary) -- time #endif <*> (truncateUTCTime =<< arbitrary) -- utc @@ -154,9 +154,9 @@ truncateToMicro p = let p' = fromRational . toRational $ p :: Micro in fromRational . toRational $ p' :: Pico -truncateTimeOfDay :: TimeOfDay -> TimeOfDay +truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay truncateTimeOfDay (TimeOfDay h m s) = - TimeOfDay h m $ truncateToMicro s + return $ TimeOfDay h m $ truncateToMicro s truncateUTCTime :: UTCTime -> Gen UTCTime truncateUTCTime (UTCTime d dift) = do