diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # 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) diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -7,1595 +7,1765 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' --- | 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 qualified Data.Map as Map -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" -> Nothing - _ -> - 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]) +{-# 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,89 +1,95 @@ -name: persistent-mysql -version: 2.13.1.5 -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 +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.9 && < 5 - , persistent >= 2.13.3 && < 3 - , aeson >= 1.0 - , 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 - , resourcet >= 1.1 - , resource-pool - , text >= 1.2 - , transformers >= 0.5 - , unliftio-core - exposed-modules: Database.Persist.MySQL - ghc-options: -Wall - default-language: Haskell2010 + 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: - MyInit - InsertDuplicateUpdate - CustomConstraintTest - ImplicitUuidSpec - JSONTest - ghc-options: -Wall + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test + other-modules: + CustomConstraintTest + ImplicitUuidSpec + InsertDuplicateUpdate + JSONTest + MyInit - build-depends: - base >= 4.9 && < 5 - , aeson - , bytestring - , containers - , conduit - , 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 + 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 --- a/test/CustomConstraintTest.hs +++ b/test/CustomConstraintTest.hs @@ -1,23 +1,26 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds, FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module CustomConstraintTest where -import MyInit import qualified Data.Text as T +import MyInit -share [mkPersist sqlSettings, mkMigrate "customConstraintMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "customConstraintMigrate"] + [persistLowerCase| CustomConstraint1 some_field Text deriving Show @@ -33,7 +36,7 @@ deriving Show |] -clean :: MonadUnliftIO m => SqlPersistT m () +clean :: (MonadUnliftIO m) => SqlPersistT m () clean = do rawExecute "drop table custom_constraint3" [] rawExecute "drop table custom_constraint2" [] @@ -41,32 +44,39 @@ 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) + 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 () + 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 --- a/test/ImplicitUuidSpec.hs +++ b/test/ImplicitUuidSpec.hs @@ -44,7 +44,8 @@ rawExecute "DROP TABLE IF EXISTS with_def_uuid;" [] void $ runMigrationSilent implicitUuidMigrate -itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) +itDb + :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) itDb msg action = it msg $ db $ void action pass :: IO () @@ -54,10 +55,12 @@ spec = describe "ImplicitUuidSpec" $ before_ wipe $ do describe "WithDefUuidKey" $ do it "works on UUIDs" $ do - let withDefUuidKey = WithDefUuidKey (UUID "Hello") + let + withDefUuidKey = WithDefUuidKey (UUID "Hello") pass describe "getEntityId" $ do - let Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid)) + 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 @@ -65,10 +68,12 @@ describe "insert" $ do itDb "successfully has a default" $ do - let matt = WithDefUuid - { withDefUuidName = - "Matt" - } + let + matt = + WithDefUuid + { withDefUuidName = + "Matt" + } k <- insert matt mrec <- get k uuids <- selectList @WithDefUuid [] [] diff --git a/test/InsertDuplicateUpdate.hs b/test/InsertDuplicateUpdate.hs --- a/test/InsertDuplicateUpdate.hs +++ b/test/InsertDuplicateUpdate.hs @@ -1,21 +1,27 @@ -{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, ExistentialQuantification #-} +{-# 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 #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} module InsertDuplicateUpdate where -import Data.List (sort) +import Data.List (sort) import Database.Persist.MySQL import MyInit -share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| +share + [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] + [persistUpperCase| Item name Text sqltype=varchar(80) description Text @@ -29,67 +35,76 @@ 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 + 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 } + 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) + 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 --- a/test/JSONTest.hs +++ b/test/JSONTest.hs @@ -28,6 +28,9 @@ 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 + 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 --- a/test/MyInit.hs +++ b/test/MyInit.hs @@ -3,94 +3,103 @@ {-# 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 +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 - , (==@) - , (@/=) - , (@==) - ) + ( 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 Data.Aeson (FromJSON, ToJSON, Value (..)) +import Database.Persist.ImplicitIdDef import Database.Persist.Sql.Raw.QQ import Database.Persist.TH - ( MkPersistSettings(..) - , migrateModels - , setImplicitIdDef - , mkEntityDefList - , mkMigrate - , mkPersist - , persistLowerCase - , persistUpperCase - , share - , sqlSettings - ) + ( MkPersistSettings (..) + , migrateModels + , mkEntityDefList + , mkMigrate + , mkPersist + , persistLowerCase + , persistUpperCase + , setImplicitIdDef + , share + , sqlSettings + ) import Test.Hspec import Test.QuickCheck.Instances () import Web.Internal.HttpApiData import Web.PathPieces -import Database.Persist.ImplicitIdDef -- testing import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) @@ -115,60 +124,76 @@ _debugOn = False persistSettings :: MkPersistSettings -persistSettings = sqlSettings { mpsGeneric = True } +persistSettings = sqlSettings{mpsGeneric = True} type BackendMonad = SqlBackend -runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () +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 () + 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 + runResourceT $ runConn $ actions >> transactionUndo -newtype UUID = UUID { unUUID :: Text } +newtype UUID = UUID {unUUID :: Text} deriving stock (Show, Eq, Ord, Read) deriving newtype - ( ToJSON, FromJSON - , PersistField, PersistFieldSql - , FromHttpApiData, ToHttpApiData, PathPiece + ( ToJSON + , FromJSON + , PersistField + , PersistFieldSql + , FromHttpApiData + , ToHttpApiData + , PathPiece ) sqlSettingsUuid :: Text -> MkPersistSettings sqlSettingsUuid defExpr = let uuidDef = - setImplicitIdDefMaxLen 100 $ mkImplicitIdDef @UUID defExpr + setImplicitIdDefMaxLen 100 $ mkImplicitIdDef @UUID defExpr settings = setImplicitIdDef uuidDef sqlSettings in diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -10,8 +10,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -Wno-unused-top-binds #-} import MyInit @@ -21,7 +21,13 @@ 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 + ( Day + , TimeOfDay + , UTCTime (..) + , timeOfDayToTime + , timeToTimeOfDay + ) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Database.Persist.Sql import Test.QuickCheck @@ -48,11 +54,13 @@ 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 @@ -69,7 +77,9 @@ type Tuple a b = (a, b) -- Test lower case names -share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase| +share + [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] + [persistLowerCase| DataTypeTable no-json text Text textMaxLen Text maxlen=100 @@ -96,35 +106,37 @@ |] 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 + 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 () + printMigration migration + _ <- runMigrationUnsafe migration + pure () main :: IO () main = do runConn $ do - mapM_ setup + mapM_ + setup [ PersistentTest.testMigrate , PersistentTest.noPrefixMigrate , PersistentTest.customPrefixMigrate @@ -146,8 +158,8 @@ , CustomPrimaryKeyReferenceTest.migration , MigrationColumnLengthTest.migration , TransactionLevelTest.migration - -- , LongIdentifierTest.migration - , ForeignKey.compositeMigrate + , -- , LongIdentifierTest.migration + ForeignKey.compositeMigrate ] PersistentTest.cleanDB ForeignKey.cleanDB @@ -176,7 +188,7 @@ , TestFn "tinyint" dataTypeTableTinyint , TestFn "tinyint4" dataTypeTableTinyint4 ] - [ ("pico", dataTypeTablePico) ] + [("pico", dataTypeTablePico)] dataTypeTableDouble HtmlTest.specsWith db @@ -190,8 +202,9 @@ MaxLenTest.specsWith db Recursive.specsWith db SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) - MigrationOnlyTest.specsWith db - (Just $ do + MigrationOnlyTest.specsWith + db + ( Just $ do void $ rawExecute "DROP TABLE IF EXISTS referencing;" [] void $ rawExecute "DROP TABLE IF EXISTS two_field;" [] void $ runMigrationSilent MigrationOnlyTest.migrateAll1 @@ -209,7 +222,9 @@ ForeignKey.specsWith db MpsNoPrefixTest.specsWith db MpsCustomPrefixTest.specsWith db - EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) + EmptyEntityTest.specsWith + db + (Just (runMigrationSilent EmptyEntityTest.migration)) CompositeTest.specsWith db PersistUniqueTest.specsWith db CustomPersistFieldTest.specsWith db @@ -223,12 +238,13 @@ 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 + 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 :: (RealFrac a) => a -> Integer roundFn = round roundTime :: TimeOfDay -> TimeOfDay