diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +## 2.6.2 + +* Extend the `SomeField` type to allow `insertManyOnDuplicateKeyUpdate` to conditionally copy values. +* Depend on `mysql-simple >= 0.4.3` to fix encoding and decoding of date/time values with fractional seconds (when a column is specified using something like `sqltype=TIME(6)`). See also [#705](https://github.com/yesodweb/persistent/issues/705) +* Fix behavior of `insertManyOnDuplicateKeyUpdate` to ignore duplicate key exceptions when no updates specified. + ## 2.6.1 * Add functions `insertOnDuplicateKeyUpdate`, `insertManyOnDuplicateKeyUpdate` to `Database.Persist.MySQL` module. diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -17,7 +18,10 @@ , mockMigration , insertOnDuplicateKeyUpdate , insertManyOnDuplicateKeyUpdate - , SomeField(..) + , SomeField(SomeField) + , copyUnlessNull + , copyUnlessEmpty + , copyUnlessEq ) where import Control.Arrow @@ -25,13 +29,14 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Trans.Reader (runReaderT, ReaderT, withReaderT) 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 +70,8 @@ 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' @@ -620,9 +627,13 @@ -- Text parseColumnType "varchar" ci = return (SqlString, ciMaxLength ci) parseColumnType "text" _ = return (SqlString, Nothing) +parseColumnType "mediumtext" _ = return (SqlString, Nothing) +parseColumnType "longtext" _ = return (SqlString, Nothing) -- ByteString parseColumnType "varbinary" ci = return (SqlBlob, ciMaxLength ci) parseColumnType "blob" _ = return (SqlBlob, Nothing) +parseColumnType "mediumblob" _ = return (SqlBlob, Nothing) +parseColumnType "longblob" _ = return (SqlBlob, Nothing) -- Time-related parseColumnType "time" _ = return (SqlTime, Nothing) parseColumnType "datetime" _ = return (SqlDayTime, Nothing) @@ -1022,70 +1033,206 @@ -- | MySQL specific 'upsert'. This will prevent multiple queries, when one will -- do. insertOnDuplicateKeyUpdate - :: ( PersistEntityBackend record ~ BaseBackend backend + :: ( backend ~ PersistEntityBackend record , PersistEntity record , MonadIO m , PersistStore backend - , backend ~ SqlBackend + , BackendCompatible SqlBackend backend ) => record -> [Update record] - -> SqlPersistT m () + -> ReaderT backend m () 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. - -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted. - -> SqlPersistT m () + :: forall record backend m. + ( backend ~ PersistEntityBackend record + , BackendCompatible SqlBackend backend + , 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. + -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted. + -> ReaderT backend m () insertManyOnDuplicateKeyUpdate [] _ _ = return () -insertManyOnDuplicateKeyUpdate records [] [] = insertMany_ records insertManyOnDuplicateKeyUpdate records fieldValues updates = - uncurry rawExecute $ mkBulkInsertQuery records fieldValues updates + withReaderT projectBackend + . uncurry rawExecute + $ mkBulkInsertQuery records fieldValues updates --- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. It will give --- garbage results if you don't provide a list of either fields to copy or --- fields to update. +-- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. If you +-- provide an empty list of updates to perform, then it will generate +-- a dummy/no-op update using the first field of the record. This avoids +-- duplicate key exceptions. mkBulkInsertQuery - :: (PersistEntityBackend record ~ SqlBackend, PersistEntity record) + :: PersistEntity record => [record] -- ^ A list of the records you want to insert, or update -> [SomeField record] -- ^ A list of the fields you want to copy over. -> [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') + firstField = case entityFieldNames of + [] -> error "The entity you're trying to insert does not have any fields." + (field:_) -> field + 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 + updateText = case fieldSets <> upds <> condFieldSets of + [] -> T.concat [firstField, "=", firstField] + xs -> commaSeparated xs q = T.concat [ "INSERT INTO " , tableName @@ -1095,7 +1242,7 @@ , " VALUES " , recordPlaceholders , " ON DUPLICATE KEY UPDATE " - , commaSeparated (fieldSets <> upds) + , updateText ] -- | Vendored from @persistent@. diff --git a/persistent-mysql.cabal b/persistent-mysql.cabal --- a/persistent-mysql.cabal +++ b/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 @@ -29,7 +29,7 @@ library build-depends: base >= 4.6 && < 5 , transformers >= 0.2.1 - , mysql-simple >= 0.2.2.3 && < 0.5 + , mysql-simple >= 0.4.3 && < 0.5 , mysql >= 0.1.1.3 && < 0.2 , blaze-builder , persistent >= 2.6.1 && < 3