persistent-mysql 2.10.2.3 → 2.10.3
raw patch · 7 files changed
+480/−242 lines, 7 filesdep ~mysqldep ~persistent
Dependency ranges changed: mysql, persistent
Files
- ChangeLog.md +4/−0
- Database/Persist/MySQL.hs +420/−217
- persistent-mysql.cabal +2/−2
- test/CustomConstraintTest.hs +25/−13
- test/InsertDuplicateUpdate.hs +2/−2
- test/MyInit.hs +6/−4
- test/main.hs +21/−4
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for persistent-mysql +## 2.10.3++* Compatibility with latest persistent+ ## 2.10.2.3 * Fix issue with multiple foreign keys on single column. [#1025](https://github.com/yesodweb/persistent/pull/1025)
Database/Persist/MySQL.hs view
@@ -1,9 +1,15 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# 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@@ -41,6 +47,7 @@ import Control.Monad.Trans.Reader (runReaderT, ReaderT) import Control.Monad.Trans.Writer (runWriterT) +import GHC.Stack import Data.Conduit import qualified Data.Conduit.List as CL import Data.Acquire (Acquire, mkAcquire, with)@@ -54,6 +61,7 @@ import Data.IORef import Data.List (find, intercalate, sort, groupBy) import qualified Data.Map as Map+import Data.Maybe (listToMaybe, mapMaybe, fromMaybe) import Data.Monoid ((<>)) import qualified Data.Monoid as Monoid import Data.Pool (Pool)@@ -61,7 +69,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T-import Text.Read (readMaybe) import System.Environment (getEnvironment) import Database.Persist.Sql@@ -161,18 +168,20 @@ -- | SQL code to be executed when inserting an entity. insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals =- let sql = pack $ concat- [ "INSERT INTO "- , escapeDBName $ entityDB ent- , "("- , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent- , ") VALUES("- , intercalate "," (map (const "?") $ entityFields ent)- , ")"- ]- in case entityPrimary ent of- Just _ -> ISRManyKeys sql vals- Nothing -> ISRInsertGet sql "SELECT LAST_INSERT_ID()"+ case entityPrimary ent of+ Just _ -> ISRManyKeys sql vals+ Nothing -> ISRInsertGet sql "SELECT LAST_INSERT_ID()"+ where+ (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escape)+ sql = T.concat+ [ "INSERT INTO "+ , escape $ entityDB 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@@ -202,9 +211,9 @@ let getters = [ maybe PersistNull (getGetter f f . Just) | f <- fields] convert = use getters where use (g:gs) (col:cols) =- let v = g col- vs = use gs cols- in v `seq` vs `seq` (v:vs)+ let !v = g col+ !vs = use gs cols+ in (v:vs) use _ _ = [] -- Ready to go!@@ -212,8 +221,8 @@ row <- MySQLBase.fetchRow result case row of [] -> return (acc [])- _ -> let converted = convert row- in converted `seq` go (acc . (converted:))+ _ -> let !converted = convert row+ in go (acc . (converted:)) go id @@ -235,8 +244,10 @@ render (P (PersistMap m)) = MySQL.render $ mapToJSON m render (P (PersistRational r)) = MySQL.Plain $ BBB.fromString $ show (fromRational r :: Pico)- -- FIXME: Too Ambigous, can not select precision without information about field+ -- FIXME: Too Ambiguous, can not select precision without information about field render (P (PersistDbSpecific s)) = MySQL.Plain $ BBS.fromByteString s+ render (P (PersistLiteral l)) = MySQL.Plain $ BBS.fromByteString l+ render (P (PersistLiteralEscaped 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"@@ -310,7 +321,7 @@ -- Conversion using PersistDbSpecific go MySQLBase.Geometry _ _ = \_ m -> case m of- Just g -> PersistDbSpecific g+ Just g -> PersistLiteral g Nothing -> error "Unexpected null in database specific value" -- Unsupported go other _ _ = error $ "MySQL.getGetter: type " ++@@ -330,42 +341,96 @@ -> IO (Either [Text] [(Bool, Text)]) migrate' connectInfo allDefs getter val = do let name = entityDB val- let (newcols, udefs, fdefs) = mkColumns allDefs val- (idClmn, old) <- getColumns connectInfo getter val newcols+ let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val+ old <- getColumns connectInfo getter val newcols let udspair = map udToPair udefs- case (idClmn, old, partitionEithers old) of- -- Nothing found, create everything- ([], [], _) -> do- let uniques = flip concatMap udspair $ \(uname, ucols) ->- [ AlterTable name $- AddUniqueConstraint uname $- map (findTypeAndMaxLen name) ucols ]- let foreigns = do- Column { cName=cname, cReference=Just (refTblName, refConstraintName) } <- newcols- return $ AlterColumn name (refTblName, addReference allDefs refConstraintName refTblName cname)+ 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 foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))- in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs+ 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) - return $ Right $ map showAlterDb $ (addTable newcols val): uniques ++ foreigns ++ foreignsAlt- -- No errors and something found, migrate- (_, _, ([], old')) -> do- let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of- Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of- Just _ -> c { cReference = Nothing }- Nothing -> c- Nothing -> c) xs,ys)- (acs, ats) = getAlters allDefs name (newcols, udspair) $ excludeForeignKeys $ partitionEithers old'- acs' = map (AlterColumn name) acs- ats' = map (AlterTable name) ats- return $ Right $ map showAlterDb $ acs' ++ ats'- -- Errors- (_, _, (errs, _)) -> return $ Left errs+ guard $ refTblName /= name && cname /= fieldDB (entityId val)+ return $ AlterColumn name (refTblName, refTarget) + let foreignsAlt =+ map+ (\fdef ->+ let (childfields, parentfields) =+ unzip+ $ map (\((_,b),(_,d)) -> (b,d))+ $ foreignFields fdef+ in+ AlterColumn+ name+ ( foreignRefTableDBName fdef+ , AddReference+ (foreignRefTableDBName fdef)+ (foreignConstraintNameDBName fdef)+ childfields parentfields+ (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)+ 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@@ -374,11 +439,13 @@ , escapeDBName name , "(" , idtxt- , if null cols then [] else ","- , intercalate "," $ map showColumn cols+ , if null nonIdCols then [] else ","+ , intercalate "," $ map showColumn nonIdCols , ")" ] where+ nonIdCols =+ filter (\c -> cName c /= fieldDB (entityId entity) ) cols name = entityDB entity idtxt = case entityPrimary entity of Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . fieldDB) $ compositeFields pdef, ")"]@@ -400,10 +467,13 @@ -- | Find out the type of a column. findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) findTypeOfColumn allDefs name col =- maybe (error $ "Could not find type of column " +++ maybe+ (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++- " (allDefs = " ++ show allDefs ++ ")")- ((,) col) $ do+ " (allDefs = " ++ show allDefs ++ ")"+ )+ ((,) col)+ $ do entDef <- find ((== name) . entityDB) allDefs fieldDef <- find ((== col) . fieldDB) (entityFields entDef) return (fieldType fieldDef)@@ -419,25 +489,45 @@ -- | Find out the maxlen of a field findMaxLenOfField :: FieldDef -> Maybe Integer-findMaxLenOfField fieldDef = do- maxLenAttr <- find ((T.isPrefixOf "maxlen=") . T.toLower) (fieldAttrs fieldDef)- readMaybe . T.unpack . T.drop 7 $ maxLenAttr+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] -> DBName -> DBName -> DBName -> AlterColumn-addReference allDefs fkeyname reftable cname = AddReference reftable fkeyname [cname] referencedColumns- where- referencedColumns = maybe (error $ "Could not find ID of entity " ++ show reftable- ++ " (allDefs = " ++ show allDefs ++ ")")- id $ do- entDef <- find ((== reftable) . entityDB) allDefs- return $ map fieldDB $ entityKeyFields entDef+addReference+ :: [EntityDef]+ -- ^ List of all known 'EntityDef's.+ -> DBName+ -- ^ Foreign key name+ -> DBName+ -- ^ Referenced table name+ -> DBName+ -- ^ 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) . entityDB) allDefs+ return $ map fieldDB $ entityKeyFields entDef data AlterColumn = Change Column | Add' Column | Drop | Default String | NoDefault+ | Gen SqlType (Maybe Integer) String+ | NoGen SqlType (Maybe Integer) | Update' String -- | See the definition of the 'showAlter' function to see how these fields are used. | AddReference@@ -445,16 +535,20 @@ DBName -- Foreign key name [DBName] -- Referencing columns [DBName] -- Referenced columns+ FieldCascade | DropReference DBName+ deriving Show type AlterColumn' = (DBName, AlterColumn) data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType, Integer)] | DropUniqueConstraint DBName+ deriving Show data AlterDB = AddTable String | AlterColumn DBName AlterColumn' | AlterTable DBName AlterTable+ deriving Show udToPair :: UniqueDef -> (DBName, [DBName])@@ -465,26 +559,13 @@ -- | Returns all of the 'Column'@s@ in the given table currently -- in the database.-getColumns :: MySQL.ConnectInfo- -> (Text -> IO Statement)- -> EntityDef -> [Column] - -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column- , [Either Text (Either Column (DBName, [DBName]))] -- everything else- )+getColumns+ :: HasCallStack+ => MySQL.ConnectInfo+ -> (Text -> IO Statement)+ -> EntityDef -> [Column]+ -> IO [Either Text (Either Column (DBName, [DBName]))] getColumns connectInfo getter def cols = do- -- Find out ID column.- stmtIdClmn <- getter $ T.concat- [ "SELECT COLUMN_NAME, "- , "IS_NULLABLE, "- , "DATA_TYPE, "- , "COLUMN_DEFAULT "- , "FROM INFORMATION_SCHEMA.COLUMNS "- , "WHERE TABLE_SCHEMA = ? "- , "AND TABLE_NAME = ? "- , "AND COLUMN_NAME = ?"- ]- inter1 <- with (stmtQuery stmtIdClmn vals) (\src -> runConduit $ src .| CL.consume)- ids <- runConduitRes $ CL.sourceList inter1 .| helperClmns -- avoid nested queries -- Find out all columns. stmtClmns <- getter $ T.concat@@ -495,11 +576,12 @@ , "CHARACTER_MAXIMUM_LENGTH, " , "NUMERIC_PRECISION, " , "NUMERIC_SCALE, "- , "COLUMN_DEFAULT "+ , "COLUMN_DEFAULT, "+ , "GENERATION_EXPRESSION " , "FROM INFORMATION_SCHEMA.COLUMNS " , "WHERE TABLE_SCHEMA = ? " , "AND TABLE_NAME = ? "- , "AND COLUMN_NAME <> ?"+ -- , "AND COLUMN_NAME <> ?" ] inter2 <- with (stmtQuery stmtClmns vals) (\src -> runConduitRes $ src .| CL.consume) cs <- runConduitRes $ CL.sourceList inter2 .| helperClmns -- avoid nested queries@@ -511,7 +593,7 @@ , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE " , "WHERE TABLE_SCHEMA = ? " , "AND TABLE_NAME = ? "- , "AND COLUMN_NAME <> ? "+ -- , "AND COLUMN_NAME <> ? " , "AND CONSTRAINT_NAME <> 'PRIMARY' " , "AND REFERENCED_TABLE_SCHEMA IS NULL " , "ORDER BY CONSTRAINT_NAME, "@@ -520,7 +602,7 @@ us <- with (stmtQuery stmtCntrs vals) (\src -> runConduitRes $ src .| helperCntrs) -- Return both- return (ids, cs ++ us)+ return (cs ++ us) where refMap = Map.fromList $ foldl ref [] cols where ref rs c = case cReference c of@@ -528,7 +610,8 @@ (Just r) -> (unDBName $ cName c, r) : rs vals = [ PersistText $ pack $ MySQL.connectDatabase connectInfo , PersistText $ unDBName $ entityDB def- , PersistText $ unDBName $ fieldDB $ entityId def ]+ -- , PersistText $ unDBName $ fieldDB $ entityId def+ ] helperClmns = CL.mapM getIt .| CL.consume where@@ -549,12 +632,14 @@ -- | Get the information about a column in a table.-getColumn :: MySQL.ConnectInfo- -> (Text -> IO Statement)- -> DBName- -> [PersistValue]- -> Maybe (DBName, DBName)- -> IO (Either Text Column)+getColumn+ :: HasCallStack+ => MySQL.ConnectInfo+ -> (Text -> IO Statement)+ -> DBName+ -> [PersistValue]+ -> Maybe ColumnReference+ -> IO (Either Text Column) getColumn connectInfo getter tname [ PersistText cname , PersistText null_ , PersistText dataType@@ -562,69 +647,122 @@ , colMaxLen , colPrecision , colScale- , default'] refName =+ , 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'+ -- 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' - ref <- getRef refName- let colMaxLen' = case colMaxLen of- PersistInt64 l -> Just (fromIntegral l)- _ -> Nothing- ci = ColumnInfo- { ciColumnType = colType- , ciMaxLength = colMaxLen'- , ciNumericPrecision = colPrecision- , ciNumericScale = colScale+ 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 = DBName $ cname+ , cNull = null_ == "YES"+ , cSqlType = typ+ , cDefault = default_+ , cGenerated = generated_+ , cDefaultConstraintName = Nothing+ , cMaxLen = maxLen+ , cReference = ref }- (typ, maxLen) <- parseColumnType dataType ci- -- Okay!- return Column- { cName = DBName $ cname- , cNull = null_ == "YES"- , cSqlType = typ- , cDefault = default_- , 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 REFERENCED_TABLE_NAME, "- , "CONSTRAINT_NAME, "- , "ORDINAL_POSITION "- , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE "- , "WHERE TABLE_SCHEMA = ? "- , "AND TABLE_NAME = ? "- , "AND COLUMN_NAME = ? "- , "AND REFERENCED_TABLE_SCHEMA = ? "- , "AND CONSTRAINT_NAME = ? "- , "ORDER BY CONSTRAINT_NAME, "- , "COLUMN_NAME"+ 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 "+ , " ON KCU.CONSTRAINT_NAME = RC.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 $ unDBName $ tname- , PersistText cname- , PersistText $ pack $ MySQL.connectDatabase connectInfo- , PersistText $ unDBName refName' ]- cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume)- case cntrs of- [] -> return Nothing- [[PersistText tab, PersistText ref, PersistInt64 pos]] ->- return $ if pos == 1 then Just (DBName tab, DBName ref) else Nothing- xs -> error $ mconcat + let vars =+ [ PersistText $ pack $ MySQL.connectDatabase connectInfo+ , PersistText $ unDBName $ tname+ , PersistText cname+ , PersistText $ pack $ MySQL.connectDatabase connectInfo+ , PersistText $ unDBName 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 (DBName tab) (DBName 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 (unDBName tname) , " and column: "@@ -633,7 +771,6 @@ , show xs ] - getColumn _ _ _ x _ = return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x @@ -679,29 +816,32 @@ -- | @getAlters allDefs tblName new old@ finds out what needs to -- be changed from @old@ to become @new@.-getAlters :: [EntityDef]- -> DBName- -> ([Column], [(DBName, [DBName])])- -> ([Column], [(DBName, [DBName])])- -> ([AlterColumn'], [AlterTable])-getAlters allDefs tblName (c1, u1) (c2, u2) =+getAlters+ :: [EntityDef]+ -> EntityDef+ -> ([Column], [(DBName, [DBName])])+ -> ([Column], [(DBName, [DBName])])+ -> ([AlterColumn'], [AlterTable])+getAlters allDefs edef (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where+ tblName = entityDB edef getAltersC [] old = concatMap dropColumn old getAltersC (new:news) old =- let (alters, old') = findAlters tblName allDefs new old+ let (alters, old') = findAlters edef allDefs new old in alters ++ getAltersC news old' dropColumn col = map ((,) (cName col)) $- [DropReference n | Just (_, n) <- [cReference col]] +++ [DropReference (crConstraintName cr) | Just cr <- [cReference col]] ++ [Drop] getAltersU [] old = map (DropUniqueConstraint . fst) old getAltersU ((name, cols):news) old = case lookup name old of Nothing ->- AddUniqueConstraint name (map findTypeAndMaxLen cols) : getAltersU news old+ AddUniqueConstraint name (map findTypeAndMaxLen cols)+ : getAltersU news old Just ocols -> let old' = filter (\(x, _) -> x /= name) old in if sort cols == ocols@@ -710,43 +850,75 @@ : 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)+ findTypeAndMaxLen col =+ let (col', ty) = findTypeOfColumn allDefs tblName col+ (_, ml) = findMaxLenOfColumn allDefs tblName col+ in+ (col', ty, ml) --- | @findAlters newColumn oldColumns@ finds out what needs to be+-- | @findAlters x y newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported.-findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column])-findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName maxLen ref) cols =+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 didnt exist before- [] -> case ref of- Nothing -> ([(name, Add' col)],[])- Just (tname, cname) -> let cnstr = [addReference allDefs cname tname name]- in (map ((,) tname) (Add' col : cnstr), cols)- Column _ isNull' type_' def' _defConstraintName' maxLen' ref':_ ->+ -- new fkey that didn't exist before+ [] ->+ case ref of+ Nothing -> ([(name, Add' col)],[])+ Just cr ->+ let tname = crTableName cr+ cname = crConstraintName cr+ cnstr = [addReference allDefs cname tname name (crFieldCascade cr)]+ in+ (map ((,) tname) (Add' col : cnstr), cols)+ Column _ isNull' type_' def' gen' _defConstraintName' maxLen' ref' : _ -> let -- Foreign key- refDrop = case (ref == ref', ref') of- (False, Just (_, cname)) -> [(name, DropReference cname)]- _ -> []- refAdd = case (ref == ref', ref) of- (False, Just (tname, cname)) -> [(tname, addReference allDefs cname tname name)]- _ -> []+ refDrop =+ case (ref == ref', ref') of+ (False, Just ColumnReference {crConstraintName=cname}) ->+ [(name, DropReference cname)]+ _ ->+ []+ refAdd =+ case (ref == ref', ref) of+ (False, Just ColumnReference {crTableName=tname, crConstraintName=cname, crFieldCascade = cfc })+ | tname /= entityDB edef+ , cname /= fieldDB (entityId edef)+ ->+ [(tname, addReference allDefs cname tname name cfc)]+ _ -> [] -- Type and nullability modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = [] | otherwise = [(name, Change col)]+ -- Default value -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields- modDef | def == def' = []- | otherwise = case def of- Nothing -> [(name, NoDefault)]- Just s -> if T.toUpper s == "NULL" then []- else [(name, Default $ T.unpack s)]- in ( refDrop ++ modType ++ modDef ++ refAdd- , filter ((name /=) . cName) cols )+ modDef =+ if def == def' then []+ else case def of+ Nothing -> [(name, NoDefault)]+ Just s ->+ if T.toUpper s == "NULL" then []+ else [(name, Default $ T.unpack s)] + -- Does the generated value need to change?+ modGen =+ if gen == gen' then []+ else case gen of+ Nothing -> [(name, NoGen type_ maxLen)]+ Just genExpr -> [(name, Gen 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) @@ -756,11 +928,16 @@ -- | Prints the part of a @CREATE TABLE@ statement about a given -- column. showColumn :: Column -> String-showColumn (Column n nu t def _defConstraintName maxLen ref) = concat+showColumn (Column n nu t def gen _defConstraintName maxLen ref) = concat [ escapeDBName 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 -> ""@@ -769,7 +946,8 @@ else " DEFAULT " ++ T.unpack s , case ref of Nothing -> ""- Just (s, _) -> " REFERENCES " ++ escapeDBName s+ Just cRef -> " REFERENCES " ++ escapeDBName (crTableName cRef)+ <> " " <> T.unpack (renderFieldCascade (crFieldCascade cRef)) ] @@ -831,14 +1009,14 @@ -- | Render an action that must be done on a column. showAlter :: DBName -> AlterColumn' -> String-showAlter table (oldName, Change (Column n nu t def defConstraintName maxLen _ref)) =+showAlter table (oldName, Change (Column n nu t def gen defConstraintName maxLen _ref)) = concat [ "ALTER TABLE " , escapeDBName table , " CHANGE " , escapeDBName oldName , " "- , showColumn (Column n nu t def defConstraintName maxLen Nothing)+ , showColumn (Column n nu t def gen defConstraintName maxLen Nothing) ] showAlter table (_, Add' col) = concat@@ -871,6 +1049,27 @@ , escapeDBName n , " DROP DEFAULT" ]+showAlter table (col, Gen typ len expr) =+ concat+ [ "ALTER TABLE "+ , escapeDBName table+ , " MODIFY COLUMN "+ , escapeDBName col+ , " "+ , showSqlType typ len True+ , " GENERATED ALWAYS AS ("+ , expr+ , ") STORED"+ ]+showAlter table (col, NoGen typ len) =+ concat+ [ "ALTER TABLE "+ , escapeDBName table+ , " MODIFY COLUMN "+ , escapeDBName col+ , " "+ , showSqlType typ len True+ ] showAlter table (n, Update' s) = concat [ "UPDATE "@@ -883,7 +1082,7 @@ , escapeDBName n , " IS NULL" ]-showAlter table (_, AddReference reftable fkeyname t2 id2) = concat+showAlter table (_, AddReference reftable fkeyname t2 id2 fc) = concat [ "ALTER TABLE " , escapeDBName table , " ADD CONSTRAINT "@@ -894,7 +1093,8 @@ , escapeDBName reftable , "(" , intercalate "," $ map escapeDBName id2- , ")"+ , ") "+ , T.unpack $ renderFieldCascade fc ] showAlter table (_, DropReference cname) = concat [ "ALTER TABLE "@@ -989,7 +1189,7 @@ -> IO (Either [Text] [(Bool, Text)]) mockMigrate _connectInfo allDefs _getter val = do let name = entityDB val- let (newcols, udefs, fdefs) = mkColumns allDefs val+ let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val let udspair = map udToPair udefs case () of -- Nothing found, create everything@@ -999,28 +1199,28 @@ AddUniqueConstraint uname $ map (findTypeAndMaxLen name) ucols ] let foreigns = do- Column { cName=cname, cReference=Just (refTblName, refConstraintName) } <- newcols- return $ AlterColumn name (refTblName, addReference allDefs refConstraintName refTblName cname)+ Column { cName=cname, cReference= Just ColumnReference{crTableName = refTable, crConstraintName = refConstr, crFieldCascade = cfc }} <- newcols+ return $ AlterColumn name (refTable, addReference allDefs refConstr refTable cname cfc) - let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))- in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs+ let foreignsAlt =+ map+ (\fdef ->+ let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))+ in+ AlterColumn+ name+ ( foreignRefTableDBName fdef+ , AddReference+ (foreignRefTableDBName fdef)+ (foreignConstraintNameDBName fdef)+ childfields+ parentfields+ (foreignFieldCascade fdef)+ )+ )+ fdefs return $ Right $ map showAlterDb $ (addTable newcols val): uniques ++ foreigns ++ foreignsAlt- {- FIXME redundant, why is this here? The whole case expression is weird- -- No errors and something found, migrate- (_, _, ([], old')) -> do- let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of- Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of- Just _ -> c { cReference = Nothing }- Nothing -> c- Nothing -> c) xs,ys)- (acs, ats) = getAlters allDefs name (newcols, udspair) $ excludeForeignKeys $ partitionEithers old'- acs' = map (AlterColumn name) acs- ats' = map (AlterTable name) ats- return $ Right $ map showAlterDb $ acs' ++ ats'- -- Errors- (_, _, (errs, _)) -> return $ Left errs- -} where findTypeAndMaxLen tblName col = let (col', ty) = findTypeOfColumn allDefs tblName col@@ -1308,7 +1508,7 @@ fields = keyAndEntityFields ent putManySql' :: [FieldDef] -> EntityDef -> Int -> Text-putManySql' fields ent n = q+putManySql' (filter isFieldNotGenerated -> fields) ent n = q where fieldDbToText = escape . fieldDB mkAssignment f = T.concat [f, "=VALUES(", f, ")"]@@ -1328,3 +1528,6 @@ , " ON DUPLICATE KEY UPDATE " , Util.commaSeparated updates ]++mysqlMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])+mysqlMkColumns allDefs t = mkColumns allDefs t emptyBackendSpecificOverrides
persistent-mysql.cabal view
@@ -1,5 +1,5 @@ name: persistent-mysql-version: 2.10.2.3+version: 2.10.3 license: MIT license-file: LICENSE author: Felipe Lessa <felipe.lessa@gmail.com>, Michael Snoyman@@ -28,7 +28,7 @@ library build-depends: base >= 4.9 && < 5- , persistent >= 2.10.0 && < 3+ , persistent >= 2.11 && < 3 , aeson >= 1.0 , blaze-builder , bytestring >= 0.10.8
test/CustomConstraintTest.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -10,6 +11,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-}+ module CustomConstraintTest where import MyInit@@ -31,12 +33,18 @@ deriving Show |] -specs :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec+clean :: MonadUnliftIO m => SqlPersistT m ()+clean = do+ rawExecute "drop table custom_constraint3" []+ rawExecute "drop table custom_constraint2" []+ rawExecute "drop table custom_constraint1" []++specs :: (MonadUnliftIO m, MonadFail m) => RunDb SqlBackend m -> Spec specs runDb = do- describe "custom constraint used in migration" $ do+ describe "custom constraint used in migration" $ before_ (runDb $ void $ runMigrationSilent customConstraintMigrate) $ after_ (runDb clean) $ do+ it "custom constraint is actually created" $ runDb $ do- runMigration customConstraintMigrate- runMigration customConstraintMigrate -- run a second time to ensure the constraint isn't dropped+ 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 "@@ -45,16 +53,20 @@ ,"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)+ [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- runMigration customConstraintMigrate- -- | 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.+ -- 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`+ -- This is where the error is thrown in `getColumn` _ <- getMigration customConstraintMigrate pure ()
test/InsertDuplicateUpdate.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}@@ -42,7 +42,7 @@ it "performs only updates given if record already exists" $ db $ do deleteWhere ([] :: [Filter Item]) let newDescription = "I am a new description"- _ <- insert item1+ insert_ item1 insertOnDuplicateKeyUpdate (Item "item1" "i am inserted description" (Just 1) (Just 2)) [ItemDescription =. newDescription]
test/MyInit.hs view
@@ -23,6 +23,7 @@ , module Database.Persist.Sql.Raw.QQ , module Test.Hspec , module Test.HUnit+ , MonadUnliftIO , liftIO , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase , Int32, Int64@@ -110,10 +111,11 @@ , connectDatabase = "test" } 1 $ runSqlPool f else withMySQLPool baseConnectInfo- { connectHost = "localhost"- , connectUser = "travis"- , connectPassword = ""- , connectDatabase = "persistent"+ { connectHost = "127.0.0.1"+ , connectUser = "test"+ , connectPassword = "test"+ , connectDatabase = "test"+ , connectPort = 33306 } 1 $ runSqlPool f return ()
test/main.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}@@ -36,6 +36,7 @@ import qualified MigrationIdempotencyTest import qualified MigrationOnlyTest import qualified MpsNoPrefixTest+import qualified MpsCustomPrefixTest import qualified PersistentTest import qualified PersistUniqueTest -- FIXME: Not used... should it be?@@ -43,12 +44,16 @@ import qualified RawSqlTest import qualified ReadWriteTest import qualified Recursive+-- TODO: can't use this as MySQL can't do DEFAULT CURRENT_DATE import qualified RenameTest import qualified SumTypeTest import qualified TransactionLevelTest import qualified UniqueTest import qualified UpsertTest import qualified CustomConstraintTest+import qualified LongIdentifierTest+import qualified GeneratedColumnTestSQL+import qualified ForeignKey type Tuple a b = (a, b) @@ -96,10 +101,11 @@ <*> (truncateTimeOfDay =<< arbitrary) -- timeFrac <*> (truncateUTCTime =<< arbitrary) -- utcFrac -setup :: MonadIO m => Migration -> ReaderT SqlBackend m ()+setup :: (HasCallStack, MonadUnliftIO m) => Migration -> ReaderT SqlBackend m () setup migration = do printMigration migration- runMigrationUnsafe migration+ _ <- runMigrationUnsafe migration+ pure () main :: IO () main = do@@ -107,6 +113,7 @@ mapM_ setup [ PersistentTest.testMigrate , PersistentTest.noPrefixMigrate+ , PersistentTest.customPrefixMigrate , EmbedTest.embedMigrate , EmbedOrderTest.embedOrderMigrate , LargeNumberTest.numberMigrate@@ -122,11 +129,15 @@ , CustomPrimaryKeyReferenceTest.migration , MigrationColumnLengthTest.migration , TransactionLevelTest.migration+ -- , LongIdentifierTest.migration+ , ForeignKey.compositeMigrate ] PersistentTest.cleanDB+ ForeignKey.cleanDB hspec $ do- RenameTest.specsWith db+ xdescribe "This is pending on MySQL because you can't have DEFAULT CURRENT_DATE" $ do+ RenameTest.specsWith db DataTypeTest.specsWith db (Just (runMigrationSilent dataTypeMigrate))@@ -171,7 +182,9 @@ UpsertTest.Don'tUpdateNull UpsertTest.UpsertPreserveOldKey + ForeignKey.specsWith db MpsNoPrefixTest.specsWith db+ MpsCustomPrefixTest.specsWith db EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) CompositeTest.specsWith db PersistUniqueTest.specsWith db@@ -184,6 +197,10 @@ MigrationIdempotencyTest.specsWith db CustomConstraintTest.specs db+ -- TODO: implement automatic truncation for too long foreign keys, so we can run this test.+ xdescribe "The migration for this test currently fails because of MySQL's 64 character limit for identifiers. See https://github.com/yesodweb/persistent/issues/1000 for details" $+ LongIdentifierTest.specsWith db+ GeneratedColumnTestSQL.specsWith db roundFn :: RealFrac a => a -> Integer roundFn = round