diff --git a/persistent-mysql/ChangeLog.md b/persistent-mysql/ChangeLog.md index 56b3f2020..2a2dd3c8c 100644 --- a/persistent-mysql/ChangeLog.md +++ b/persistent-mysql/ChangeLog.md @@ -1,3 +1,7 @@ +## 2.6.2 + +* Extend the `SomeField` type 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 a2db5e7b7..c06bff5c9 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -17,7 +17,10 @@ module Database.Persist.MySQL , mockMigration , insertOnDuplicateKeyUpdate , insertManyOnDuplicateKeyUpdate - , SomeField(..) + , SomeField(SomeField) + , copyUnlessNull + , copyUnlessEmpty + , copyUnlessEq ) where import Control.Arrow @@ -27,11 +30,12 @@ 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 qualified Data.Monoid as 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 @@ -65,6 +69,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' @@ -1038,29 +1044,140 @@ 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. + -- @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.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. -- -- 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 () @@ -1078,15 +1195,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 @@ -1099,7 +1231,7 @@ mkBulkInsertQuery records fieldValues updates = , " VALUES " , recordPlaceholders , " ON DUPLICATE KEY UPDATE " - , commaSeparated (fieldSets <> upds) + , commaSeparated (fieldSets <> upds <> condFieldSets) ] -- | Vendored from @persistent@. 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 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/src/InsertDuplicateUpdate.hs b/persistent-test/src/InsertDuplicateUpdate.hs new file mode 100644 index 000000000..f78aee133 --- /dev/null +++ b/persistent-test/src/InsertDuplicateUpdate.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-} +{-# 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 +#ifdef WITH_MYSQL +import Database.Persist.MySQL +import Data.List (sort) + +share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| + Item + name Text sqltype=varchar(80) + description Text + price Double Maybe + quantity Int Maybe + + Primary name + deriving Eq Show Ord + +|] + +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 inserted description" (Just 1) (Just 2)) + [ItemDescription =. newDescription] + Just item <- get (ItemKey "item1") + item @== item1 { itemDescription = newDescription } + + 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 +=. Just 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 +specs :: Spec +specs = describe "DuplicateKeyUpdate" $ do + it "Is only supported on MySQL currently." $ do + True `shouldBe` True +#endif diff --git a/persistent-test/test/main.hs b/persistent-test/test/main.hs index f47e284fb..702da322c 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 @@ -67,6 +68,9 @@ main = do , CustomPersistFieldTest.customFieldMigrate # ifndef WITH_MYSQL , PrimaryTest.migration +# endif +# ifdef WITH_MYSQL + , InsertDuplicateUpdate.duplicateMigrate # endif , CustomPrimaryKeyReferenceTest.migration ] @@ -92,6 +96,7 @@ main = do PrimaryTest.specs CustomPersistFieldTest.specs CustomPrimaryKeyReferenceTest.specs + InsertDuplicateUpdate.specs #ifdef WITH_SQLITE MigrationTest.specs