diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,19 @@ +## 2.8.0 (Unreleased) + +* Switch from `MonadBaseControl` to `MonadUnliftIO` +* Fix duplicate migrations when using `mediumtext`, `longtext`, `mediumblob`, `longblob`, and `double`s using a custom precision. [#754](https://github.com/yesodweb/persistent/pull/754) + +-- This can be released as a minor change on the next update. Currently persistent-mysql can't be released because 2.6.2.2 depends on persistent-2.7.2 being released. + +* The `SomeField` type was renamed to `HandleUpdateCollision` and deprecated. Please migrate to using `HandleUpdateCollision`. +* The `SomeField` constructor was deprecated, and a temporary pattern synonym introduced. Please migrate to using `copyField`. + +## 2.6.2.2 [UNRELEASED ON HACKAGE] + +-- This version depends on persistent 2.7.2, which introduced breaking changes and is deprecated on hackage. + +* Fix ambiguous type errors introduced by `persistent-2.7.2` [#723](https://github.com/yesodweb/persistent/pull/723) + ## 2.6.2.1 * Fix haddock documentation [#725](https://github.com/yesodweb/persistent/pull/725) diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -16,9 +18,17 @@ , MySQLBase.defaultSSLInfo , MySQLConf(..) , mockMigration + -- * @ON DUPLICATE KEY UPDATE@ Functionality , insertOnDuplicateKeyUpdate , insertManyOnDuplicateKeyUpdate - , SomeField(SomeField) +#if MIN_VERSION_base(4,7,0) + , HandleUpdateCollision + , pattern SomeField +#elif MIN_VERSION_base(4,9,0) + , HandleUpdateCollision(SomeField) +#endif + , SomeField + , copyField , copyUnlessNull , copyUnlessEmpty , copyUnlessEq @@ -29,7 +39,7 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Reader (runReaderT, ReaderT, withReaderT) +import Control.Monad.Trans.Reader (runReaderT, ReaderT) import Control.Monad.Trans.Writer (runWriterT) import Data.Either (partitionEithers) import Data.Monoid ((<>)) @@ -67,8 +77,7 @@ import qualified Database.MySQL.Base as MySQLBase import qualified Database.MySQL.Base.Types as MySQLBase -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.IO.Unlift (MonadUnliftIO) import Prelude @@ -76,7 +85,7 @@ -- The pool is properly released after the action finishes using -- it. Note that you should not use the given 'ConnectionPool' -- outside the action since it may be already been released. -withMySQLPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend) +withMySQLPool :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend) => MySQL.ConnectInfo -- ^ Connection information. -> Int @@ -90,7 +99,7 @@ -- | Create a MySQL connection pool. Note that it's your -- responsibility to properly close the connection pool when -- unneeded. Use 'withMySQLPool' for automatic resource control. -createMySQLPool :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, IsSqlBackend backend) +createMySQLPool :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend) => MySQL.ConnectInfo -- ^ Connection information. -> Int @@ -101,7 +110,7 @@ -- | Same as 'withMySQLPool', but instead of opening a pool -- of connections, only one connection is opened. -withMySQLConn :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, IsSqlBackend backend) +withMySQLConn :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend) => MySQL.ConnectInfo -- ^ Connection information. -> (backend -> m a) @@ -178,7 +187,7 @@ => MySQL.Connection -> MySQL.Query -> [PersistValue] - -> Acquire (Source m [PersistValue]) + -> Acquire (ConduitM () [PersistValue] m ()) withStmt' conn query vals = do result <- mkAcquire createResult MySQLBase.freeResult return $ fetchRows result >>= CL.sourceList @@ -465,45 +474,51 @@ ) getColumns connectInfo getter def = do -- Find out ID column. - stmtIdClmn <- getter "SELECT COLUMN_NAME, \ - \IS_NULLABLE, \ - \DATA_TYPE, \ - \COLUMN_DEFAULT \ - \FROM INFORMATION_SCHEMA.COLUMNS \ - \WHERE TABLE_SCHEMA = ? \ - \AND TABLE_NAME = ? \ - \AND COLUMN_NAME = ?" - inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) - ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries + stmtIdClmn <- getter $ T.concat + [ "SELECT COLUMN_NAME, " + , "IS_NULLABLE, " + , "DATA_TYPE, " + , "COLUMN_DEFAULT " + , "FROM INFORMATION_SCHEMA.COLUMNS " + , "WHERE TABLE_SCHEMA = ? " + , "AND TABLE_NAME = ? " + , "AND COLUMN_NAME = ?" + ] + inter1 <- with (stmtQuery stmtIdClmn vals) (\src -> runConduit $ src .| CL.consume) + ids <- runConduitRes $ CL.sourceList inter1 .| helperClmns -- avoid nested queries -- Find out all columns. - stmtClmns <- getter "SELECT COLUMN_NAME, \ - \IS_NULLABLE, \ - \DATA_TYPE, \ - \COLUMN_TYPE, \ - \CHARACTER_MAXIMUM_LENGTH, \ - \NUMERIC_PRECISION, \ - \NUMERIC_SCALE, \ - \COLUMN_DEFAULT \ - \FROM INFORMATION_SCHEMA.COLUMNS \ - \WHERE TABLE_SCHEMA = ? \ - \AND TABLE_NAME = ? \ - \AND COLUMN_NAME <> ?" - inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) - cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries + stmtClmns <- getter $ T.concat + [ "SELECT COLUMN_NAME, " + , "IS_NULLABLE, " + , "DATA_TYPE, " + , "COLUMN_TYPE, " + , "CHARACTER_MAXIMUM_LENGTH, " + , "NUMERIC_PRECISION, " + , "NUMERIC_SCALE, " + , "COLUMN_DEFAULT " + , "FROM INFORMATION_SCHEMA.COLUMNS " + , "WHERE TABLE_SCHEMA = ? " + , "AND TABLE_NAME = ? " + , "AND COLUMN_NAME <> ?" + ] + inter2 <- with (stmtQuery stmtClmns vals) (\src -> runConduitRes $ src .| CL.consume) + cs <- runConduitRes $ CL.sourceList inter2 .| helperClmns -- avoid nested queries -- Find out the constraints. - stmtCntrs <- getter "SELECT CONSTRAINT_NAME, \ - \COLUMN_NAME \ - \FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE \ - \WHERE TABLE_SCHEMA = ? \ - \AND TABLE_NAME = ? \ - \AND COLUMN_NAME <> ? \ - \AND CONSTRAINT_NAME <> 'PRIMARY' \ - \AND REFERENCED_TABLE_SCHEMA IS NULL \ - \ORDER BY CONSTRAINT_NAME, \ - \COLUMN_NAME" - us <- with (stmtQuery stmtCntrs vals) ($$ helperCntrs) + stmtCntrs <- getter $ T.concat + [ "SELECT CONSTRAINT_NAME, " + , "COLUMN_NAME " + , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE " + , "WHERE TABLE_SCHEMA = ? " + , "AND TABLE_NAME = ? " + , "AND COLUMN_NAME <> ? " + , "AND CONSTRAINT_NAME <> 'PRIMARY' " + , "AND REFERENCED_TABLE_SCHEMA IS NULL " + , "ORDER BY CONSTRAINT_NAME, " + , "COLUMN_NAME" + ] + us <- with (stmtQuery stmtCntrs vals) (\src -> runConduitRes $ src .| helperCntrs) -- Return both return (ids, cs ++ us) @@ -512,7 +527,7 @@ , PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ fieldDB $ entityId def ] - helperClmns = CL.mapM getIt =$ CL.consume + helperClmns = CL.mapM getIt .| CL.consume where getIt = fmap (either Left (Right . Left)) . liftIO . @@ -556,21 +571,23 @@ _ -> fail $ "Invalid default column: " ++ show default' -- Foreign key (if any) - stmt <- lift $ getter "SELECT REFERENCED_TABLE_NAME, \ - \CONSTRAINT_NAME, \ - \ORDINAL_POSITION \ - \FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE \ - \WHERE TABLE_SCHEMA = ? \ - \AND TABLE_NAME = ? \ - \AND COLUMN_NAME = ? \ - \AND REFERENCED_TABLE_SCHEMA = ? \ - \ORDER BY CONSTRAINT_NAME, \ - \COLUMN_NAME" + stmt <- lift . getter $ T.concat + [ "SELECT REFERENCED_TABLE_NAME, " + , "CONSTRAINT_NAME, " + , "ORDINAL_POSITION " + , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE " + , "WHERE TABLE_SCHEMA = ? " + , "AND TABLE_NAME = ? " + , "AND COLUMN_NAME = ? " + , "AND REFERENCED_TABLE_SCHEMA = ? " + , "ORDER BY CONSTRAINT_NAME, " + , "COLUMN_NAME" + ] let vars = [ PersistText $ pack $ MySQL.connectDatabase connectInfo , PersistText $ unDBName $ tname , PersistText cname , PersistText $ pack $ MySQL.connectDatabase connectInfo ] - cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) + cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistText tab, PersistText ref, PersistInt64 pos]] -> @@ -617,7 +634,7 @@ parseColumnType "int" ci | ciColumnType ci == "int(11)" = return (SqlInt32, Nothing) parseColumnType "bigint" ci | ciColumnType ci == "bigint(20)" = return (SqlInt64, Nothing) -- Double -parseColumnType "double" _ = return (SqlReal, Nothing) +parseColumnType x@("double") ci | ciColumnType ci == x = return (SqlReal, Nothing) parseColumnType "decimal" ci = case (ciNumericPrecision ci, ciNumericScale ci) of (PersistInt64 p, PersistInt64 s) -> @@ -627,13 +644,9 @@ -- 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) @@ -1030,8 +1043,10 @@ resp <- result sqlbackend mapM_ T.putStrLn $ map snd $ snd resp --- | MySQL specific 'upsert'. This will prevent multiple queries, when one will --- do. +-- | MySQL specific 'upsert_'. This will prevent multiple queries, when one will +-- do. The record will be inserted into the database. In the event that the +-- record already exists in the database, the record will have the +-- relevant updates performed. insertOnDuplicateKeyUpdate :: ( backend ~ PersistEntityBackend record , PersistEntity record @@ -1046,45 +1061,64 @@ insertManyOnDuplicateKeyUpdate [record] [] -- | 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. +-- @INSERT ... ON DUPLICATE KEY UPDATE@ functionality, exposed via +-- 'insertManyOnDuplicateKeyUpdate' in this library. -- --- @since 2.6.2 -data SomeField record where +-- @since 3.0.0 +data HandleUpdateCollision record where -- | Copy the field directly from the record. - SomeField :: EntityField record typ -> SomeField record + CopyField :: EntityField record typ -> HandleUpdateCollision record -- | Only copy the field if it is not equal to the provided value. - CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> SomeField record + CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record +-- | An alias for 'HandleUpdateCollision'. The type previously was only +-- used to copy a single value, but was expanded to be handle more complex +-- queries. +-- +-- @since 2.6.2 +type SomeField = HandleUpdateCollision + +#if MIN_VERSION_base(4,8,0) +pattern SomeField :: EntityField record typ -> SomeField record +#endif +pattern SomeField x = CopyField x +{-# DEPRECATED SomeField "The type SomeField is deprecated. Use the type HandleUpdateCollision instead, and use the function copyField instead of the data constructor." #-} + -- | 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 :: PersistField typ => EntityField record (Maybe typ) -> HandleUpdateCollision 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 +-- The resulting 'HandleUpdateCollision' type is useful for the -- 'insertManyOnDuplicateKeyUpdate' function. -- -- @since 2.6.2 -copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> SomeField record +copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision 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 +-- The resulting 'HandleUpdateCollision' type is useful for the -- 'insertManyOnDuplicateKeyUpdate' function. -- -- @since 2.6.2 -copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> SomeField record +copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record copyUnlessEq = CopyUnlessEq +-- | Copy the field directly from the record. +-- +-- @since 3.0 +copyField :: PersistField typ => EntityField record typ -> HandleUpdateCollision record +copyField = CopyField + -- | 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. @@ -1097,9 +1131,9 @@ -- 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__ +-- === __More details on 'HandleUpdateCollision' usage__ -- --- The @['SomeField']@ parameter allows you to specify which fields (and +-- The @['HandleUpdateCollision']@ 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: -- @@ -1181,13 +1215,12 @@ , 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. + -> [HandleUpdateCollision 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 fieldValues updates = - withReaderT projectBackend - . uncurry rawExecute + uncurry rawExecute $ mkBulkInsertQuery records fieldValues updates -- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. If you @@ -1197,14 +1230,14 @@ mkBulkInsertQuery :: 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. + -> [HandleUpdateCollision 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 <> copyUnlessValues) where mfieldDef x = case x of - SomeField rec -> Right (fieldDbToText (persistFieldDef rec)) + CopyField 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 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.2.1 +version: 2.8.0 license: MIT license-file: LICENSE author: Felipe Lessa , Michael Snoyman @@ -27,18 +27,18 @@ extra-source-files: ChangeLog.md library - build-depends: base >= 4.6 && < 5 + build-depends: base >= 4.8 && < 5 , transformers >= 0.2.1 , mysql-simple >= 0.4.3 && < 0.5 , mysql >= 0.1.1.3 && < 0.2 , blaze-builder - , persistent >= 2.6.1 && < 3 + , persistent >= 2.8.0 && < 3 , containers >= 0.2 , bytestring >= 0.9 , text >= 0.11.0.6 - , monad-control >= 0.2 + , unliftio-core , aeson >= 0.6.2 - , conduit >= 0.5.3 + , conduit >= 1.2.8 , resourcet >= 0.4.10 , monad-logger , resource-pool