[persistent-mysql] Add support for conditional copying

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.

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'
@@ -1034,29 +1040,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 ()
@@ -1074,15 +1191,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 +1227,7 @@ mkBulkInsertQuery records fieldValues updates =
         , " VALUES "
         , recordPlaceholders
         , " ON DUPLICATE KEY UPDATE "
-        , commaSeparated (fieldSets <> upds)
+        , commaSeparated (fieldSets <> upds <> condFieldSets)
         ]
 
 -- | Vendored from @persistent@.

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 <felipe.lessa@gmail.com>, Michael Snoyman

persistent-test/persistent-test.cabal

@@ -76,6 +76,7 @@ library
                      CustomPersistField
                      CustomPersistFieldTest
                      CustomPrimaryKeyReferenceTest
+                     InsertDuplicateUpdate
 
     hs-source-dirs: src, test
 

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

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