-
Notifications
You must be signed in to change notification settings - Fork 293
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
[persistent-mysql] Add support for conditional copying #693
Changes from 16 commits
3c1ee71
8d451cd
be7e1f0
38c16bd
cdc513f
2af38f8
22d9c89
8d50adb
04b1f51
a0ff3e9
d25a5e6
1c1851e
3c42fc0
5ff24ed
4ac6db8
d5d5551
0f14f79
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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 | ||
|
||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Both of the introduced functions are only seem to be applicable for |
||
-- | 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@. | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Can you bump the cabal version, update changelog and add the
@since
haddock syntax for all the functions you have added here.There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Sure thing! Is adding a constructor like this a minor version bump?
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
You need to bump it to
2.6.2
. More info here: http://www.snoyman.com/blog/2017/06/how-to-send-me-a-pull-request