diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -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 - -- - , 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 + -- + 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 diff --git a/persistent-mysql.cabal b/persistent-mysql.cabal --- a/persistent-mysql.cabal +++ b/persistent-mysql.cabal @@ -1,50 +1,95 @@ -name: persistent-mysql -version: 2.6.2.1 -license: MIT -license-file: LICENSE -author: Felipe Lessa , Michael Snoyman -maintainer: Felipe Lessa -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 , Michael Snoyman +maintainer: Felipe Lessa +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 diff --git a/test/CustomConstraintTest.hs b/test/CustomConstraintTest.hs new file mode 100644 --- /dev/null +++ b/test/CustomConstraintTest.hs @@ -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 () diff --git a/test/ImplicitUuidSpec.hs b/test/ImplicitUuidSpec.hs new file mode 100644 --- /dev/null +++ b/test/ImplicitUuidSpec.hs @@ -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`) diff --git a/test/InsertDuplicateUpdate.hs b/test/InsertDuplicateUpdate.hs new file mode 100644 --- /dev/null +++ b/test/InsertDuplicateUpdate.hs @@ -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) diff --git a/test/JSONTest.hs b/test/JSONTest.hs new file mode 100644 --- /dev/null +++ b/test/JSONTest.hs @@ -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) diff --git a/test/MyInit.hs b/test/MyInit.hs new file mode 100644 --- /dev/null +++ b/test/MyInit.hs @@ -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 diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -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