persistent-mysql 2.6.2.1 → 2.13.1.6
raw patch · 9 files changed
Files
- ChangeLog.md +135/−0
- Database/Persist/MySQL.hs +1771/−1272
- persistent-mysql.cabal +88/−43
- test/CustomConstraintTest.hs +82/−0
- test/ImplicitUuidSpec.hs +88/−0
- test/InsertDuplicateUpdate.hs +110/−0
- test/JSONTest.hs +36/−0
- test/MyInit.hs +200/−0
- test/main.hs +255/−0
ChangeLog.md view
@@ -1,3 +1,138 @@+# Changelog for persistent-mysql++## 2.13.1.6++* [#1610](https://github.com/yesodweb/persistent/pull/1610)+ * Added `NoAction` as a `CascadeAction` ++## 2.13.1.5++* [#1526](https://github.com/yesodweb/persistent/pull/1526)+ * Parse `tinyint` column as `SqlOther "tinyint"` rather than `SqlBool`, fixing breakage in legitimate non-Boolean uses of `tinyint` on MySQL 8.0++## 2.13.1.4++* [#1459](https://github.com/yesodweb/persistent/pull/1459)+ * Make use of `CautiousMigration` type alias for clarity.++## 2.13.1.3++* [#1372](https://github.com/yesodweb/persistent/pull/1372)+ * Fix migrations which add a new column in `persistent-mysql` ([#1373](https://github.com/yesodweb/persistent/issues/1373))+ * Include MigrationTest in `persistent-mysql` tests++## 2.13.1.2++* [#1367](https://github.com/yesodweb/persistent/pull/1367),+ [#1366](https://github.com/yesodweb/persistent/pull/1367),+ [#1338](https://github.com/yesodweb/persistent/pull/1338),+ [#1335](https://github.com/yesodweb/persistent/pull/1335)+ * Support GHC 9.2++## 2.13.1.1++* [#1360](https://github.com/yesodweb/persistent/pull/1360)+ * Fix anomalies in migration of integer columns in MySQL 8++## 2.13.1.0++* [#1341](https://github.com/yesodweb/persistent/pull/1341)+ * Add `SqlBackendHooks` to allow for instrumentation of queries.+* [#1327](https://github.com/yesodweb/persistent/pull/1327)+ * Update backend to support new `StatementCache` interface++## 2.13.0.4++* No longer errors on `json` columns. [#1333](https://github.com/yesodweb/persistent/pull/1333)++## 2.13.0.3++* Bugfix: Omit `REFERENCES` in `CREATe TABLE` statements. These are ignored by+ MySQL, but are a syntax error for MariaDB.+ [#1355](https://github.com/yesodweb/persistent/pull/1355), a continuation of+ [#1283](https://github.com/yesodweb/persistent/pull/1283)++## 2.13.0.2++* Bugfix: prevent fetching constraint info from other databases during migrations [#1301](https://github.com/yesodweb/persistent/pull/1301)++## 2.13.0.1++* [#1275](https://github.com/yesodweb/persistent/pull/1275)+ * Fix `SafeToRemove`++## 2.13.0.0++* [#1225](https://github.com/yesodweb/persistent/pull/1225)+ * Support `persistent-2.13` changes for SqlBackend being made internal.+ * Remove the deprecated `SomeField` type and pattern.++## 2.12.1.0++* Expose `openMySQLConn` for explicit reference to opened connection. [#1248](https://github.com/yesodweb/persistent/pull/1248)+ * Makes it convenient to use with `mysql-simple`.++## 2.12.0.0++* Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174)++## 2.10.3.1+* Fix foreign key migrations [#1167] https://github.com/yesodweb/persistent/pull/1167+ * Fix a bug where a foreign key of a field to its table was ignored.++## 2.10.3++* Compatibility with latest persistent++## 2.10.2.3++* Fix issue with multiple foreign keys on single column. [#1025](https://github.com/yesodweb/persistent/pull/1025)++## 2.10.2.2++* Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files)++## 2.10.2.1++* Changed persistent-mysql to use 'utf8mb4' instead of 'utf8' in migrations [#980](https://github.com/yesodweb/persistent/pull/980) @charukiewicz++## 2.10.2++* Added support for GHC 8.8 [#977](https://github.com/yesodweb/persistent/pull/977)++## 2.10.1++* Added `constraint=` attribute to allow users to specify foreign reference constraint names.++## 2.10.0++* Remove deprecated `SomeField` type and pattern synonym. Use `HandleUpdateCollision` type instead and the `copyField` function instead of `SomeField` constructor/pattern. [#894](https://github.com/yesodweb/persistent/pull/894)++## 2.9.0++* Added support for SQL isolation levels to via SqlBackend. [#812]+* Fix [832](https://github.com/yesodweb/persistent/issues/832): `repsertMany` now matches `mapM_ (uncurry repsert)` and is atomic.++## 2.8.1++* Implemented `connPutManySql` to utilize batched `putMany`. [#770](https://github.com/yesodweb/persistent/pull/770)++## 2.8.0++* 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)
Database/Persist/MySQL.hs view
@@ -1,1272 +1,1771 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--- | A MySQL backend for @persistent@.-module Database.Persist.MySQL- ( withMySQLPool- , withMySQLConn- , createMySQLPool- , module Database.Persist.Sql- , MySQL.ConnectInfo(..)- , MySQLBase.SSLInfo(..)- , MySQL.defaultConnectInfo- , MySQLBase.defaultSSLInfo- , MySQLConf(..)- , mockMigration- , insertOnDuplicateKeyUpdate- , insertManyOnDuplicateKeyUpdate- , SomeField(SomeField)- , copyUnlessNull- , copyUnlessEmpty- , copyUnlessEq- ) where--import Control.Arrow-import Control.Monad.Logger (MonadLogger, runNoLoggingT)-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.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.Fixed (Pico)-import Data.Function (on)-import Data.IORef-import Data.List (find, intercalate, sort, groupBy)-import Data.Pool (Pool)-import Data.Text (Text, pack)-import qualified Data.Text.IO as T-import Text.Read (readMaybe)-import System.Environment (getEnvironment)-import Data.Acquire (Acquire, mkAcquire, with)--import Data.Conduit-import qualified Blaze.ByteString.Builder.Char8 as BBB-import qualified Blaze.ByteString.Builder.ByteString as BBS-import qualified Data.Conduit.List as CL-import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.Encoding as T--import Database.Persist.Sql-import Database.Persist.Sql.Types.Internal (mkPersistBackend)-import Data.Int (Int64)--import qualified Database.MySQL.Simple as MySQL-import qualified Database.MySQL.Simple.Param as MySQL-import qualified Database.MySQL.Simple.Result as MySQL-import qualified Database.MySQL.Simple.Types as MySQL--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 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'--- outside the action since it may be already been released.-withMySQLPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend)- => MySQL.ConnectInfo- -- ^ Connection information.- -> Int- -- ^ Number of connections to be kept open in the pool.- -> (Pool backend -> m a)- -- ^ Action to be executed that uses the connection pool.- -> m a-withMySQLPool ci = withSqlPool $ open' ci----- | 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)- => MySQL.ConnectInfo- -- ^ Connection information.- -> Int- -- ^ Number of connections to be kept open in the pool.- -> m (Pool backend)-createMySQLPool ci = createSqlPool $ open' ci----- | 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)- => MySQL.ConnectInfo- -- ^ Connection information.- -> (backend -> m a)- -- ^ Action to be executed that uses the connection.- -> m a-withMySQLConn = withSqlConn . open'----- | Internal function that opens a connection to the MySQL--- server.-open' :: (IsSqlBackend backend) => MySQL.ConnectInfo -> LogFunc -> IO backend-open' ci logFunc = do- conn <- MySQL.connect ci- MySQLBase.autocommit conn False -- disable autocommit!- smap <- newIORef $ Map.empty- return . mkPersistBackend $ SqlBackend- { connPrepare = prepare' conn- , connStmtMap = smap- , connInsertSql = insertSql'- , connInsertManySql = Nothing- , connUpsertSql = Nothing- , connClose = MySQL.close conn- , connMigrateSql = migrate' ci- , connBegin = const $ MySQL.execute_ conn "start transaction" >> return ()- , connCommit = const $ MySQL.commit conn- , connRollback = const $ MySQL.rollback conn- , connEscapeName = pack . escapeDBName- , connNoLimit = "LIMIT 18446744073709551615"- -- This noLimit is suggested by MySQL's own docs, see- -- <http://dev.mysql.com/doc/refman/5.5/en/select.html>- , connRDBMS = "mysql"- , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615"- , connLogFunc = logFunc- , connMaxParams = Nothing- }---- | Prepare a query. We don't support prepared statements, but--- we'll do some client-side preprocessing here.-prepare' :: MySQL.Connection -> Text -> IO Statement-prepare' conn sql = do- let query = MySQL.Query (T.encodeUtf8 sql)- return Statement- { stmtFinalize = return ()- , stmtReset = return ()- , stmtExecute = execute' conn query- , stmtQuery = withStmt' conn query- }----- | SQL code to be executed when inserting an entity.-insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult-insertSql' ent vals =- let sql = pack $ concat- [ "INSERT INTO "- , escapeDBName $ entityDB ent- , "("- , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent- , ") VALUES("- , intercalate "," (map (const "?") $ entityFields ent)- , ")"- ]- in case entityPrimary ent of- Just _ -> ISRManyKeys sql vals- Nothing -> ISRInsertGet sql "SELECT LAST_INSERT_ID()"---- | Execute an statement that doesn't return any results.-execute' :: MySQL.Connection -> MySQL.Query -> [PersistValue] -> IO Int64-execute' conn query vals = MySQL.execute conn query (map P vals)----- | Execute an statement that does return results. The results--- are fetched all at once and stored into memory.-withStmt' :: MonadIO m- => MySQL.Connection- -> MySQL.Query- -> [PersistValue]- -> Acquire (Source m [PersistValue])-withStmt' conn query vals = do- result <- mkAcquire createResult MySQLBase.freeResult- return $ fetchRows result >>= CL.sourceList- where- createResult = do- -- Execute the query- formatted <- MySQL.formatQuery conn query (map P vals)- MySQLBase.query conn formatted- MySQLBase.storeResult conn-- fetchRows result = liftIO $ do- -- Find out the type of the columns- fields <- MySQLBase.fetchFields result- let getters = [ maybe PersistNull (getGetter f f . Just) | f <- fields]- convert = use getters- where use (g:gs) (col:cols) =- let v = g col- vs = use gs cols- in v `seq` vs `seq` (v:vs)- use _ _ = []-- -- Ready to go!- let go acc = do- row <- MySQLBase.fetchRow result- case row of- [] -> return (acc [])- _ -> let converted = convert row- in converted `seq` go (acc . (converted:))- go id----- | @newtype@ around 'PersistValue' that supports the--- 'MySQL.Param' type class.-newtype P = P PersistValue--instance MySQL.Param P where- render (P (PersistText t)) = MySQL.render t- render (P (PersistByteString bs)) = MySQL.render bs- render (P (PersistInt64 i)) = MySQL.render i- render (P (PersistDouble d)) = MySQL.render d- render (P (PersistBool b)) = MySQL.render b- render (P (PersistDay d)) = MySQL.render d- render (P (PersistTimeOfDay t)) = MySQL.render t- render (P (PersistUTCTime t)) = MySQL.render t- render (P PersistNull) = MySQL.render MySQL.Null- render (P (PersistList l)) = MySQL.render $ listToJSON l- render (P (PersistMap m)) = MySQL.render $ mapToJSON m- render (P (PersistRational r)) =- MySQL.Plain $ BBB.fromString $ show (fromRational r :: Pico)- -- FIXME: Too Ambigous, can not select precision without information about field- render (P (PersistDbSpecific s)) = MySQL.Plain $ BBS.fromByteString s- render (P (PersistObjectId _)) =- error "Refusing to serialize a PersistObjectId to a MySQL value"----- | @Getter a@ is a function that converts an incoming value--- into a data type @a@.-type Getter a = MySQLBase.Field -> Maybe ByteString -> a---- | Helper to construct 'Getter'@s@ using 'MySQL.Result'.-convertPV :: MySQL.Result a => (a -> b) -> Getter b-convertPV f = (f .) . MySQL.convert---- | Get the corresponding @'Getter' 'PersistValue'@ depending on--- the type of the column.-getGetter :: MySQLBase.Field -> Getter PersistValue-getGetter field = go (MySQLBase.fieldType field) - (MySQLBase.fieldLength field)- (MySQLBase.fieldCharSet field)- where- -- Bool- go MySQLBase.Tiny 1 _ = convertPV PersistBool- go MySQLBase.Tiny _ _ = convertPV PersistInt64- -- Int64- go MySQLBase.Int24 _ _ = convertPV PersistInt64- go MySQLBase.Short _ _ = convertPV PersistInt64- go MySQLBase.Long _ _ = convertPV PersistInt64- go MySQLBase.LongLong _ _ = convertPV PersistInt64- -- Double- go MySQLBase.Float _ _ = convertPV PersistDouble- go MySQLBase.Double _ _ = convertPV PersistDouble- go MySQLBase.Decimal _ _ = convertPV PersistDouble- go MySQLBase.NewDecimal _ _ = convertPV PersistDouble-- -- ByteString and Text-- -- The MySQL C client (and by extension the Haskell mysql package) doesn't distinguish between binary and non-binary string data at the type level.- -- (e.g. both BLOB and TEXT have the MySQLBase.Blob type).- -- Instead, the character set distinguishes them. Binary data uses character set number 63.- -- See https://dev.mysql.com/doc/refman/5.6/en/c-api-data-structures.html (Search for "63")- go MySQLBase.VarChar _ 63 = convertPV PersistByteString- go MySQLBase.VarString _ 63 = convertPV PersistByteString- go MySQLBase.String _ 63 = convertPV PersistByteString-- go MySQLBase.VarChar _ _ = convertPV PersistText- go MySQLBase.VarString _ _ = convertPV PersistText- go MySQLBase.String _ _ = convertPV PersistText- - go MySQLBase.Blob _ 63 = convertPV PersistByteString- go MySQLBase.TinyBlob _ 63 = convertPV PersistByteString- go MySQLBase.MediumBlob _ 63 = convertPV PersistByteString- go MySQLBase.LongBlob _ 63 = convertPV PersistByteString-- go MySQLBase.Blob _ _ = convertPV PersistText- go MySQLBase.TinyBlob _ _ = convertPV PersistText- go MySQLBase.MediumBlob _ _ = convertPV PersistText- go MySQLBase.LongBlob _ _ = convertPV PersistText-- -- Time-related- go MySQLBase.Time _ _ = convertPV PersistTimeOfDay- go MySQLBase.DateTime _ _ = convertPV PersistUTCTime- go MySQLBase.Timestamp _ _ = convertPV PersistUTCTime- go MySQLBase.Date _ _ = convertPV PersistDay- go MySQLBase.NewDate _ _ = convertPV PersistDay- go MySQLBase.Year _ _ = convertPV PersistDay- -- Null- go MySQLBase.Null _ _ = \_ _ -> PersistNull- -- Controversial conversions- go MySQLBase.Set _ _ = convertPV PersistText- go MySQLBase.Enum _ _ = convertPV PersistText- -- Conversion using PersistDbSpecific- go MySQLBase.Geometry _ _ = \_ m ->- case m of- Just g -> PersistDbSpecific g- Nothing -> error "Unexpected null in database specific value"- -- Unsupported- go other _ _ = error $ "MySQL.getGetter: type " ++- show other ++ " not supported."------------------------------------------------------------------------------- | Create the migration plan for the given 'PersistEntity'--- @val@.-migrate' :: MySQL.ConnectInfo- -> [EntityDef]- -> (Text -> IO Statement)- -> EntityDef- -> IO (Either [Text] [(Bool, Text)])-migrate' connectInfo allDefs getter val = do- let name = entityDB val- (idClmn, old) <- getColumns connectInfo getter val- let (newcols, udefs, fdefs) = mkColumns allDefs val- let udspair = map udToPair udefs- case (idClmn, old, partitionEithers old) of- -- Nothing found, create everything- ([], [], _) -> do- let uniques = flip concatMap udspair $ \(uname, ucols) ->- [ AlterTable name $- AddUniqueConstraint uname $- map (findTypeAndMaxLen name) ucols ]- let foreigns = do- Column { cName=cname, cReference=Just (refTblName, _a) } <- newcols- return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname)- - let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs- - return $ Right $ map showAlterDb $ (addTable newcols val): uniques ++ foreigns ++ foreignsAlt- -- No errors and something found, migrate- (_, _, ([], old')) -> do- let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of- Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of- Just _ -> c { cReference = Nothing }- Nothing -> c- Nothing -> c) xs,ys)- (acs, ats) = getAlters allDefs name (newcols, udspair) $ excludeForeignKeys $ partitionEithers old'- acs' = map (AlterColumn name) acs- ats' = map (AlterTable name) ats- return $ Right $ map showAlterDb $ acs' ++ ats'- -- Errors- (_, _, (errs, _)) -> return $ Left errs-- where- findTypeAndMaxLen tblName col = let (col', ty) = findTypeOfColumn allDefs tblName col- (_, ml) = findMaxLenOfColumn allDefs tblName col- in (col', ty, ml)--addTable :: [Column] -> EntityDef -> AlterDB-addTable cols entity = AddTable $ concat- -- Lower case e: see Database.Persist.Sql.Migration- [ "CREATe TABLE "- , escapeDBName name- , "("- , idtxt- , if null cols then [] else ","- , intercalate "," $ map showColumn cols- , ")"- ]- where- name = entityDB entity- idtxt = case entityPrimary entity of- Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . fieldDB) $ compositeFields pdef, ")"]- Nothing ->- let defText = defaultAttribute $ fieldAttrs $ entityId entity- sType = fieldSqlType $ entityId entity- autoIncrementText = case (sType, defText) of- (SqlInt64, Nothing) -> " AUTO_INCREMENT"- _ -> ""- maxlen = findMaxLenOfField (entityId entity)- in concat- [ escapeDBName $ fieldDB $ entityId entity- , " " <> showSqlType sType maxlen False- , " NOT NULL"- , autoIncrementText- , " PRIMARY KEY"- ]---- | Find out the type of a column.-findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType)-findTypeOfColumn allDefs name col =- maybe (error $ "Could not find type of column " ++- show col ++ " on table " ++ show name ++- " (allDefs = " ++ show allDefs ++ ")")- ((,) col) $ do- entDef <- find ((== name) . entityDB) allDefs- fieldDef <- find ((== col) . fieldDB) (entityFields entDef)- return (fieldType fieldDef)---- | Find out the maxlen of a column (default to 200)-findMaxLenOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, Integer)-findMaxLenOfColumn allDefs name col =- maybe (col, 200)- ((,) col) $ do- entDef <- find ((== name) . entityDB) allDefs- fieldDef <- find ((== col) . fieldDB) (entityFields entDef)- findMaxLenOfField fieldDef---- | Find out the maxlen of a field-findMaxLenOfField :: FieldDef -> Maybe Integer-findMaxLenOfField fieldDef = do- maxLenAttr <- find ((T.isPrefixOf "maxlen=") . T.toLower) (fieldAttrs fieldDef)- readMaybe . T.unpack . T.drop 7 $ maxLenAttr---- | Helper for 'AddReference' that finds out the which primary key columns to reference.-addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn-addReference allDefs fkeyname reftable cname = AddReference reftable fkeyname [cname] referencedColumns- where- referencedColumns = maybe (error $ "Could not find ID of entity " ++ show reftable- ++ " (allDefs = " ++ show allDefs ++ ")")- id $ do- entDef <- find ((== reftable) . entityDB) allDefs- return $ map fieldDB $ entityKeyFields entDef--data AlterColumn = Change Column- | Add' Column- | Drop- | Default String- | NoDefault- | Update' String- -- | See the definition of the 'showAlter' function to see how these fields are used.- | AddReference- DBName -- Referenced table- DBName -- Foreign key name- [DBName] -- Referencing columns- [DBName] -- Referenced columns- | DropReference DBName--type AlterColumn' = (DBName, AlterColumn)--data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType, Integer)]- | DropUniqueConstraint DBName--data AlterDB = AddTable String- | AlterColumn DBName AlterColumn'- | AlterTable DBName AlterTable---udToPair :: UniqueDef -> (DBName, [DBName])-udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud)----------------------------------------------------------------------------- | Returns all of the 'Column'@s@ in the given table currently--- in the database.-getColumns :: MySQL.ConnectInfo- -> (Text -> IO Statement)- -> EntityDef- -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column- , [Either Text (Either Column (DBName, [DBName]))] -- everything else- )-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-- -- 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-- -- 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)-- -- Return both- return (ids, cs ++ us)- where- vals = [ PersistText $ pack $ MySQL.connectDatabase connectInfo- , PersistText $ unDBName $ entityDB def- , PersistText $ unDBName $ fieldDB $ entityId def ]-- helperClmns = CL.mapM getIt =$ CL.consume- where- getIt = fmap (either Left (Right . Left)) .- liftIO .- getColumn connectInfo getter (entityDB def)-- helperCntrs = do- let check [ PersistText cntrName- , PersistText clmnName] = return ( cntrName, clmnName )- check other = fail $ "helperCntrs: unexpected " ++ show other- rows <- mapM check =<< CL.consume- return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd)))- $ groupBy ((==) `on` fst) rows----- | Get the information about a column in a table.-getColumn :: MySQL.ConnectInfo- -> (Text -> IO Statement)- -> DBName- -> [PersistValue]- -> IO (Either Text Column)-getColumn connectInfo getter tname [ PersistText cname- , PersistText null_- , PersistText dataType- , PersistText colType- , colMaxLen- , colPrecision- , colScale- , default'] =- fmap (either (Left . pack) Right) $- runExceptT $ do- -- Default value- default_ <- case default' of- PersistNull -> return Nothing- PersistText t -> return (Just t)- PersistByteString bs ->- case T.decodeUtf8' bs of- Left exc -> fail $ "Invalid default column: " ++- show default' ++ " (error: " ++- show exc ++ ")"- Right t -> return (Just t)- _ -> 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"- let vars = [ PersistText $ pack $ MySQL.connectDatabase connectInfo- , PersistText $ unDBName $ tname- , PersistText cname- , PersistText $ pack $ MySQL.connectDatabase connectInfo ]- cntrs <- with (stmtQuery stmt vars) ($$ CL.consume)- ref <- case cntrs of- [] -> return Nothing- [[PersistText tab, PersistText ref, PersistInt64 pos]] ->- return $ if pos == 1 then Just (DBName tab, DBName ref) else Nothing- _ -> fail "MySQL.getColumn/getRef: never here"-- let colMaxLen' = case colMaxLen of- PersistInt64 l -> Just (fromIntegral l)- _ -> Nothing- ci = ColumnInfo- { ciColumnType = colType- , ciMaxLength = colMaxLen'- , ciNumericPrecision = colPrecision- , ciNumericScale = colScale- }- (typ, maxLen) <- parseColumnType dataType ci- -- Okay!- return Column- { cName = DBName $ cname- , cNull = null_ == "YES"- , cSqlType = typ- , cDefault = default_- , cDefaultConstraintName = Nothing- , cMaxLen = maxLen- , cReference = ref- }--getColumn _ _ _ x =- return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x---- | Extra column information from MySQL schema-data ColumnInfo = ColumnInfo- { ciColumnType :: Text- , ciMaxLength :: Maybe Integer- , ciNumericPrecision :: PersistValue- , ciNumericScale :: PersistValue- }---- | Parse the type of column as returned by MySQL's--- @INFORMATION_SCHEMA@ tables.-parseColumnType :: Monad m => Text -> ColumnInfo -> m (SqlType, Maybe Integer)--- Ints-parseColumnType "tinyint" ci | ciColumnType ci == "tinyint(1)" = return (SqlBool, Nothing)-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 "decimal" ci =- case (ciNumericPrecision ci, ciNumericScale ci) of- (PersistInt64 p, PersistInt64 s) ->- return (SqlNumeric (fromIntegral p) (fromIntegral s), Nothing)- _ ->- fail "missing DECIMAL precision in DB schema"--- 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)-parseColumnType "date" _ = return (SqlDay, Nothing)--parseColumnType _ ci = return (SqlOther (ciColumnType ci), Nothing)------------------------------------------------------------------------------ | @getAlters allDefs tblName new old@ finds out what needs to--- be changed from @old@ to become @new@.-getAlters :: [EntityDef]- -> DBName- -> ([Column], [(DBName, [DBName])])- -> ([Column], [(DBName, [DBName])])- -> ([AlterColumn'], [AlterTable])-getAlters allDefs tblName (c1, u1) (c2, u2) =- (getAltersC c1 c2, getAltersU u1 u2)- where- getAltersC [] old = concatMap dropColumn old- getAltersC (new:news) old =- let (alters, old') = findAlters tblName allDefs new old- in alters ++ getAltersC news old'-- dropColumn col =- map ((,) (cName col)) $- [DropReference n | Just (_, n) <- [cReference col]] ++- [Drop]-- getAltersU [] old = map (DropUniqueConstraint . fst) old- getAltersU ((name, cols):news) old =- case lookup name old of- Nothing ->- AddUniqueConstraint name (map findTypeAndMaxLen cols) : getAltersU news old- Just ocols ->- let old' = filter (\(x, _) -> x /= name) old- in if sort cols == ocols- then getAltersU news old'- else DropUniqueConstraint name- : AddUniqueConstraint name (map findTypeAndMaxLen cols)- : getAltersU news old'- where- findTypeAndMaxLen col = let (col', ty) = findTypeOfColumn allDefs tblName col- (_, ml) = findMaxLenOfColumn allDefs tblName col- in (col', ty, ml)----- | @findAlters newColumn oldColumns@ finds out what needs to be--- changed in the columns @oldColumns@ for @newColumn@ to be--- supported.-findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column])-findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName maxLen ref) cols =- case filter ((name ==) . cName) cols of- -- new fkey that didnt exist before- [] -> case ref of- Nothing -> ([(name, Add' col)],[])- Just (tname, _b) -> let cnstr = [addReference allDefs (refName tblName name) tname name]- in (map ((,) tname) (Add' col : cnstr), cols)- Column _ isNull' type_' def' _defConstraintName' maxLen' ref':_ ->- let -- Foreign key- refDrop = case (ref == ref', ref') of- (False, Just (_, cname)) -> [(name, DropReference cname)]- _ -> []- refAdd = case (ref == ref', ref) of- (False, Just (tname, _cname)) -> [(tname, addReference allDefs (refName tblName name) tname name)]- _ -> []- -- Type and nullability- modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = []- | otherwise = [(name, Change col)]- -- Default value- -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields- modDef | def == def' = []- | otherwise = case def of- Nothing -> [(name, NoDefault)]- Just s -> if T.toUpper s == "NULL" then []- else [(name, Default $ T.unpack s)]- in ( refDrop ++ modType ++ modDef ++ refAdd- , filter ((name /=) . cName) cols )-- where- ciEquals x y = T.toCaseFold (T.pack x) == T.toCaseFold (T.pack y)----------------------------------------------------------------------------- | Prints the part of a @CREATE TABLE@ statement about a given--- column.-showColumn :: Column -> String-showColumn (Column n nu t def _defConstraintName maxLen ref) = concat- [ escapeDBName n- , " "- , showSqlType t maxLen True- , " "- , if nu then "NULL" else "NOT NULL"- , case def of- Nothing -> ""- Just s -> -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields- if T.toUpper s == "NULL" then ""- else " DEFAULT " ++ T.unpack s- , case ref of- Nothing -> ""- Just (s, _) -> " REFERENCES " ++ escapeDBName s- ]----- | Renders an 'SqlType' in MySQL's format.-showSqlType :: SqlType- -> Maybe Integer -- ^ @maxlen@- -> Bool -- ^ include character set information?- -> String-showSqlType SqlBlob Nothing _ = "BLOB"-showSqlType SqlBlob (Just i) _ = "VARBINARY(" ++ show i ++ ")"-showSqlType SqlBool _ _ = "TINYINT(1)"-showSqlType SqlDay _ _ = "DATE"-showSqlType SqlDayTime _ _ = "DATETIME"-showSqlType SqlInt32 _ _ = "INT(11)"-showSqlType SqlInt64 _ _ = "BIGINT"-showSqlType SqlReal _ _ = "DOUBLE"-showSqlType (SqlNumeric s prec) _ _ = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")"-showSqlType SqlString Nothing True = "TEXT CHARACTER SET utf8"-showSqlType SqlString Nothing False = "TEXT"-showSqlType SqlString (Just i) True = "VARCHAR(" ++ show i ++ ") CHARACTER SET utf8"-showSqlType SqlString (Just i) False = "VARCHAR(" ++ show i ++ ")"-showSqlType SqlTime _ _ = "TIME"-showSqlType (SqlOther t) _ _ = T.unpack t---- | Render an action that must be done on the database.-showAlterDb :: AlterDB -> (Bool, Text)-showAlterDb (AddTable s) = (False, pack s)-showAlterDb (AlterColumn t (c, ac)) =- (isUnsafe ac, pack $ showAlter t (c, ac))- where- isUnsafe Drop = True- isUnsafe _ = False-showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at)----- | Render an action that must be done on a table.-showAlterTable :: DBName -> AlterTable -> String-showAlterTable table (AddUniqueConstraint cname cols) = concat- [ "ALTER TABLE "- , escapeDBName table- , " ADD CONSTRAINT "- , escapeDBName cname- , " UNIQUE("- , intercalate "," $ map escapeDBName' cols- , ")"- ]- where- escapeDBName' (name, (FTTypeCon _ "Text" ), maxlen) = escapeDBName name ++ "(" ++ show maxlen ++ ")"- escapeDBName' (name, (FTTypeCon _ "String" ), maxlen) = escapeDBName name ++ "(" ++ show maxlen ++ ")"- escapeDBName' (name, (FTTypeCon _ "ByteString"), maxlen) = escapeDBName name ++ "(" ++ show maxlen ++ ")"- escapeDBName' (name, _ , _) = escapeDBName name-showAlterTable table (DropUniqueConstraint cname) = concat- [ "ALTER TABLE "- , escapeDBName table- , " DROP INDEX "- , escapeDBName cname- ]----- | Render an action that must be done on a column.-showAlter :: DBName -> AlterColumn' -> String-showAlter table (oldName, Change (Column n nu t def defConstraintName maxLen _ref)) =- concat- [ "ALTER TABLE "- , escapeDBName table- , " CHANGE "- , escapeDBName oldName- , " "- , showColumn (Column n nu t def defConstraintName maxLen Nothing)- ]-showAlter table (_, Add' col) =- concat- [ "ALTER TABLE "- , escapeDBName table- , " ADD COLUMN "- , showColumn col- ]-showAlter table (n, Drop) =- concat- [ "ALTER TABLE "- , escapeDBName table- , " DROP COLUMN "- , escapeDBName n- ]-showAlter table (n, Default s) =- concat- [ "ALTER TABLE "- , escapeDBName table- , " ALTER COLUMN "- , escapeDBName n- , " SET DEFAULT "- , s- ]-showAlter table (n, NoDefault) =- concat- [ "ALTER TABLE "- , escapeDBName table- , " ALTER COLUMN "- , escapeDBName n- , " DROP DEFAULT"- ]-showAlter table (n, Update' s) =- concat- [ "UPDATE "- , escapeDBName table- , " SET "- , escapeDBName n- , "="- , s- , " WHERE "- , escapeDBName n- , " IS NULL"- ]-showAlter table (_, AddReference reftable fkeyname t2 id2) = concat- [ "ALTER TABLE "- , escapeDBName table- , " ADD CONSTRAINT "- , escapeDBName fkeyname- , " FOREIGN KEY("- , intercalate "," $ map escapeDBName t2- , ") REFERENCES "- , escapeDBName reftable- , "("- , intercalate "," $ map escapeDBName id2- , ")"- ]-showAlter table (_, DropReference cname) = concat- [ "ALTER TABLE "- , escapeDBName table- , " DROP FOREIGN KEY "- , escapeDBName cname- ]--refName :: DBName -> DBName -> DBName-refName (DBName table) (DBName column) =- DBName $ T.concat [table, "_", column, "_fkey"]----------------------------------------------------------------------------- | Escape a database name to be included on a query.-escapeDBName :: DBName -> String-escapeDBName (DBName s) = '`' : go (T.unpack s)- where- go ('`':xs) = '`' : '`' : go xs- go ( x :xs) = x : go xs- go "" = "`"---- | Information required to connect to a MySQL database--- using @persistent@'s generic facilities. These values are the--- same that are given to 'withMySQLPool'.-data MySQLConf = MySQLConf- { myConnInfo :: MySQL.ConnectInfo- -- ^ The connection information.- , myPoolSize :: Int- -- ^ How many connections should be held on the connection pool.- } deriving Show--instance FromJSON MySQLConf where- parseJSON v = modifyFailure ("Persistent: error loading MySQL conf: " ++) $- flip (withObject "MySQLConf") v $ \o -> do- database <- o .: "database"- host <- o .: "host"- port <- o .: "port"- path <- o .:? "path"- user <- o .: "user"- password <- o .: "password"- pool <- o .: "poolsize"- let ci = MySQL.defaultConnectInfo- { MySQL.connectHost = host- , MySQL.connectPort = port- , MySQL.connectPath = case path of- Just p -> p- Nothing -> MySQL.connectPath MySQL.defaultConnectInfo- , MySQL.connectUser = user- , MySQL.connectPassword = password- , MySQL.connectDatabase = database- }- return $ MySQLConf ci pool--instance PersistConfig MySQLConf where- type PersistConfigBackend MySQLConf = SqlPersistT-- type PersistConfigPool MySQLConf = ConnectionPool-- createPoolConfig (MySQLConf cs size) = runNoLoggingT $ createMySQLPool cs size -- FIXME-- runPool _ = runSqlPool-- loadConfig = parseJSON-- applyEnv conf = do- env <- getEnvironment- let maybeEnv old var = maybe old id $ lookup ("MYSQL_" ++ var) env- return conf- { myConnInfo =- case myConnInfo conf of- MySQL.ConnectInfo- { MySQL.connectHost = host- , MySQL.connectPort = port- , MySQL.connectPath = path- , MySQL.connectUser = user- , MySQL.connectPassword = password- , MySQL.connectDatabase = database- } -> (myConnInfo conf)- { MySQL.connectHost = maybeEnv host "HOST"- , MySQL.connectPort = read $ maybeEnv (show port) "PORT"- , MySQL.connectPath = maybeEnv path "PATH"- , MySQL.connectUser = maybeEnv user "USER"- , MySQL.connectPassword = maybeEnv password "PASSWORD"- , MySQL.connectDatabase = maybeEnv database "DATABASE"- }- }--mockMigrate :: MySQL.ConnectInfo- -> [EntityDef]- -> (Text -> IO Statement)- -> EntityDef- -> IO (Either [Text] [(Bool, Text)])-mockMigrate _connectInfo allDefs _getter val = do- let name = entityDB val- let (newcols, udefs, fdefs) = mkColumns allDefs val- let udspair = map udToPair udefs- case () of- -- Nothing found, create everything- () -> do- let uniques = flip concatMap udspair $ \(uname, ucols) ->- [ AlterTable name $- AddUniqueConstraint uname $- map (findTypeAndMaxLen name) ucols ]- let foreigns = do- Column { cName=cname, cReference=Just (refTblName, _a) } <- newcols- return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname)-- let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))- in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs-- return $ Right $ map showAlterDb $ (addTable newcols val): uniques ++ foreigns ++ foreignsAlt- {- FIXME redundant, why is this here? The whole case expression is weird- -- No errors and something found, migrate- (_, _, ([], old')) -> do- let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of- Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of- Just _ -> c { cReference = Nothing }- Nothing -> c- Nothing -> c) xs,ys)- (acs, ats) = getAlters allDefs name (newcols, udspair) $ excludeForeignKeys $ partitionEithers old'- acs' = map (AlterColumn name) acs- ats' = map (AlterTable name) ats- return $ Right $ map showAlterDb $ acs' ++ ats'- -- Errors- (_, _, (errs, _)) -> return $ Left errs- -}-- where- findTypeAndMaxLen tblName col = let (col', ty) = findTypeOfColumn allDefs tblName col- (_, ml) = findMaxLenOfColumn allDefs tblName col- in (col', ty, ml)----- | Mock a migration even when the database is not present.--- This function will mock the migration for a database even when --- the actual database isn't already present in the system.-mockMigration :: Migration -> IO ()-mockMigration mig = do- smap <- newIORef $ Map.empty- let sqlbackend = SqlBackend { connPrepare = \_ -> do- return Statement- { stmtFinalize = return ()- , stmtReset = return ()- , stmtExecute = undefined- , stmtQuery = \_ -> return $ return ()- },- connInsertManySql = Nothing,- connInsertSql = undefined,- connStmtMap = smap,- connClose = undefined,- connMigrateSql = mockMigrate undefined,- connBegin = undefined,- connCommit = undefined,- connRollback = undefined,- connEscapeName = undefined,- connNoLimit = undefined,- connRDBMS = undefined,- connLimitOffset = undefined,- connLogFunc = undefined,- connUpsertSql = undefined,- connMaxParams = Nothing}- result = runReaderT . runWriterT . runWriterT $ mig - resp <- result sqlbackend- mapM_ T.putStrLn $ map snd $ snd resp---- | MySQL specific 'upsert'. This will prevent multiple queries, when one will--- do.-insertOnDuplicateKeyUpdate- :: ( backend ~ PersistEntityBackend record- , PersistEntity record- , MonadIO m- , PersistStore backend- , BackendCompatible SqlBackend backend- )- => record- -> [Update record]- -> ReaderT backend m ()-insertOnDuplicateKeyUpdate record =- 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.------ @since 2.6.2-data SomeField record where- -- | Copy the field directly from the record.- SomeField :: EntityField record typ -> SomeField record- -- | Only copy the field if it is not equal to the provided value.- CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> SomeField record---- | 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 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- :: 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 fieldValues updates =- withReaderT projectBackend- . uncurry rawExecute- $ mkBulkInsertQuery records fieldValues updates---- | 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- :: 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 <> copyUnlessValues)- where- 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- 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- , " ("- , commaSeparated entityFieldNames- , ") "- , " VALUES "- , recordPlaceholders- , " ON DUPLICATE KEY UPDATE "- , updateText- ]---- | Vendored from @persistent@.-mkUpdateText :: PersistEntity record => Update record -> Text-mkUpdateText x =- case updateUpdate x of- Assign -> n <> "=?"- Add -> T.concat [n, "=", n, "+?"]- Subtract -> T.concat [n, "=", n, "-?"]- Multiply -> T.concat [n, "=", n, "*?"]- Divide -> T.concat [n, "=", n, "/?"]- BackendSpecificUpdate up ->- error . T.unpack $ "BackendSpecificUpdate " <> up <> " not supported"- where- n = T.pack . escapeDBName . fieldDB . updateFieldDef $ x--commaSeparated :: [Text] -> Text-commaSeparated = T.intercalate ", "--parenWrapped :: Text -> Text-parenWrapped t = T.concat ["(", t, ")"]---- | Gets the 'FieldDef' for an 'Update'. Vendored from @persistent@.-updateFieldDef :: PersistEntity v => Update v -> FieldDef-updateFieldDef (Update f _ _) = persistFieldDef f-updateFieldDef BackendUpdate {} = error "updateFieldDef did not expect BackendUpdate"+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+-- Pattern match 'PersistDbSpecific'+{-# OPTIONS_GHC -fno-warn-deprecations #-}++-- | A MySQL backend for @persistent@.+module Database.Persist.MySQL+ ( withMySQLPool+ , withMySQLConn+ , createMySQLPool+ , module Database.Persist.Sql+ , MySQL.ConnectInfo (..)+ , MySQLBase.SSLInfo (..)+ , MySQL.defaultConnectInfo+ , MySQLBase.defaultSSLInfo+ , MySQLConf (..)+ , mockMigration++ -- * @ON DUPLICATE KEY UPDATE@ Functionality+ , insertOnDuplicateKeyUpdate+ , insertManyOnDuplicateKeyUpdate+ , HandleUpdateCollision+ , copyField+ , copyUnlessNull+ , copyUnlessEmpty+ , copyUnlessEq+ , openMySQLConn+ ) where++import qualified Blaze.ByteString.Builder.ByteString as BBS+import qualified Blaze.ByteString.Builder.Char8 as BBB++import Control.Arrow+import Control.Monad+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import Control.Monad.Trans.Writer (runWriterT)+import Data.IORef (newIORef)+import Data.Proxy (Proxy (..))++import Data.Acquire (Acquire, mkAcquire, with)+import Data.Aeson+import Data.Aeson.Types (modifyFailure)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Either (partitionEithers)+import Data.Fixed (Pico)+import Data.Function (on)+import Data.Int (Int64)+import Data.List (find, groupBy, intercalate, sort)+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Monoid ((<>))+import qualified Data.Monoid as Monoid+import Data.Pool (Pool)+import Data.Text (Text, pack)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import GHC.Stack+import System.Environment (getEnvironment)++import Database.Persist.Sql+import Database.Persist.Sql.Types.Internal (makeIsolationLevelStatement)+import qualified Database.Persist.Sql.Util as Util+import Database.Persist.SqlBackend+import Database.Persist.SqlBackend.StatementCache++import qualified Database.MySQL.Base as MySQLBase+import qualified Database.MySQL.Base.Types as MySQLBase+import qualified Database.MySQL.Simple as MySQL+import qualified Database.MySQL.Simple.Param as MySQL+import qualified Database.MySQL.Simple.Result as MySQL+import qualified Database.MySQL.Simple.Types as MySQL++-- | 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'+-- outside the action since it may be already been released.+withMySQLPool+ :: (MonadLoggerIO m, MonadUnliftIO m)+ => MySQL.ConnectInfo+ -- ^ Connection information.+ -> Int+ -- ^ Number of connections to be kept open in the pool.+ -> (Pool SqlBackend -> m a)+ -- ^ Action to be executed that uses the connection pool.+ -> m a+withMySQLPool ci = withSqlPool $ open' ci++-- | 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+ :: (MonadUnliftIO m, MonadLoggerIO m)+ => MySQL.ConnectInfo+ -- ^ Connection information.+ -> Int+ -- ^ Number of connections to be kept open in the pool.+ -> m (Pool SqlBackend)+createMySQLPool ci = createSqlPool $ open' ci++-- | Same as 'withMySQLPool', but instead of opening a pool+-- of connections, only one connection is opened.+withMySQLConn+ :: (MonadUnliftIO m, MonadLoggerIO m)+ => MySQL.ConnectInfo+ -- ^ Connection information.+ -> (SqlBackend -> m a)+ -- ^ Action to be executed that uses the connection.+ -> m a+withMySQLConn = withSqlConn . open'++-- | Open a connection to MySQL server, initialize the 'SqlBackend' and return+-- their tuple+--+-- @since 2.12.1.0+openMySQLConn+ :: MySQL.ConnectInfo -> LogFunc -> IO (MySQL.Connection, SqlBackend)+openMySQLConn ci logFunc = do+ conn <- MySQL.connect ci+ MySQLBase.autocommit conn False -- disable autocommit!+ smap <- newIORef mempty+ let+ backend =+ setConnPutManySql putManySql $+ setConnRepsertManySql repsertManySql $+ mkSqlBackend+ MkSqlBackendArgs+ { connPrepare = prepare' conn+ , connStmtMap = smap+ , connInsertSql = insertSql'+ , connClose = MySQL.close conn+ , connMigrateSql = migrate' ci+ , connBegin = \_ mIsolation -> do+ forM_ mIsolation $ \iso -> MySQL.execute_ conn (makeIsolationLevelStatement iso)+ MySQL.execute_ conn "start transaction" >> return ()+ , connCommit = const $ MySQL.commit conn+ , connRollback = const $ MySQL.rollback conn+ , connEscapeFieldName = T.pack . escapeF+ , connEscapeTableName = T.pack . escapeE . getEntityDBName+ , connEscapeRawName = T.pack . escapeDBName . T.unpack+ , connNoLimit = "LIMIT 18446744073709551615"+ , -- This noLimit is suggested by MySQL's own docs, see+ -- <http://dev.mysql.com/doc/refman/5.5/en/select.html>+ connRDBMS = "mysql"+ , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615"+ , connLogFunc = logFunc+ }+ pure (conn, backend)++-- | Internal function that opens a connection to the MySQL server.+open' :: MySQL.ConnectInfo -> LogFunc -> IO SqlBackend+open' ci logFunc = snd <$> openMySQLConn ci logFunc++-- | Prepare a query. We don't support prepared statements, but+-- we'll do some client-side preprocessing here.+prepare' :: MySQL.Connection -> Text -> IO Statement+prepare' conn sql = do+ let+ query = MySQL.Query (T.encodeUtf8 sql)+ return+ Statement+ { stmtFinalize = return ()+ , stmtReset = return ()+ , stmtExecute = execute' conn query+ , stmtQuery = withStmt' conn query+ }++-- | SQL code to be executed when inserting an entity.+insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult+insertSql' ent vals =+ case getEntityId ent of+ EntityIdNaturalKey _ ->+ ISRManyKeys sql vals+ EntityIdField _ ->+ ISRInsertGet sql "SELECT LAST_INSERT_ID()"+ where+ (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeFT)+ sql =+ T.concat+ [ "INSERT INTO "+ , escapeET $ getEntityDBName ent+ , "("+ , T.intercalate "," fieldNames+ , ") VALUES("+ , T.intercalate "," placeholders+ , ")"+ ]++-- | Execute an statement that doesn't return any results.+execute' :: MySQL.Connection -> MySQL.Query -> [PersistValue] -> IO Int64+execute' conn query vals = MySQL.execute conn query (map P vals)++-- | Execute an statement that does return results. The results+-- are fetched all at once and stored into memory.+withStmt'+ :: (MonadIO m)+ => MySQL.Connection+ -> MySQL.Query+ -> [PersistValue]+ -> Acquire (ConduitM () [PersistValue] m ())+withStmt' conn query vals = do+ result <- mkAcquire createResult MySQLBase.freeResult+ return $ fetchRows result >>= CL.sourceList+ where+ createResult = do+ -- Execute the query+ formatted <- MySQL.formatQuery conn query (map P vals)+ MySQLBase.query conn formatted+ MySQLBase.storeResult conn++ fetchRows result = liftIO $ do+ -- Find out the type of the columns+ fields <- MySQLBase.fetchFields result+ let+ getters = [maybe PersistNull (getGetter f f . Just) | f <- fields]+ convert = use getters+ where+ use (g : gs) (col : cols) =+ let+ !v = g col+ !vs = use gs cols+ in+ (v : vs)+ use _ _ = []++ -- Ready to go!+ let+ go acc = do+ row <- MySQLBase.fetchRow result+ case row of+ [] -> return (acc [])+ _ ->+ let+ !converted = convert row+ in+ go (acc . (converted :))+ go id++-- | @newtype@ around 'PersistValue' that supports the+-- 'MySQL.Param' type class.+newtype P = P PersistValue++instance MySQL.Param P where+ render (P (PersistText t)) = MySQL.render t+ render (P (PersistByteString bs)) = MySQL.render bs+ render (P (PersistInt64 i)) = MySQL.render i+ render (P (PersistDouble d)) = MySQL.render d+ render (P (PersistBool b)) = MySQL.render b+ render (P (PersistDay d)) = MySQL.render d+ render (P (PersistTimeOfDay t)) = MySQL.render t+ render (P (PersistUTCTime t)) = MySQL.render t+ render (P PersistNull) = MySQL.render MySQL.Null+ render (P (PersistList l)) = MySQL.render $ listToJSON l+ render (P (PersistMap m)) = MySQL.render $ mapToJSON m+ render (P (PersistRational r)) =+ MySQL.Plain $ BBB.fromString $ show (fromRational r :: Pico)+ -- FIXME: Too Ambiguous, can not select precision without information about field+ render (P (PersistLiteral_ DbSpecific s)) = MySQL.Plain $ BBS.fromByteString s+ render (P (PersistLiteral_ Unescaped l)) = MySQL.Plain $ BBS.fromByteString l+ render (P (PersistLiteral_ Escaped e)) = MySQL.Escape e+ render (P (PersistArray a)) = MySQL.render (P (PersistList a))+ render (P (PersistObjectId _)) =+ error "Refusing to serialize a PersistObjectId to a MySQL value"++-- | @Getter a@ is a function that converts an incoming value+-- into a data type @a@.+type Getter a = MySQLBase.Field -> Maybe ByteString -> a++-- | Helper to construct 'Getter'@s@ using 'MySQL.Result'.+convertPV :: (MySQL.Result a) => (a -> b) -> Getter b+convertPV f = (f .) . MySQL.convert++-- | Get the corresponding @'Getter' 'PersistValue'@ depending on+-- the type of the column.+getGetter :: MySQLBase.Field -> Getter PersistValue+getGetter field =+ go+ (MySQLBase.fieldType field)+ (MySQLBase.fieldLength field)+ (MySQLBase.fieldCharSet field)+ where+ -- Bool+ go MySQLBase.Tiny 1 _ = convertPV PersistBool+ go MySQLBase.Tiny _ _ = convertPV PersistInt64+ -- Int64+ go MySQLBase.Int24 _ _ = convertPV PersistInt64+ go MySQLBase.Short _ _ = convertPV PersistInt64+ go MySQLBase.Long _ _ = convertPV PersistInt64+ go MySQLBase.LongLong _ _ = convertPV PersistInt64+ -- Double+ go MySQLBase.Float _ _ = convertPV PersistDouble+ go MySQLBase.Double _ _ = convertPV PersistDouble+ go MySQLBase.Decimal _ _ = convertPV PersistDouble+ go MySQLBase.NewDecimal _ _ = convertPV PersistDouble+ -- ByteString and Text++ -- The MySQL C client (and by extension the Haskell mysql package) doesn't distinguish between binary and non-binary string data at the type level.+ -- (e.g. both BLOB and TEXT have the MySQLBase.Blob type).+ -- Instead, the character set distinguishes them. Binary data uses character set number 63.+ -- See https://dev.mysql.com/doc/refman/5.6/en/c-api-data-structures.html (Search for "63")+ go MySQLBase.VarChar _ 63 = convertPV PersistByteString+ go MySQLBase.VarString _ 63 = convertPV PersistByteString+ go MySQLBase.String _ 63 = convertPV PersistByteString+ go MySQLBase.VarChar _ _ = convertPV PersistText+ go MySQLBase.VarString _ _ = convertPV PersistText+ go MySQLBase.String _ _ = convertPV PersistText+ go MySQLBase.Blob _ 63 = convertPV PersistByteString+ go MySQLBase.TinyBlob _ 63 = convertPV PersistByteString+ go MySQLBase.MediumBlob _ 63 = convertPV PersistByteString+ go MySQLBase.LongBlob _ 63 = convertPV PersistByteString+ go MySQLBase.Blob _ _ = convertPV PersistText+ go MySQLBase.TinyBlob _ _ = convertPV PersistText+ go MySQLBase.MediumBlob _ _ = convertPV PersistText+ go MySQLBase.LongBlob _ _ = convertPV PersistText+ -- Time-related+ go MySQLBase.Time _ _ = convertPV PersistTimeOfDay+ go MySQLBase.DateTime _ _ = convertPV PersistUTCTime+ go MySQLBase.Timestamp _ _ = convertPV PersistUTCTime+ go MySQLBase.Date _ _ = convertPV PersistDay+ go MySQLBase.NewDate _ _ = convertPV PersistDay+ go MySQLBase.Year _ _ = convertPV PersistDay+ -- Null+ go MySQLBase.Null _ _ = \_ _ -> PersistNull+ -- Controversial conversions+ go MySQLBase.Set _ _ = convertPV PersistText+ go MySQLBase.Enum _ _ = convertPV PersistText+ -- Conversion using PersistLiteral+ go MySQLBase.Geometry _ _ = \_ m ->+ case m of+ Just g -> PersistLiteral g+ Nothing -> error "Unexpected null in database specific value"+ go MySQLBase.Json _ _ = convertPV PersistByteString+ -- Unsupported+ go other _ _ =+ error $+ "MySQL.getGetter: type "+ ++ show other+ ++ " not supported."++----------------------------------------------------------------------++-- | Create the migration plan for the given 'PersistEntity'+-- @val@.+migrate'+ :: MySQL.ConnectInfo+ -> [EntityDef]+ -> (Text -> IO Statement)+ -> EntityDef+ -> IO (Either [Text] CautiousMigration)+migrate' connectInfo allDefs getter val = do+ let+ name = getEntityDBName val+ let+ (newcols, udefs, fdefs) = mysqlMkColumns allDefs val+ old <- getColumns connectInfo getter val newcols+ let+ udspair = map udToPair udefs+ case ([], old, partitionEithers old) of+ -- Nothing found, create everything+ ([], [], _) -> do+ let+ uniques = do+ (uname, ucols) <- udspair+ pure $+ AlterTable name $+ AddUniqueConstraint uname $+ map (findTypeAndMaxLen name) ucols++ let+ foreigns = do+ Column{cName = cname, cReference = Just cRef} <- newcols+ let+ refConstraintName = crConstraintName cRef+ let+ refTblName = crTableName cRef+ let+ refTarget =+ addReference allDefs refConstraintName refTblName cname (crFieldCascade cRef)++ guard $ Just cname /= fmap fieldDB (getEntityIdField val)+ return $ AlterColumn name refTarget++ let+ foreignsAlt =+ map+ ( \fdef ->+ let+ (childfields, parentfields) =+ unzip $+ map (\((_, b), (_, d)) -> (b, d)) $+ foreignFields fdef+ in+ AlterColumn+ name+ ( AddReference+ (foreignRefTableDBName fdef)+ (foreignConstraintNameDBName fdef)+ childfields+ parentfields+ (foreignFieldCascade fdef)+ )+ )+ fdefs++ return $+ Right $+ map showAlterDb $+ (addTable newcols val) : uniques ++ foreigns ++ foreignsAlt++ -- No errors and something found, migrate+ (_, _, ([], old')) -> do+ let+ excludeForeignKeys (xs, ys) =+ ( map+ ( \c ->+ case cReference c of+ Just ColumnReference{crConstraintName = fk} ->+ case find (\f -> fk == foreignConstraintNameDBName f) fdefs of+ Just _ -> c{cReference = Nothing}+ Nothing -> c+ Nothing -> c+ )+ xs+ , ys+ )+ (acs, ats) =+ getAlters+ allDefs+ val+ (newcols, udspair)+ $ excludeForeignKeys+ $ partitionEithers+ $ old'+ acs' =+ map (AlterColumn name) acs+ ats' =+ map (AlterTable name) ats+ return $+ Right $+ map showAlterDb $+ acs' ++ ats'++ -- Errors+ (_, _, (errs, _)) ->+ return $ Left errs+ where+ findTypeAndMaxLen tblName col =+ let+ (col', ty) = findTypeOfColumn allDefs tblName col+ (_, ml) = findMaxLenOfColumn allDefs tblName col+ in+ (col', ty, ml)++addTable :: [Column] -> EntityDef -> AlterDB+addTable cols entity =+ AddTable $+ concat+ -- Lower case e: see Database.Persist.Sql.Migration+ [ "CREATe TABLE "+ , escapeE name+ , "("+ , idtxt+ , if null nonIdCols then [] else ","+ , intercalate "," $ map showCreateColumn nonIdCols+ , ")"+ ]+ where+ nonIdCols =+ filter (\c -> Just (cName c) /= fmap fieldDB (getEntityIdField entity)) cols+ name =+ getEntityDBName entity+ idtxt =+ case getEntityId entity of+ EntityIdNaturalKey pdef ->+ concat+ [ " PRIMARY KEY ("+ , intercalate "," $+ map (escapeF . fieldDB) $+ NEL.toList $+ compositeFields pdef+ , ")"+ ]+ EntityIdField idField ->+ let+ defText =+ defaultAttribute $ fieldAttrs idField+ sType =+ fieldSqlType idField+ autoIncrementText =+ case (sType, defText) of+ (SqlInt64, Nothing) -> " AUTO_INCREMENT"+ _ -> ""+ maxlen =+ findMaxLenOfField idField+ in+ concat+ [ escapeF $ fieldDB idField+ , " " <> showSqlType sType maxlen False+ , " NOT NULL"+ , autoIncrementText+ , " PRIMARY KEY"+ , case defText of+ Nothing ->+ ""+ Just def ->+ concat+ [ " DEFAULT ("+ , T.unpack def+ , ")"+ ]+ ]++-- | Find out the type of a column.+findTypeOfColumn+ :: [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType)+findTypeOfColumn allDefs name col =+ maybe+ ( error $+ "Could not find type of column "+ ++ show col+ ++ " on table "+ ++ show name+ ++ " (allDefs = "+ ++ show allDefs+ ++ ")"+ )+ ((,) col)+ $ do+ entDef <- find ((== name) . getEntityDBName) allDefs+ fieldDef <- find ((== col) . fieldDB) (getEntityFieldsDatabase entDef)+ return (fieldType fieldDef)++-- | Find out the maxlen of a column (default to 200)+findMaxLenOfColumn+ :: [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, Integer)+findMaxLenOfColumn allDefs name col =+ maybe+ (col, 200)+ ((,) col)+ $ do+ entDef <- find ((== name) . getEntityDBName) allDefs+ fieldDef <- find ((== col) . fieldDB) (getEntityFieldsDatabase entDef)+ findMaxLenOfField fieldDef++-- | Find out the maxlen of a field+findMaxLenOfField :: FieldDef -> Maybe Integer+findMaxLenOfField fieldDef =+ listToMaybe+ . mapMaybe+ ( \case+ FieldAttrMaxlen x -> Just x+ _ -> Nothing+ )+ . fieldAttrs+ $ fieldDef++-- | Helper for 'AddReference' that finds out the which primary key columns to reference.+addReference+ :: [EntityDef]+ -- ^ List of all known 'EntityDef's.+ -> ConstraintNameDB+ -- ^ Foreign key name+ -> EntityNameDB+ -- ^ Referenced table name+ -> FieldNameDB+ -- ^ Column name+ -> FieldCascade+ -> AlterColumn+addReference allDefs fkeyname reftable cname fc =+ AddReference reftable fkeyname [cname] referencedColumns fc+ where+ errorMessage =+ error $+ "Could not find ID of entity "+ ++ show reftable+ ++ " (allDefs = "+ ++ show allDefs+ ++ ")"+ referencedColumns =+ fromMaybe errorMessage $ do+ entDef <- find ((== reftable) . getEntityDBName) allDefs+ return $ map fieldDB $ NEL.toList $ getEntityKeyFields entDef++data AlterColumn+ = Change Column+ | Add' Column+ | Drop Column+ | Default Column String+ | NoDefault Column+ | Gen Column SqlType (Maybe Integer) String+ | NoGen Column SqlType (Maybe Integer)+ | Update' Column String+ | -- | See the definition of the 'showAlter' function to see how these fields are used.+ AddReference+ EntityNameDB -- Referenced table+ ConstraintNameDB -- Foreign key name+ [FieldNameDB] -- Referencing columns+ [FieldNameDB] -- Referenced columns+ FieldCascade+ | DropReference ConstraintNameDB+ deriving (Show)++data AlterTable+ = AddUniqueConstraint ConstraintNameDB [(FieldNameDB, FieldType, Integer)]+ | DropUniqueConstraint ConstraintNameDB+ deriving (Show)++data AlterDB+ = AddTable String+ | AlterColumn EntityNameDB AlterColumn+ | AlterTable EntityNameDB AlterTable+ deriving (Show)++udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])+udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud)++----------------------------------------------------------------------++-- | Returns all of the 'Column'@s@ in the given table currently+-- in the database.+getColumns+ :: (HasCallStack)+ => MySQL.ConnectInfo+ -> (Text -> IO Statement)+ -> EntityDef+ -> [Column]+ -> IO [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]+getColumns connectInfo getter def cols = do+ -- Find out all columns.+ stmtClmns <-+ getter $+ T.concat+ [ "SELECT COLUMN_NAME, "+ , "IS_NULLABLE, "+ , "DATA_TYPE, "+ , "COLUMN_TYPE, "+ , "CHARACTER_MAXIMUM_LENGTH, "+ , "NUMERIC_PRECISION, "+ , "NUMERIC_SCALE, "+ , "COLUMN_DEFAULT, "+ , "GENERATION_EXPRESSION "+ , "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 $+ 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 (cs ++ us)+ where+ refMap = Map.fromList $ foldl ref [] cols+ where+ ref rs c = case cReference c of+ Nothing -> rs+ (Just r) -> (unFieldNameDB $ cName c, r) : rs+ vals =+ [ PersistText $ pack $ MySQL.connectDatabase connectInfo+ , PersistText $ unEntityNameDB $ getEntityDBName def+ -- , PersistText $ unDBName $ fieldDB $ getEntityId def+ ]++ helperClmns = CL.mapM getIt .| CL.consume+ where+ getIt row =+ fmap (either Left (Right . Left))+ . liftIO+ . getColumn connectInfo getter (getEntityDBName def) row+ $ ref+ where+ ref = case row of+ (PersistText cname : _) -> (Map.lookup cname refMap)+ _ -> Nothing++ helperCntrs = do+ let+ check+ [ PersistText cntrName+ , PersistText clmnName+ ] = return (cntrName, clmnName)+ check other = fail $ "helperCntrs: unexpected " ++ show other+ rows <- mapM check =<< CL.consume+ return+ $ map+ (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd)))+ $ groupBy ((==) `on` fst) rows++-- | Get the information about a column in a table.+getColumn+ :: (HasCallStack)+ => MySQL.ConnectInfo+ -> (Text -> IO Statement)+ -> EntityNameDB+ -> [PersistValue]+ -> Maybe ColumnReference+ -> IO (Either Text Column)+getColumn+ connectInfo+ getter+ tname+ [ PersistText cname+ , PersistText null_+ , PersistText dataType+ , PersistText colType+ , colMaxLen+ , colPrecision+ , colScale+ , default'+ , generated+ ]+ cRef =+ fmap (either (Left . pack) Right) $+ runExceptT $ do+ -- Default value+ default_ <-+ case default' of+ PersistNull -> return Nothing+ PersistText t -> return (Just t)+ PersistByteString bs ->+ case T.decodeUtf8' bs of+ Left exc ->+ fail $+ "Invalid default column: "+ ++ show default'+ ++ " (error: "+ ++ show exc+ ++ ")"+ Right t ->+ return (Just t)+ _ ->+ fail $ "Invalid default column: " ++ show default'++ generated_ <-+ case generated of+ PersistNull -> return Nothing+ PersistText "" -> return Nothing+ PersistByteString "" -> return Nothing+ PersistText t -> return (Just t)+ PersistByteString bs ->+ case T.decodeUtf8' bs of+ Left exc ->+ fail $+ "Invalid generated column: "+ ++ show generated+ ++ " (error: "+ ++ show exc+ ++ ")"+ Right t ->+ return (Just t)+ _ ->+ fail $ "Invalid generated column: " ++ show generated++ ref <- getRef (crConstraintName <$> cRef)++ let+ colMaxLen' =+ case colMaxLen of+ PersistInt64 l -> Just (fromIntegral l)+ _ -> Nothing+ ci =+ ColumnInfo+ { ciColumnType = colType+ , ciMaxLength = colMaxLen'+ , ciNumericPrecision = colPrecision+ , ciNumericScale = colScale+ }++ (typ, maxLen) <- parseColumnType dataType ci++ -- Okay!+ return+ Column+ { cName = FieldNameDB cname+ , cNull = null_ == "YES"+ , cSqlType = typ+ , cDefault = default_+ , cGenerated = generated_+ , cDefaultConstraintName = Nothing+ , cMaxLen = maxLen+ , cReference = ref+ }+ where+ getRef Nothing = return Nothing+ getRef (Just refName') = do+ -- Foreign key (if any)+ stmt <-+ lift . getter $+ T.concat+ [ "SELECT KCU.REFERENCED_TABLE_NAME, "+ , "KCU.CONSTRAINT_NAME, "+ , "KCU.ORDINAL_POSITION, "+ , "DELETE_RULE, "+ , "UPDATE_RULE "+ , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU "+ , "INNER JOIN INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC "+ , " USING (CONSTRAINT_SCHEMA, CONSTRAINT_NAME) "+ , "WHERE KCU.TABLE_SCHEMA = ? "+ , "AND KCU.TABLE_NAME = ? "+ , "AND KCU.COLUMN_NAME = ? "+ , "AND KCU.REFERENCED_TABLE_SCHEMA = ? "+ , "AND KCU.CONSTRAINT_NAME = ? "+ , "ORDER BY KCU.CONSTRAINT_NAME, "+ , "KCU.COLUMN_NAME"+ ]+ let+ vars =+ [ PersistText $ pack $ MySQL.connectDatabase connectInfo+ , PersistText $ unEntityNameDB tname+ , PersistText cname+ , PersistText $ pack $ MySQL.connectDatabase connectInfo+ , PersistText $ unConstraintNameDB refName'+ ]+ parseCascadeAction txt =+ case txt of+ "RESTRICT" -> Just Restrict+ "CASCADE" -> Just Cascade+ "SET NULL" -> Just SetNull+ "SET DEFAULT" -> Just SetDefault+ "NO ACTION" -> Just NoAction+ _ ->+ error $ "Unexpected value in parseCascadeAction: " <> show txt++ cntrs <-+ liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume)+ pure $ case cntrs of+ [] ->+ Nothing+ [ [ PersistText tab+ , PersistText ref+ , PersistInt64 pos+ , PersistText onDel+ , PersistText onUpd+ ]+ ] ->+ if pos == 1+ then+ Just $+ ColumnReference+ (EntityNameDB tab)+ (ConstraintNameDB ref)+ FieldCascade+ { fcOnUpdate = parseCascadeAction onUpd+ , fcOnDelete = parseCascadeAction onDel+ }+ else Nothing+ xs ->+ error $+ mconcat+ [ "MySQL.getColumn/getRef: error fetching constraints. Expected a single result for foreign key query for table: "+ , T.unpack (unEntityNameDB tname)+ , " and column: "+ , T.unpack cname+ , " but got: "+ , show xs+ ]+getColumn _ _ _ x _ =+ return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x++-- | Extra column information from MySQL schema+data ColumnInfo = ColumnInfo+ { ciColumnType :: Text+ , ciMaxLength :: Maybe Integer+ , ciNumericPrecision :: PersistValue+ , ciNumericScale :: PersistValue+ }++-- | Parse the type of column as returned by MySQL's+-- @INFORMATION_SCHEMA@ tables.+parseColumnType+ :: Text -> ColumnInfo -> ExceptT String IO (SqlType, Maybe Integer)+-- Ints+-- The display width is deprecated and being removed in MySQL 8.X+-- with [an exception of tinyint(1) which is used for boolean values](https://dev.mysql.com/doc/relnotes/mysql/8.0/en/news-8-0-19.html#mysqld-8-0-19-deprecation-removal).+-- To be consistent with earlier versions, which do report it, accept either+-- the bare type in `ciColumnType ci`, or the type adorned with the expected+-- value for the display width (ie the defaults for int and bigint, or the+-- value explicitly set in `showSqlType` for SqlBool).+--+parseColumnType "tinyint" ci+ | ciColumnType ci == "tinyint(1)" = return (SqlBool, Nothing)+ | otherwise = return (SqlOther "tinyint", Nothing)+parseColumnType "int" ci+ | ciColumnType ci == "int" || ciColumnType ci == "int(11)" =+ return (SqlInt32, Nothing)+parseColumnType "bigint" ci+ | ciColumnType ci == "bigint" || ciColumnType ci == "bigint(20)" =+ return (SqlInt64, Nothing)+-- Double+parseColumnType x@("double") ci | ciColumnType ci == x = return (SqlReal, Nothing)+parseColumnType "decimal" ci =+ case (ciNumericPrecision ci, ciNumericScale ci) of+ (PersistInt64 p, PersistInt64 s) ->+ return (SqlNumeric (fromIntegral p) (fromIntegral s), Nothing)+ _ ->+ fail "missing DECIMAL precision in DB schema"+-- Text+parseColumnType "varchar" ci = return (SqlString, ciMaxLength ci)+parseColumnType "text" _ = return (SqlString, Nothing)+-- ByteString+parseColumnType "varbinary" ci = return (SqlBlob, ciMaxLength ci)+parseColumnType "blob" _ = return (SqlBlob, Nothing)+-- Time-related+parseColumnType "time" _ = return (SqlTime, Nothing)+parseColumnType "datetime" _ = return (SqlDayTime, Nothing)+parseColumnType "date" _ = return (SqlDay, Nothing)+parseColumnType _ ci =+ return (SqlOther (ciColumnType ci), Nothing)++----------------------------------------------------------------------++-- | @getAlters allDefs tblName new old@ finds out what needs to+-- be changed from @old@ to become @new@.+getAlters+ :: [EntityDef]+ -> EntityDef+ -> ([Column], [(ConstraintNameDB, [FieldNameDB])])+ -> ([Column], [(ConstraintNameDB, [FieldNameDB])])+ -> ([AlterColumn], [AlterTable])+getAlters allDefs edef (c1, u1) (c2, u2) =+ (getAltersC c1 c2, getAltersU u1 u2)+ where+ tblName = getEntityDBName edef+ getAltersC [] old = concatMap dropColumn old+ getAltersC (new : news) old =+ let+ (alters, old') = findAlters edef allDefs new old+ in+ alters ++ getAltersC news old'++ dropColumn col =+ [DropReference (crConstraintName cr) | Just cr <- [cReference col]]+ ++ [Drop col]++ getAltersU [] old = map (DropUniqueConstraint . fst) old+ getAltersU ((name, cols) : news) old =+ case lookup name old of+ Nothing ->+ AddUniqueConstraint name (map findTypeAndMaxLen cols)+ : getAltersU news old+ Just ocols ->+ let+ old' = filter (\(x, _) -> x /= name) old+ in+ if sort cols == ocols+ then getAltersU news old'+ else+ DropUniqueConstraint name+ : AddUniqueConstraint name (map findTypeAndMaxLen cols)+ : getAltersU news old'+ where+ findTypeAndMaxLen col =+ let+ (col', ty) = findTypeOfColumn allDefs tblName col+ (_, ml) = findMaxLenOfColumn allDefs tblName col+ in+ (col', ty, ml)++-- | @findAlters x y newColumn oldColumns@ finds out what needs to be+-- changed in the columns @oldColumns@ for @newColumn@ to be+-- supported.+findAlters+ :: EntityDef+ -> [EntityDef]+ -> Column+ -> [Column]+ -> ([AlterColumn], [Column])+findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName maxLen ref) cols =+ case filter ((name ==) . cName) cols of+ -- new fkey that didn't exist before+ [] ->+ case ref of+ Nothing -> ([Add' col], cols)+ Just cr ->+ let+ tname = crTableName cr+ cname = crConstraintName cr+ cnstr = [addReference allDefs cname tname name (crFieldCascade cr)]+ in+ (Add' col : cnstr, cols)+ Column _ isNull' type_' def' gen' _defConstraintName' maxLen' ref' : _ ->+ let+ -- Foreign key+ refDrop =+ case (ref == ref', ref') of+ (False, Just ColumnReference{crConstraintName = cname}) ->+ [DropReference cname]+ _ ->+ []+ refAdd =+ case (ref == ref', ref) of+ ( False+ , Just+ ColumnReference+ { crTableName = tname+ , crConstraintName = cname+ , crFieldCascade = cfc+ }+ )+ | tname /= getEntityDBName edef+ , Just idField <- getEntityIdField edef+ , unConstraintNameDB cname /= unFieldNameDB (fieldDB idField) ->+ [addReference allDefs cname tname name cfc]+ _ -> []+ -- Type and nullability+ modType+ | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False+ && isNull == isNull' =+ []+ | otherwise = [Change col]++ -- Default value+ -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields+ modDef =+ if def == def'+ then []+ else case def of+ Nothing -> [NoDefault col]+ Just s ->+ if T.toUpper s == "NULL"+ then []+ else [Default col $ T.unpack s]++ -- Does the generated value need to change?+ modGen =+ if gen == gen'+ then []+ else case gen of+ Nothing -> [NoGen col type_ maxLen]+ Just genExpr -> [Gen col type_ maxLen $ T.unpack genExpr]+ in+ ( refDrop ++ modType ++ modDef ++ modGen ++ refAdd+ , filter ((name /=) . cName) cols+ )+ where+ ciEquals x y = T.toCaseFold (T.pack x) == T.toCaseFold (T.pack y)++----------------------------------------------------------------------++-- | Prints the part of a @CREATE TABLE@ statement about a given+-- column.+showCreateColumn :: Column -> String+showCreateColumn = showColumn False++showAlterColumn :: Column -> String+showAlterColumn = showColumn True++showColumn :: Bool -> Column -> String+showColumn showReferences (Column n nu t def gen _defConstraintName maxLen ref) =+ concat+ [ escapeF n+ , " "+ , showSqlType t maxLen True+ , " "+ , case gen of+ Nothing -> ""+ Just genExpr ->+ if T.toUpper genExpr == "NULL"+ then ""+ else " GENERATED ALWAYS AS (" <> T.unpack genExpr <> ") STORED "+ , if nu then "NULL" else "NOT NULL"+ , case def of+ Nothing -> ""+ Just s ->+ -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields+ if T.toUpper s == "NULL"+ then ""+ else " DEFAULT " ++ T.unpack s+ , case ref of+ Just cRef+ | showReferences ->+ mconcat+ [ " REFERENCES "+ , escapeE (crTableName cRef)+ , " "+ , T.unpack (renderFieldCascade (crFieldCascade cRef))+ ]+ _ ->+ ""+ ]++-- | Renders an 'SqlType' in MySQL's format.+showSqlType+ :: SqlType+ -> Maybe Integer+ -- ^ @maxlen@+ -> Bool+ -- ^ include character set information?+ -> String+showSqlType SqlBlob Nothing _ = "BLOB"+showSqlType SqlBlob (Just i) _ = "VARBINARY(" ++ show i ++ ")"+-- While integer widths are deprecated in MySQL 8.0, "tinyint(1)" remains as an exception.+-- cf. https://dev.mysql.com/doc/relnotes/mysql/8.0/en/news-8-0-19.html#mysqld-8-0-19-deprecation-removal+showSqlType SqlBool _ _ = "TINYINT(1)"+showSqlType SqlDay _ _ = "DATE"+showSqlType SqlDayTime _ _ = "DATETIME"+showSqlType SqlInt32 _ _ = "INT"+showSqlType SqlInt64 _ _ = "BIGINT"+showSqlType SqlReal _ _ = "DOUBLE"+showSqlType (SqlNumeric s prec) _ _ = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")"+showSqlType SqlString Nothing True = "TEXT CHARACTER SET utf8mb4"+showSqlType SqlString Nothing False = "TEXT"+showSqlType SqlString (Just i) True = "VARCHAR(" ++ show i ++ ") CHARACTER SET utf8mb4"+showSqlType SqlString (Just i) False = "VARCHAR(" ++ show i ++ ")"+showSqlType SqlTime _ _ = "TIME"+showSqlType (SqlOther t) _ _ = T.unpack t++-- | Render an action that must be done on the database.+showAlterDb :: AlterDB -> (Bool, Text)+showAlterDb (AddTable s) = (False, pack s)+showAlterDb (AlterColumn t ac) =+ (isUnsafe ac, pack $ showAlter t ac)+ where+ isUnsafe Drop{} = True+ isUnsafe _ = False+showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at)++-- | Render an action that must be done on a table.+showAlterTable :: EntityNameDB -> AlterTable -> String+showAlterTable table (AddUniqueConstraint cname cols) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " ADD CONSTRAINT "+ , escapeC cname+ , " UNIQUE("+ , intercalate "," $ map escapeDBName' cols+ , ")"+ ]+ where+ escapeDBName' (name, (FTTypeCon _ "Text"), maxlen) = escapeF name ++ "(" ++ show maxlen ++ ")"+ escapeDBName' (name, (FTTypeCon _ "String"), maxlen) = escapeF name ++ "(" ++ show maxlen ++ ")"+ escapeDBName' (name, (FTTypeCon _ "ByteString"), maxlen) = escapeF name ++ "(" ++ show maxlen ++ ")"+ escapeDBName' (name, _, _) = escapeF name+showAlterTable table (DropUniqueConstraint cname) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " DROP INDEX "+ , escapeC cname+ ]++-- | Render an action that must be done on a column.+showAlter :: EntityNameDB -> AlterColumn -> String+showAlter table (Change (Column n nu t def gen defConstraintName maxLen _ref)) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " CHANGE "+ , escapeF n+ , " "+ , showAlterColumn (Column n nu t def gen defConstraintName maxLen Nothing)+ ]+showAlter table (Add' col) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " ADD COLUMN "+ , showAlterColumn col+ ]+showAlter table (Drop c) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " DROP COLUMN "+ , escapeF (cName c)+ ]+showAlter table (Default c s) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " ALTER COLUMN "+ , escapeF (cName c)+ , " SET DEFAULT "+ , s+ ]+showAlter table (NoDefault c) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " ALTER COLUMN "+ , escapeF (cName c)+ , " DROP DEFAULT"+ ]+showAlter table (Gen col typ len expr) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " MODIFY COLUMN "+ , escapeF (cName col)+ , " "+ , showSqlType typ len True+ , " GENERATED ALWAYS AS ("+ , expr+ , ") STORED"+ ]+showAlter table (NoGen col typ len) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " MODIFY COLUMN "+ , escapeF (cName col)+ , " "+ , showSqlType typ len True+ ]+showAlter table (Update' c s) =+ concat+ [ "UPDATE "+ , escapeE table+ , " SET "+ , escapeF (cName c)+ , "="+ , s+ , " WHERE "+ , escapeF (cName c)+ , " IS NULL"+ ]+showAlter table (AddReference reftable fkeyname t2 id2 fc) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " ADD CONSTRAINT "+ , escapeC fkeyname+ , " FOREIGN KEY("+ , intercalate "," $ map escapeF t2+ , ") REFERENCES "+ , escapeE reftable+ , "("+ , intercalate "," $ map escapeF id2+ , ") "+ , T.unpack $ renderFieldCascade fc+ ]+showAlter table (DropReference cname) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " DROP FOREIGN KEY "+ , escapeC cname+ ]++----------------------------------------------------------------------++escapeC :: ConstraintNameDB -> String+escapeC = escapeWith (escapeDBName . T.unpack)++escapeE :: EntityNameDB -> String+escapeE = escapeWith (escapeDBName . T.unpack)++escapeF :: FieldNameDB -> String+escapeF = escapeWith (escapeDBName . T.unpack)++escapeET :: EntityNameDB -> Text+escapeET = escapeWith (T.pack . escapeDBName . T.unpack)++escapeFT :: FieldNameDB -> Text+escapeFT = escapeWith (T.pack . escapeDBName . T.unpack)++-- | Escape a database name to be included on a query.+escapeDBName :: String -> String+escapeDBName str = '`' : go str+ where+ go ('`' : xs) = '`' : '`' : go xs+ go (x : xs) = x : go xs+ go "" = "`"++-- | Information required to connect to a MySQL database+-- using @persistent@'s generic facilities. These values are the+-- same that are given to 'withMySQLPool'.+data MySQLConf = MySQLConf+ { myConnInfo :: MySQL.ConnectInfo+ -- ^ The connection information.+ , myPoolSize :: Int+ -- ^ How many connections should be held on the connection pool.+ }+ deriving (Show)++instance FromJSON MySQLConf where+ parseJSON v = modifyFailure ("Persistent: error loading MySQL conf: " ++) $+ flip (withObject "MySQLConf") v $ \o -> do+ database <- o .: "database"+ host <- o .: "host"+ port <- o .: "port"+ path <- o .:? "path"+ user <- o .: "user"+ password <- o .: "password"+ pool <- o .: "poolsize"+ let+ ci =+ MySQL.defaultConnectInfo+ { MySQL.connectHost = host+ , MySQL.connectPort = port+ , MySQL.connectPath = case path of+ Just p -> p+ Nothing -> MySQL.connectPath MySQL.defaultConnectInfo+ , MySQL.connectUser = user+ , MySQL.connectPassword = password+ , MySQL.connectDatabase = database+ }+ return $ MySQLConf ci pool++instance PersistConfig MySQLConf where+ type PersistConfigBackend MySQLConf = SqlPersistT++ type PersistConfigPool MySQLConf = ConnectionPool++ createPoolConfig (MySQLConf cs size) = runNoLoggingT $ createMySQLPool cs size -- FIXME++ runPool _ = runSqlPool++ loadConfig = parseJSON++ applyEnv conf = do+ env <- getEnvironment+ let+ maybeEnv old var = maybe old id $ lookup ("MYSQL_" ++ var) env+ return+ conf+ { myConnInfo =+ case myConnInfo conf of+ MySQL.ConnectInfo+ { MySQL.connectHost = host+ , MySQL.connectPort = port+ , MySQL.connectPath = path+ , MySQL.connectUser = user+ , MySQL.connectPassword = password+ , MySQL.connectDatabase = database+ } ->+ (myConnInfo conf)+ { MySQL.connectHost = maybeEnv host "HOST"+ , MySQL.connectPort = read $ maybeEnv (show port) "PORT"+ , MySQL.connectPath = maybeEnv path "PATH"+ , MySQL.connectUser = maybeEnv user "USER"+ , MySQL.connectPassword = maybeEnv password "PASSWORD"+ , MySQL.connectDatabase = maybeEnv database "DATABASE"+ }+ }++mockMigrate+ :: MySQL.ConnectInfo+ -> [EntityDef]+ -> (Text -> IO Statement)+ -> EntityDef+ -> IO (Either [Text] [(Bool, Text)])+mockMigrate _connectInfo allDefs _getter val = do+ let+ name = getEntityDBName val+ let+ (newcols, udefs, fdefs) = mysqlMkColumns allDefs val+ let+ udspair = map udToPair udefs+ case () of+ -- Nothing found, create everything+ () -> do+ let+ uniques = flip concatMap udspair $ \(uname, ucols) ->+ [ AlterTable name $+ AddUniqueConstraint uname $+ map (findTypeAndMaxLen name) ucols+ ]+ let+ foreigns = do+ Column+ { cName = cname+ , cReference =+ Just+ ColumnReference+ { crTableName = refTable+ , crConstraintName = refConstr+ , crFieldCascade = cfc+ }+ } <-+ newcols+ return $ AlterColumn name (addReference allDefs refConstr refTable cname cfc)++ let+ foreignsAlt =+ map+ ( \fdef ->+ let+ (childfields, parentfields) = unzip (map (\((_, b), (_, d)) -> (b, d)) (foreignFields fdef))+ in+ AlterColumn+ name+ ( AddReference+ (foreignRefTableDBName fdef)+ (foreignConstraintNameDBName fdef)+ childfields+ parentfields+ (foreignFieldCascade fdef)+ )+ )+ fdefs++ return $+ Right $+ map showAlterDb $+ (addTable newcols val) : uniques ++ foreigns ++ foreignsAlt+ where+ findTypeAndMaxLen tblName col =+ let+ (col', ty) = findTypeOfColumn allDefs tblName col+ (_, ml) = findMaxLenOfColumn allDefs tblName col+ in+ (col', ty, ml)++-- | Mock a migration even when the database is not present.+-- This function will mock the migration for a database even when+-- the actual database isn't already present in the system.+mockMigration :: Migration -> IO ()+mockMigration mig = do+ smap <- newIORef mempty+ let+ sqlbackend =+ mkSqlBackend+ MkSqlBackendArgs+ { connPrepare = \_ -> do+ return+ Statement+ { stmtFinalize = return ()+ , stmtReset = return ()+ , stmtExecute = undefined+ , stmtQuery = \_ -> return $ return ()+ }+ , connInsertSql = undefined+ , connStmtMap = smap+ , connClose = undefined+ , connMigrateSql = mockMigrate undefined+ , connBegin = undefined+ , connCommit = undefined+ , connRollback = undefined+ , connEscapeFieldName = T.pack . escapeDBName . T.unpack . unFieldNameDB+ , connEscapeTableName =+ T.pack . escapeDBName . T.unpack . unEntityNameDB . getEntityDBName+ , connEscapeRawName = T.pack . escapeDBName . T.unpack+ , connNoLimit = undefined+ , connRDBMS = undefined+ , connLimitOffset = undefined+ , connLogFunc = undefined+ }+ result = runReaderT . runWriterT . runWriterT $ mig+ resp <- result sqlbackend+ mapM_ T.putStrLn $ map snd $ snd resp++-- | 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+ , MonadIO m+ , PersistStore backend+ , BackendCompatible SqlBackend backend+ )+ => record+ -> [Update record]+ -> ReaderT backend m ()+insertOnDuplicateKeyUpdate record =+ 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 this library.+--+-- @since 2.8.0+data HandleUpdateCollision record where+ -- | Copy the field directly from the 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+ -> HandleUpdateCollision record++-- | 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)+ -> 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 'HandleUpdateCollision' type is useful for the+-- 'insertManyOnDuplicateKeyUpdate' function.+--+-- @since 2.6.2+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 'HandleUpdateCollision' type is useful for the+-- 'insertManyOnDuplicateKeyUpdate' function.+--+-- @since 2.6.2+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.+--+-- The second parameter is a list of fields to copy from the original value.+-- 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 'HandleUpdateCollision' usage__+--+-- 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:+--+-- @+-- 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 database, 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+ :: 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+ -> [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 =+ uncurry rawExecute $+ mkBulkInsertQuery records fieldValues updates++-- | 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+ :: (PersistEntity record)+ => [record]+ -- ^ A list of the records you want to insert, or update+ -> [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+ CopyField rec -> Right (fieldDbToText (persistFieldDef rec))+ CopyUnlessEq rec val -> Left (fieldDbToText (persistFieldDef rec), toPersistValue val)+ (fieldsToMaybeCopy, updateFieldNames) = partitionEithers $ map mfieldDef fieldValues+ fieldDbToText = T.pack . escapeF . fieldDB+ entityDef' = entityDef records+ firstField = case entityFieldNames of+ [] -> error "The entity you're trying to insert does not have any fields."+ (field : _) -> field+ entityFieldNames = map fieldDbToText (getEntityFieldsDatabase entityDef')+ tableName = T.pack . escapeE . getEntityDBName $ entityDef'+ copyUnlessValues = map snd fieldsToMaybeCopy+ recordValues = concatMap (map toPersistValue . toPersistFields) records+ recordPlaceholders =+ Util.commaSeparated $+ map+ (Util.parenWrapped . Util.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 (Util.mkUpdateText' (pack . escapeF) id) updates+ updsValues = map (\(Update _ val _) -> toPersistValue val) updates+ updateText = case fieldSets <> upds <> condFieldSets of+ [] -> T.concat [firstField, "=", firstField]+ xs -> Util.commaSeparated xs+ q =+ T.concat+ [ "INSERT INTO "+ , tableName+ , " ("+ , Util.commaSeparated entityFieldNames+ , ") "+ , " VALUES "+ , recordPlaceholders+ , " ON DUPLICATE KEY UPDATE "+ , updateText+ ]++putManySql :: EntityDef -> Int -> Text+putManySql ent n = putManySql' fields ent n+ where+ fields = getEntityFields ent++repsertManySql :: EntityDef -> Int -> Text+repsertManySql ent n = putManySql' fields ent n+ where+ fields = NEL.toList $ keyAndEntityFields ent++putManySql' :: [FieldDef] -> EntityDef -> Int -> Text+putManySql' (filter isFieldNotGenerated -> fields) ent n = q+ where+ fieldDbToText = (T.pack . escapeF) . fieldDB+ mkAssignment f = T.concat [f, "=VALUES(", f, ")"]++ table = (T.pack . escapeE) . getEntityDBName $ ent+ columns = Util.commaSeparated $ map fieldDbToText fields+ placeholders = map (const "?") fields+ updates = map (mkAssignment . fieldDbToText) fields++ q =+ T.concat+ [ "INSERT INTO "+ , table+ , Util.parenWrapped columns+ , " VALUES "+ , Util.commaSeparated+ . replicate n+ . Util.parenWrapped+ . Util.commaSeparated+ $ placeholders+ , " ON DUPLICATE KEY UPDATE "+ , Util.commaSeparated updates+ ]++mysqlMkColumns+ :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])+mysqlMkColumns allDefs t = mkColumns allDefs t emptyBackendSpecificOverrides
persistent-mysql.cabal view
@@ -1,50 +1,95 @@-name: persistent-mysql-version: 2.6.2.1-license: MIT-license-file: LICENSE-author: Felipe Lessa <felipe.lessa@gmail.com>, Michael Snoyman-maintainer: Felipe Lessa <felipe.lessa@gmail.com>-synopsis: Backend for the persistent library using MySQL database server.-category: Database, Yesod-stability: Stable-cabal-version: >= 1.6-build-type: Simple-homepage: http://www.yesodweb.com/book/persistent-bug-reports: https://github.com/yesodweb/persistent/issues+name: persistent-mysql+version: 2.13.1.6+license: MIT+license-file: LICENSE+author: Felipe Lessa <felipe.lessa@gmail.com>, Michael Snoyman+maintainer: Felipe Lessa <felipe.lessa@gmail.com>+synopsis:+ Backend for the persistent library using MySQL database server.++category: Database, Yesod+stability: Stable+cabal-version: >=1.10+build-type: Simple+homepage: http://www.yesodweb.com/book/persistent+bug-reports: https://github.com/yesodweb/persistent/issues description:- This package contains a backend for persistent using the- MySQL database server. Internally it uses the @mysql-simple@- and @mysql@ packages in order to access the database.- .- This package supports only MySQL 5.1 and above. However, it- has been tested only on MySQL 5.5.- Only the InnoDB storage engine is officially supported.- .- Known problems:- .- * This package does not support statements inside other- statements.+ This package contains a backend for persistent using the+ MySQL database server. Internally it uses the @mysql-simple@+ and @mysql@ packages in order to access the database.+ .+ This package supports only MySQL 5.1 and above. However, it+ has been tested only on MySQL 5.5.+ Only the InnoDB storage engine is officially supported.+ .+ Known problems:+ .+ * This package does not support statements inside other+ statements.+ extra-source-files: ChangeLog.md library- build-depends: base >= 4.6 && < 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- , containers >= 0.2- , bytestring >= 0.9- , text >= 0.11.0.6- , monad-control >= 0.2- , aeson >= 0.6.2- , conduit >= 0.5.3- , resourcet >= 0.4.10- , monad-logger- , resource-pool- exposed-modules: Database.Persist.MySQL- ghc-options: -Wall+ build-depends:+ aeson >=1.0+ , base >=4.9 && <5+ , blaze-builder+ , bytestring >=0.10.8+ , conduit >=1.2.12+ , containers >=0.5+ , monad-logger+ , mysql >=0.2.1 && <0.3+ , mysql-simple >=0.4.7 && <0.5+ , persistent >=2.18 && <3+ , resource-pool+ , resourcet >=1.1+ , text >=1.2+ , transformers >=0.5+ , unliftio-core + exposed-modules: Database.Persist.MySQL+ ghc-options: -Wall+ default-language: Haskell2010+ source-repository head type: git- location: git://github.com/yesodweb/persistent.git+ location: https://github.com/yesodweb/persistent.git++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ other-modules:+ CustomConstraintTest+ ImplicitUuidSpec+ InsertDuplicateUpdate+ JSONTest+ MyInit++ ghc-options: -Wall+ build-depends:+ aeson+ , base >=4.9 && <5+ , bytestring+ , conduit+ , containers+ , fast-logger+ , hspec >=2.4+ , http-api-data+ , HUnit+ , monad-logger+ , mysql+ , path-pieces+ , persistent+ , persistent-mysql+ , persistent-qq+ , persistent-test+ , QuickCheck+ , quickcheck-instances+ , resourcet+ , text+ , time+ , transformers+ , unliftio-core++ default-language: Haskell2010
+ test/CustomConstraintTest.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module CustomConstraintTest where++import qualified Data.Text as T+import MyInit++share+ [mkPersist sqlSettings, mkMigrate "customConstraintMigrate"]+ [persistLowerCase|+CustomConstraint1+ some_field Text+ deriving Show++CustomConstraint2+ cc_id CustomConstraint1Id constraint=custom_constraint+ deriving Show++CustomConstraint3+ -- | This will lead to a constraint with the name custom_constraint3_cc_id1_fkey+ cc_id1 CustomConstraint1Id+ cc_id2 CustomConstraint1Id+ deriving Show+|]++clean :: (MonadUnliftIO m) => SqlPersistT m ()+clean = do+ rawExecute "drop table custom_constraint3" []+ rawExecute "drop table custom_constraint2" []+ rawExecute "drop table custom_constraint1" []++specs :: (MonadUnliftIO m, MonadFail m) => RunDb SqlBackend m -> Spec+specs runDb = do+ describe "custom constraint used in migration" $ before_ (runDb $ void $ runMigrationSilent customConstraintMigrate) $ after_ (runDb clean) $ do+ it "custom constraint is actually created" $ runDb $ do+ void $ runMigrationSilent customConstraintMigrate -- run a second time to ensure the constraint isn't dropped+ let+ query =+ T.concat+ [ "SELECT COUNT(*) "+ , "FROM information_schema.key_column_usage "+ , "WHERE ordinal_position=1 "+ , "AND referenced_table_name=? "+ , "AND referenced_column_name=? "+ , "AND table_name=? "+ , "AND column_name=? "+ , "AND constraint_name=?"+ ]+ [Single exists_] <-+ rawSql+ query+ [ PersistText "custom_constraint1"+ , PersistText "id"+ , PersistText "custom_constraint2"+ , PersistText "cc_id"+ , PersistText "custom_constraint"+ ]+ liftIO $ 1 @?= (exists_ :: Int)++ it "allows multiple constraints on a single column" $ runDb $ do+ -- Here we add another foreign key on the same column where the+ -- default one already exists. In practice, this could be+ -- a compound key with another field.+ rawExecute+ "ALTER TABLE custom_constraint3 ADD CONSTRAINT extra_constraint FOREIGN KEY(cc_id1) REFERENCES custom_constraint1(id)"+ []+ -- This is where the error is thrown in `getColumn`+ _ <- getMigration customConstraintMigrate+ pure ()
+ test/ImplicitUuidSpec.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module ImplicitUuidSpec where++import MyInit++import Data.Proxy+import Database.Persist.MySQL++import Database.Persist.ImplicitIdDef+import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable)++share+ [ mkPersist (sqlSettingsUuid "UUID()")+ , mkEntityDefList "entities"+ ]+ [persistLowerCase|++WithDefUuid+ name Text++ deriving Eq Show Ord++|]++implicitUuidMigrate :: Migration+implicitUuidMigrate = do+ migrateModels entities++wipe :: IO ()+wipe = db $ do+ rawExecute "DROP TABLE IF EXISTS with_def_uuid;" []+ void $ runMigrationSilent implicitUuidMigrate++itDb+ :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ()))+itDb msg action = it msg $ db $ void action++pass :: IO ()+pass = pure ()++spec :: Spec+spec = describe "ImplicitUuidSpec" $ before_ wipe $ do+ describe "WithDefUuidKey" $ do+ it "works on UUIDs" $ do+ let+ withDefUuidKey = WithDefUuidKey (UUID "Hello")+ pass+ describe "getEntityId" $ do+ let+ Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid))+ it "has a SqlString SqlType" $ asIO $ do+ fieldSqlType idField `shouldBe` SqlString+ it "is an implicit ID column" $ asIO $ do+ fieldIsImplicitIdColumn idField `shouldBe` True++ describe "insert" $ do+ itDb "successfully has a default" $ do+ let+ matt =+ WithDefUuid+ { withDefUuidName =+ "Matt"+ }+ k <- insert matt+ mrec <- get k+ uuids <- selectList @WithDefUuid [] []+ liftIO $ do+ -- MySQL's insert functionality is currently broken. The @k@+ -- here is derived from @SELECT LAST_INSERT_ID()@ which only+ -- works on auto incrementing IDs.+ --+ -- See #1251 for more details.+ mrec `shouldBe` Nothing++ map entityVal uuids `shouldSatisfy` (matt `elem`)
+ test/InsertDuplicateUpdate.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module InsertDuplicateUpdate where++import Data.List (sort)++import Database.Persist.MySQL+import MyInit++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)+ [copyField ItemDescription]+ []+ dbItems <- map entityVal <$> selectList [] []+ sort dbItems @== sort (newItem : items)+ it "updates existing records" $ db $ do+ let+ postUpdate = map (\i -> i{itemQuantity = fmap (+ 1) (itemQuantity i)}) items+ deleteWhere ([] :: [Filter Item])+ insertMany_ items+ insertManyOnDuplicateKeyUpdate+ items+ []+ [ItemQuantity +=. Just 1]+ dbItems <- sort . fmap entityVal <$> selectList [] []+ dbItems @== sort postUpdate+ 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)+ , copyField ItemPrice+ ]+ []+ dbItems <- sort . fmap entityVal <$> selectList [] []+ dbItems @== sort postUpdate+ it "inserts without modifying existing records if no updates specified" $ db $ do+ let+ newItem = Item "item3" "hi friends!" Nothing Nothing+ deleteWhere ([] :: [Filter Item])+ insertMany_ items+ insertManyOnDuplicateKeyUpdate+ (newItem : items)+ []+ []+ dbItems <- sort . fmap entityVal <$> selectList [] []+ dbItems @== sort (newItem : items)
+ test/JSONTest.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module JSONTest where++import Data.Aeson+import Test.HUnit (assertBool)++import qualified Data.ByteString.Lazy as BSL+import Data.Conduit (runConduit, (.|))+import qualified Data.Conduit.List as CL+import Database.Persist.MySQL+import MyInit++specs :: Spec+specs = describe "JSONTest" $ do+ it "can select json with rawsql" $ db $ do+ let+ testJSON = toJSON $ [object ["test" .= ("value" :: Text)]]+ [[PersistByteString value]] <-+ runConduit $+ rawQuery "select JSON_ARRAY(JSON_OBJECT('test', 'value'))" [] .| CL.consume+ liftIO $ Just testJSON `shouldBe` (decode $ BSL.fromStrict value)
+ test/MyInit.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module MyInit+ ( (@/=)+ , (@==)+ , (==@)+ , asIO+ , assertNotEqual+ , assertNotEmpty+ , assertEmpty+ , isTravis+ , BackendMonad+ , runConn+ , MonadIO+ , persistSettings+ , MkPersistSettings (..)+ , db+ , BackendKey (..)+ , GenerateKey (..)+ , RunDb+ -- re-exports+ , module Database.Persist+ , module Database.Persist.Sql.Raw.QQ+ , module Test.Hspec+ , module Test.HUnit+ , MonadUnliftIO+ , liftIO+ , mkPersist+ , mkMigrate+ , share+ , sqlSettings+ , persistLowerCase+ , persistUpperCase+ , mkEntityDefList+ , sqlSettingsUuid+ , Int32+ , Int64+ , Text+ , module Control.Monad.Trans.Reader+ , module Control.Monad+ , module Database.Persist.Sql+ , BS.ByteString+ , migrateModels+ , SomeException+ , MonadFail+ , TestFn (..)+ , truncateTimeOfDay+ , truncateToMicro+ , truncateUTCTime+ , arbText+ , liftA2+ , LoggingT+ , ResourceT+ , UUID (..)+ ) where++import Init+ ( GenerateKey (..)+ , MonadFail+ , RunDb+ , TestFn (..)+ , arbText+ , asIO+ , assertEmpty+ , assertNotEmpty+ , assertNotEqual+ , isTravis+ , truncateTimeOfDay+ , truncateToMicro+ , truncateUTCTime+ , (==@)+ , (@/=)+ , (@==)+ )++-- re-exports+import Control.Applicative (liftA2)+import Control.Exception (SomeException)+import Control.Monad (forM_, liftM, replicateM, void, when)+import Control.Monad.Trans.Reader+import Data.Aeson (FromJSON, ToJSON, Value (..))+import Database.Persist.ImplicitIdDef+import Database.Persist.Sql.Raw.QQ+import Database.Persist.TH+ ( MkPersistSettings (..)+ , migrateModels+ , mkEntityDefList+ , mkMigrate+ , mkPersist+ , persistLowerCase+ , persistUpperCase+ , setImplicitIdDef+ , share+ , sqlSettings+ )+import Test.Hspec+import Test.QuickCheck.Instances ()+import Web.Internal.HttpApiData+import Web.PathPieces++-- testing+import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=))++import Control.Monad (unless, (>=>))+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Logger+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import qualified Data.ByteString as BS+import Data.Int (Int32, Int64)+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import qualified Database.MySQL.Base as MySQL+import System.Log.FastLogger (fromLogStr)++import Database.Persist+import Database.Persist.MySQL+import Database.Persist.Sql++_debugOn :: Bool+_debugOn = False++persistSettings :: MkPersistSettings+persistSettings = sqlSettings{mpsGeneric = True}++type BackendMonad = SqlBackend++runConn :: (MonadUnliftIO m) => SqlPersistT (LoggingT m) t -> m ()+runConn f = do+ travis <- liftIO isTravis+ let+ debugPrint = not travis && _debugOn+ let+ printDebug = if debugPrint then print . fromLogStr else void . return+ flip runLoggingT (\_ _ _ s -> printDebug s) $ do+ -- Since version 5.7.5, MySQL adds a mode value `STRICT_TRANS_TABLES`+ -- which can cause an exception in MaxLenTest, depending on the server+ -- configuration. Persistent tests do not need any of the modes which are+ -- set by default, so it is simplest to clear `sql_mode` for the session.+ let+ baseConnectInfo =+ defaultConnectInfo+ { connectOptions =+ connectOptions defaultConnectInfo+ ++ [MySQL.InitCommand "SET SESSION sql_mode = '';\0"]+ }+ _ <-+ if not travis+ then+ withMySQLPool+ baseConnectInfo+ { connectHost = "127.0.0.1"+ , connectUser = "test"+ , connectPassword = "test"+ , connectDatabase = "test"+ }+ 1+ $ runSqlPool f+ else+ withMySQLPool+ baseConnectInfo+ { connectHost = "127.0.0.1"+ , connectUser = "test"+ , connectPassword = "test"+ , connectDatabase = "test"+ , connectPort = 33306+ }+ 1+ $ runSqlPool f+ return ()++db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion+db actions = do+ runResourceT $ runConn $ actions >> transactionUndo++newtype UUID = UUID {unUUID :: Text}+ deriving stock+ (Show, Eq, Ord, Read)+ deriving newtype+ ( ToJSON+ , FromJSON+ , PersistField+ , PersistFieldSql+ , FromHttpApiData+ , ToHttpApiData+ , PathPiece+ )++sqlSettingsUuid :: Text -> MkPersistSettings+sqlSettingsUuid defExpr =+ let+ uuidDef =+ setImplicitIdDefMaxLen 100 $ mkImplicitIdDef @UUID defExpr+ settings =+ setImplicitIdDef uuidDef sqlSettings+ in+ settings
+ test/main.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++import MyInit++import qualified Data.ByteString as BS+import Data.Fixed+import Data.Int (Int8)+import Data.IntMap (IntMap)+import qualified Data.Text as T+import Data.Time+ ( Day+ , TimeOfDay+ , UTCTime (..)+ , timeOfDayToTime+ , timeToTimeOfDay+ )+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Database.Persist.Sql+import Test.QuickCheck++import qualified CompositeTest+import qualified CustomPersistFieldTest+import qualified CustomPrimaryKeyReferenceTest+import qualified DataTypeTest+import qualified EmbedOrderTest+import qualified EmbedTest+import qualified EmptyEntityTest+import qualified EquivalentTypeTest+import qualified HtmlTest+import qualified InsertDuplicateUpdate+import qualified LargeNumberTest+import qualified MaxLenTest+import qualified MaybeFieldDefsTest+import qualified MigrationColumnLengthTest+import qualified MigrationIdempotencyTest+import qualified MigrationOnlyTest+import qualified MigrationTest+import qualified MpsCustomPrefixTest+import qualified MpsNoPrefixTest+import qualified PersistUniqueTest+import qualified PersistentTest+import qualified TypeLitFieldDefsTest++-- FIXME: Not used... should it be?+-- import qualified PrimaryTest+import qualified RawSqlTest+import qualified ReadWriteTest+import qualified Recursive++-- TODO: can't use this as MySQL can't do DEFAULT CURRENT_DATE+import qualified CustomConstraintTest+import qualified ForeignKey+import qualified GeneratedColumnTestSQL+import qualified ImplicitUuidSpec+import qualified JSONTest+import qualified LongIdentifierTest+import qualified RenameTest+import qualified SumTypeTest+import qualified TransactionLevelTest+import qualified UniqueTest+import qualified UpsertTest++type Tuple a b = (a, b)++-- Test lower case names+share+ [mkPersist persistSettings, mkMigrate "dataTypeMigrate"]+ [persistLowerCase|+DataTypeTable no-json+ text Text+ textMaxLen Text maxlen=100+ bytes ByteString+ bytesTextTuple (Tuple ByteString Text)+ bytesMaxLen ByteString maxlen=100+ int Int+ intList [Int]+ intMap (IntMap Int)+ double Double+ bool Bool+ day Day+ pico Pico+ time TimeOfDay+ utc UTCTime+ -- For MySQL, provide extra tests for time fields with fractional seconds,+ -- since the default (used above) is to have no fractional part. This+ -- requires the server version to be at least 5.6.4, and should be switched+ -- off for older servers by defining OLD_MYSQL.+ timeFrac TimeOfDay sqltype=TIME(6)+ utcFrac UTCTime sqltype=DATETIME(6)+ tinyint Int8 sqltype=TINYINT+ tinyint4 Int8 sqltype=TINYINT(4)+|]++instance Arbitrary (DataTypeTableGeneric backend) where+ arbitrary =+ DataTypeTable+ <$> arbText -- text+ <*> (T.take 100 <$> arbText) -- textManLen+ <*> arbitrary -- bytes+ <*> liftA2 (,) arbitrary arbText -- bytesTextTuple+ <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen+ <*> arbitrary -- int+ <*> arbitrary -- intList+ <*> arbitrary -- intMap+ <*> arbitrary -- double+ <*> arbitrary -- bool+ <*> arbitrary -- day+ <*> arbitrary -- pico+ <*> (truncateTimeOfDay =<< arbitrary) -- time+ <*> (truncateUTCTime =<< arbitrary) -- utc+ <*> (truncateTimeOfDay =<< arbitrary) -- timeFrac+ <*> (truncateUTCTime =<< arbitrary) -- utcFrac+ <*> arbitrary -- tinyint+ <*> choose (-8, 7) -- tinyint4+setup :: (HasCallStack, MonadUnliftIO m) => Migration -> ReaderT SqlBackend m ()+setup migration = do+ printMigration migration+ _ <- runMigrationUnsafe migration+ pure ()++main :: IO ()+main = do+ runConn $ do+ mapM_+ setup+ [ PersistentTest.testMigrate+ , PersistentTest.noPrefixMigrate+ , PersistentTest.customPrefixMigrate+ , EmbedTest.embedMigrate+ , EmbedOrderTest.embedOrderMigrate+ , LargeNumberTest.numberMigrate+ , UniqueTest.uniqueMigrate+ , MaxLenTest.maxlenMigrate+ , MaybeFieldDefsTest.maybeFieldDefMigrate+ , TypeLitFieldDefsTest.typeLitFieldDefsMigrate+ , Recursive.recursiveMigrate+ , CompositeTest.compositeMigrate+ , PersistUniqueTest.migration+ , RenameTest.migration+ , CustomPersistFieldTest.customFieldMigrate+ , InsertDuplicateUpdate.duplicateMigrate+ , MigrationIdempotencyTest.migration+ , MigrationTest.migrationMigrate+ , CustomPrimaryKeyReferenceTest.migration+ , MigrationColumnLengthTest.migration+ , TransactionLevelTest.migration+ , -- , LongIdentifierTest.migration+ ForeignKey.compositeMigrate+ ]+ PersistentTest.cleanDB+ ForeignKey.cleanDB++ hspec $ do+ ImplicitUuidSpec.spec+ xdescribe "This is pending on MySQL because you can't have DEFAULT CURRENT_DATE" $ do+ RenameTest.specsWith db+ DataTypeTest.specsWith+ db+ (Just (runMigrationSilent dataTypeMigrate))+ [ TestFn "text" dataTypeTableText+ , TestFn "textMaxLen" dataTypeTableTextMaxLen+ , TestFn "bytes" dataTypeTableBytes+ , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple+ , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen+ , TestFn "int" dataTypeTableInt+ , TestFn "intList" dataTypeTableIntList+ , TestFn "intMap" dataTypeTableIntMap+ , TestFn "bool" dataTypeTableBool+ , TestFn "day" dataTypeTableDay+ , TestFn "time" (roundTime . dataTypeTableTime)+ , TestFn "utc" (roundUTCTime . dataTypeTableUtc)+ , TestFn "timeFrac" (dataTypeTableTimeFrac)+ , TestFn "utcFrac" (dataTypeTableUtcFrac)+ , TestFn "tinyint" dataTypeTableTinyint+ , TestFn "tinyint4" dataTypeTableTinyint4+ ]+ [("pico", dataTypeTablePico)]+ dataTypeTableDouble+ HtmlTest.specsWith+ db+ (Just (runMigrationSilent HtmlTest.htmlMigrate))+ EmbedTest.specsWith db+ EmbedOrderTest.specsWith db+ LargeNumberTest.specsWith db+ UniqueTest.specsWith db+ MaybeFieldDefsTest.specsWith db+ TypeLitFieldDefsTest.specsWith db+ MaxLenTest.specsWith db+ Recursive.specsWith db+ SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))+ MigrationOnlyTest.specsWith+ db+ ( Just $ do+ void $ rawExecute "DROP TABLE IF EXISTS referencing;" []+ void $ rawExecute "DROP TABLE IF EXISTS two_field;" []+ void $ runMigrationSilent MigrationOnlyTest.migrateAll1+ void $ runMigrationSilent MigrationOnlyTest.migrateAll2+ )+ PersistentTest.specsWith db+ PersistentTest.filterOrSpecs db+ ReadWriteTest.specsWith db+ RawSqlTest.specsWith db+ UpsertTest.specsWith+ db+ UpsertTest.Don'tUpdateNull+ UpsertTest.UpsertPreserveOldKey++ ForeignKey.specsWith db+ MpsNoPrefixTest.specsWith db+ MpsCustomPrefixTest.specsWith db+ EmptyEntityTest.specsWith+ db+ (Just (runMigrationSilent EmptyEntityTest.migration))+ CompositeTest.specsWith db+ PersistUniqueTest.specsWith db+ CustomPersistFieldTest.specsWith db+ CustomPrimaryKeyReferenceTest.specsWith db+ InsertDuplicateUpdate.specs+ MigrationColumnLengthTest.specsWith db+ EquivalentTypeTest.specsWith db+ TransactionLevelTest.specsWith db++ MigrationIdempotencyTest.specsWith db+ MigrationTest.specsWith db+ CustomConstraintTest.specs db+ -- TODO: implement automatic truncation for too long foreign keys, so we can run this test.+ xdescribe+ "The migration for this test currently fails because of MySQL's 64 character limit for identifiers. See https://github.com/yesodweb/persistent/issues/1000 for details"+ $ LongIdentifierTest.specsWith db+ GeneratedColumnTestSQL.specsWith db+ JSONTest.specs++roundFn :: (RealFrac a) => a -> Integer+roundFn = round++roundTime :: TimeOfDay -> TimeOfDay+roundTime t = timeToTimeOfDay $ fromIntegral $ roundFn $ timeOfDayToTime t++roundUTCTime :: UTCTime -> UTCTime+roundUTCTime t =+ posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t