diff --git a/examples/Test1.hs b/examples/Test1.hs index fab2461..f50b2fe 100644 --- a/examples/Test1.hs +++ b/examples/Test1.hs @@ -14,6 +14,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} module Test1 where import qualified Database.Persist as P import Database.Persist.TH diff --git a/examples/TestODBC.hs b/examples/TestODBC.hs index 6f91efa..b547083 100644 --- a/examples/TestODBC.hs +++ b/examples/TestODBC.hs @@ -20,6 +20,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} module Main where import Database.Persist import Database.Persist.ODBC diff --git a/persistent-odbc.cabal b/persistent-odbc.cabal index a9a0f1a..a38478c 100644 --- a/persistent-odbc.cabal +++ b/persistent-odbc.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: persistent-odbc -version: 0.2.1.1 +version: 0.3 synopsis: Backend for the persistent library using ODBC license: MIT license-file: LICENSE @@ -51,8 +51,8 @@ library , HDBC-odbc >= 2.6.0.0 , monad-logger , resourcet - , persistent-template >= 2.6.0 && < 2.8.3 - , persistent >= 2.6.0 && < 2.11 + , persistent-template >= 2.6.0 && < 2.13 + , persistent >= 2.12 && < 2.13 , bytestring @@ -79,8 +79,8 @@ Executable TestODBC , HDBC-odbc >= 2.6.0.0 , monad-logger , resourcet - , persistent-template >= 2.6.0 && < 2.8.3 - , persistent >= 2.6.0 && < 2.11 + , persistent-template >= 2.6.0 && < 2.13 + , persistent >= 2.12 && < 2.13 , bytestring else buildable: False @@ -91,4 +91,4 @@ Executable TestODBC source-repository head type: git - location: git://github.com/gbwey/persistent-odbc.git + location: https://github.com/gbwey/persistent-odbc diff --git a/src/Database/Persist/MigrateDB2.hs b/src/Database/Persist/MigrateDB2.hs index d8bc79e..b1f6494 100644 --- a/src/Database/Persist/MigrateDB2.hs +++ b/src/Database/Persist/MigrateDB2.hs @@ -43,7 +43,9 @@ getMigrationStrategy dbtype@DB2 {} = { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT 99999999" ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' - ,dbmsEscape=T.pack . escapeDBName + ,dbmsEscapeFieldName = T.pack . escapeDBName + ,dbmsEscapeTableName = T.pack . escapeDBName . entityDB + ,dbmsEscapeRawName = T.pack . escapeDBName . FieldNameDB ,dbmsType=dbtype } getMigrationStrategy dbtype = error $ "DB2: calling with invalid dbtype " ++ show dbtype @@ -57,7 +59,8 @@ migrate' :: [EntityDef] migrate' allDefs getter val = do let name = entityDB val (idClmn, old) <- getColumns getter val - let (newcols, udefs, fdefs) = mkColumns allDefs val + let (newcols, udefs, fdefs) = + mkColumns allDefs val emptyBackendSpecificOverrides {- liftIO $ do putStrLn $ "\nold=" ++ show (length old) @@ -91,18 +94,22 @@ migrate' allDefs getter val = do AddUniqueConstraint uname $ map (findTypeOfColumn allDefs name) ucols ] let foreigns = tracex ("in migrate' newcols=" ++ show newcols) $ do - Column { cName=cname, cReference=Just (refTblName, a) } <- newcols + Column { cName=cname, cReference=Just cRef } <- newcols + let refTblName = crTableName cRef + let a = crConstraintName cRef tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ - return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) + return $ AlterColumn name (addReference allDefs (refName name cname) refTblName cname) let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + in AlterColumn name (AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ map showAlterDb $ addTable : 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 cRef -> + let fk = crConstraintName cRef in + case find (\f -> fk == foreignConstraintNameDBName f) fdefs of Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ c { cReference = Nothing } Nothing -> c @@ -114,12 +121,13 @@ migrate' allDefs getter val = do -- Errors (_, _, (errs, _)) -> return $ Left errs -pkeyName :: DBName -> DBName -pkeyName (DBName table) = - DBName $ T.concat [table, "_pkey"] +pkeyName :: EntityNameDB -> ConstraintNameDB +pkeyName (EntityNameDB table) = + ConstraintNameDB $ T.concat [table, "_pkey"] -- | Find out the type of a column. -findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn :: + [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType) findTypeOfColumn allDefs name col = maybe (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++ @@ -131,7 +139,7 @@ findTypeOfColumn allDefs name col = -- | Helper for 'AddRefence' that finds out the 'entityId'. -addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn +addReference :: [EntityDef] -> ConstraintNameDB -> EntityNameDB -> FieldNameDB -> AlterColumn addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ AddReference reftable fkeyname [cname] [id_] where @@ -141,28 +149,27 @@ addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname=" entDef <- find ((== reftable) . entityDB) allDefs return (fieldDB (entityId entDef)) -data AlterColumn = Change Column - | IsNull - | NotNull - | Add' Column - | Drop - | Default String - | NoDefault - | Update' String - | AddReference DBName DBName [DBName] [DBName] - | DropReference DBName - -type AlterColumn' = (DBName, AlterColumn) - -data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType)] - | DropUniqueConstraint DBName +data AlterColumn = + Change FieldNameDB Column + | IsNull FieldNameDB + | NotNull FieldNameDB + | Add' Column + | Drop FieldNameDB + | Default FieldNameDB String + | NoDefault FieldNameDB + | Update' FieldNameDB String + | AddReference EntityNameDB ConstraintNameDB [FieldNameDB] [FieldNameDB] + | DropReference ConstraintNameDB + +data AlterTable = + AddUniqueConstraint ConstraintNameDB [(FieldNameDB, FieldType)] + | DropUniqueConstraint ConstraintNameDB data AlterDB = AddTable String - | AlterColumn DBName AlterColumn' - | AlterTable DBName AlterTable - + | AlterColumn EntityNameDB AlterColumn + | AlterTable EntityNameDB AlterTable -udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) ---------------------------------------------------------------------- @@ -172,8 +179,8 @@ udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) -- in the database. getColumns :: (Text -> IO Statement) -> EntityDef - -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column - , [Either Text (Either Column (DBName, [DBName]))] -- everything else + -> IO ( [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] -- ID column + , [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] -- everything else ) getColumns getter def = do -- Find out ID column. @@ -242,8 +249,8 @@ getColumns getter def = do -- Return both return (ids, cs ++ us) where - vals = [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ fieldDB $ entityId def ] + vals = [ PersistText $ unEntityNameDB $ entityDB def + , PersistText $ unFieldNameDB $ fieldDB $ entityId def ] helperClmns = CL.mapM getIt .| CL.consume where @@ -257,13 +264,13 @@ getColumns getter def = do , T.decodeUtf8 clmnName ) check other = fail $ "helperCntrs: unexpected " ++ show other rows <- mapM check =<< CL.consume - return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) + return $ map (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd))) $ groupBy ((==) `on` fst) rows -- | Get the information about a column in a table. getColumn :: (Text -> IO Statement) - -> DBName + -> EntityNameDB -> [PersistValue] -> IO (Either Text Column) getColumn getter tname [ PersistByteString cname @@ -299,7 +306,7 @@ getColumn getter tname [ PersistByteString cname ,"AND trim(fk_colnames)=? " ,"order by constname, fk_colnames " ] - let vars = [ PersistText $ unDBName tname + let vars = [ PersistText $ unEntityNameDB tname , PersistByteString cname ] cntrs <- liftIO $ with (stmtQuery stmt vars) (`connect` CL.consume) @@ -307,14 +314,15 @@ getColumn getter tname [ PersistByteString cname [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> tracex ("\n\n\nGBREF "++show (tab,ref,pos)++"\n\n") $ - return $ Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) + return $ Just $ ColumnReference (EntityNameDB $ T.decodeUtf8 tab) (ConstraintNameDB $ T.decodeUtf8 ref) noCascade a1 -> fail $ "DB2.getColumn/getRef: never here error[" ++ show a1 ++ "]" -- Okay! return Column - { cName = DBName $ T.decodeUtf8 cname + { cName = FieldNameDB $ T.decodeUtf8 cname , cNull = null_ == "Y" , cSqlType = type_ + , cGenerated = Nothing , cDefault = default_ , cDefaultConstraintName = Nothing , cMaxLen = Nothing -- FIXME: maxLen @@ -354,10 +362,10 @@ getNumeric a b = error $ "Can not get numeric field precision, got: " ++ show a -- | @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]) + -> EntityNameDB + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([AlterColumn], [AlterTable]) getAlters allDefs tblName (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where @@ -367,9 +375,8 @@ getAlters allDefs tblName (c1, u1) (c2, u2) = in alters ++ getAltersC news old' dropColumn col = - map ((,) (cName col)) $ - [DropReference n | Just (_, n) <- [cReference col]] ++ - [Drop] + [DropReference (crConstraintName cRef) | Just cRef <- [cReference col]] ++ + [Drop (cName col)] getAltersU [] old = map (DropUniqueConstraint . fst) old getAltersU ((name, cols):news) old = @@ -390,34 +397,42 @@ getAlters allDefs tblName (c1, u1) (c2, u2) = -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName _maxLen ref) cols = +findAlters :: EntityNameDB -> [EntityDef] -> Column -> [Column] -> ([AlterColumn], [Column]) +findAlters tblName allDefs col@(Column name isNull type_ def _generated _defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of [] -> case ref of - Nothing -> ([(name, Add' col)], []) - Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ + Nothing -> ([Add' col], []) + Just (ColumnReference tname b _) -> + let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ [addReference allDefs (refName tblName name) tname name] - in (map ((,) name) (Add' col : cnstr), cols) - Column _ isNull' type_' def' _defConstraintName' _maxLen' ref':_ -> + in ((Add' col : cnstr), cols) + Column _ isNull' type_' def' _generated _defConstraintName' _maxLen' ref':_ -> let -- Foreign key - refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ - [(name, DropReference cname)] - _ -> [] - refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ - [(tname, addReference allDefs (refName tblName name) tname name)] - _ -> [] + refDrop = + case (ref == ref', ref') of + (False, Just cRef) -> + let cname = crConstraintName cRef in + tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ + [DropReference cname] + _ -> [] + refAdd = + case (ref == ref', ref) of + (False, Just cRef) -> + let tname = crTableName cRef in + let cname = crConstraintName cRef in + tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ + [addReference allDefs (refName tblName name) tname name] + _ -> [] -- Type and nullability modType | tpcheck type_ type_' && isNull == isNull' = [] - | otherwise = [(name, Change col)] + | otherwise = [Change name col] -- Default value modDef | cmpdef def def' = [] | otherwise = --tracex ("findAlters col=" ++ show col ++ " def=" ++ show def ++ " def'=" ++ show def') $ case def of - Nothing -> [(name, NoDefault)] - Just s -> [(name, Default $ T.unpack s)] + Nothing -> [NoDefault name] + Just s -> [Default name $ T.unpack s] in ( refDrop ++ modType ++ modDef ++ refAdd , filter ((name /=) . cName) cols ) @@ -442,7 +457,7 @@ tpcheck a b = a==b -- | 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 _generated _defConstraintName maxLen _ref) = concat [ escapeDBName n , " " , showSqlType t maxLen @@ -476,16 +491,16 @@ showSqlType (SqlOther t) _ = T.unpack t -- | Render an action that must be done on the database. showAlterDb :: AlterDB -> (Bool, Text) showAlterDb (AddTable s) = (False, pack s) -showAlterDb (AlterColumn t (c, ac)) = - (isUnsafe ac, pack $ showAlter t (c, ac)) +showAlterDb (AlterColumn t ac) = + (isUnsafe ac, pack $ showAlter t ac) where - isUnsafe Drop = True - isUnsafe _ = False + isUnsafe (Drop _) = True + isUnsafe _ = False showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) -- | Render an action that must be done on a table. -showAlterTable :: DBName -> AlterTable -> String +showAlterTable :: EntityNameDB -> AlterTable -> String showAlterTable table (AddUniqueConstraint cname cols) = concat [ "ALTER TABLE " , escapeDBName table @@ -509,8 +524,8 @@ showAlterTable table (DropUniqueConstraint cname) = concat -- | 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 :: EntityNameDB -> AlterColumn -> String +showAlter table (Change oldName (Column _n _nu t _def _generated _defConstraintName _maxLen _ref)) = concat [ "ALTER TABLE " , escapeDBName table @@ -519,7 +534,7 @@ showAlter table (oldName, Change (Column _n _nu t _def _defConstraintName _maxLe , " SET DATA TYPE " , showSqlType t Nothing ] -showAlter table (n, IsNull) = +showAlter table (IsNull n) = concat [ "ALTER TABLE " , escapeDBName table @@ -527,7 +542,7 @@ showAlter table (n, IsNull) = , escapeDBName n , " DROP NOT NULL" ] -showAlter table (n, NotNull) = +showAlter table (NotNull n) = concat [ "ALTER TABLE " , escapeDBName table @@ -535,21 +550,21 @@ showAlter table (n, NotNull) = , escapeDBName n , " SET NOT NULL" ] -showAlter table (_, Add' col) = +showAlter table (Add' col) = concat [ "ALTER TABLE " , escapeDBName table , " ADD COLUMN " , showColumn col ] -showAlter table (n, Drop) = +showAlter table (Drop n) = concat [ "ALTER TABLE " , escapeDBName table , " DROP COLUMN " , escapeDBName n ] -showAlter table (n, Default s) = +showAlter table (Default n s) = concat [ "ALTER TABLE " , escapeDBName table @@ -558,7 +573,7 @@ showAlter table (n, Default s) = , " SET DEFAULT " , s ] -showAlter table (n, NoDefault) = +showAlter table (NoDefault n) = concat [ "ALTER TABLE " , escapeDBName table @@ -566,7 +581,7 @@ showAlter table (n, NoDefault) = , escapeDBName n , " DROP DEFAULT" ] -showAlter table (n, Update' s) = +showAlter table (Update' n s) = concat [ "UPDATE " , escapeDBName table @@ -578,7 +593,7 @@ showAlter table (n, Update' s) = , escapeDBName n , " IS NULL" ] -showAlter table (_, AddReference reftable fkeyname t2 id2) = concat +showAlter table (AddReference reftable fkeyname t2 id2) = concat [ "ALTER TABLE " , escapeDBName table , " ADD CONSTRAINT " @@ -591,23 +606,24 @@ showAlter table (_, AddReference reftable fkeyname t2 id2) = concat , intercalate "," $ map escapeDBName id2 , ")" ] -showAlter table (_, DropReference cname) = concat +showAlter table (DropReference cname) = concat [ "ALTER TABLE " , escapeDBName table , " DROP CONSTRAINT " , escapeDBName cname ] -refName :: DBName -> DBName -> DBName -refName (DBName table) (DBName column) = - DBName $ T.concat [table, "_", column, "_fkey"] +refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB +refName (EntityNameDB table) (FieldNameDB column) = + ConstraintNameDB $ T.concat [table, "_", column, "_fkey"] ---------------------------------------------------------------------- -- | Escape a database name to be included on a query. -escapeDBName :: DBName -> String -escapeDBName (DBName s) = '"' : go (T.unpack s) +escapeDBName :: DatabaseName name => name -> String +escapeDBName = + escapeWith $ \s -> '"' : go (T.unpack s) where go ('"':xs) = '"' : '"' : go xs go ( x :xs) = x : go xs diff --git a/src/Database/Persist/MigrateMSSQL.hs b/src/Database/Persist/MigrateMSSQL.hs index e3cf30d..3a32867 100644 --- a/src/Database/Persist/MigrateMSSQL.hs +++ b/src/Database/Persist/MigrateMSSQL.hs @@ -44,7 +44,9 @@ getMigrationStrategy dbtype@MSSQL { mssql2012=ok } = { dbmsLimitOffset=limitOffset ok ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' - ,dbmsEscape=T.pack . escapeDBName + ,dbmsEscapeFieldName = T.pack . escapeDBName + ,dbmsEscapeTableName = T.pack . escapeDBName . entityDB + ,dbmsEscapeRawName = T.pack . escapeDBName . FieldNameDB ,dbmsType=dbtype } getMigrationStrategy dbtype = error $ "MSSQL: calling with invalid dbtype " ++ show dbtype @@ -58,7 +60,8 @@ migrate' :: [EntityDef] migrate' allDefs getter val = do let name = entityDB val (idClmn, old) <- getColumns getter val - let (newcols, udefs, fdefs) = mkColumns allDefs val + let (newcols, udefs, fdefs) = + mkColumns allDefs val emptyBackendSpecificOverrides {- liftIO $ do putStrLn $ "\nold=" ++ show (length old) @@ -89,18 +92,22 @@ migrate' allDefs getter val = do AddUniqueConstraint uname $ map (findTypeOfColumn allDefs name) ucols ] let foreigns = tracex ("in migrate' newcols=" ++ show newcols) $ do - Column { cName=cname, cReference=Just (refTblName, a) } <- newcols + Column { cName=cname, cReference=Just cRef } <- newcols + let refTblName = crTableName cRef + let a = crConstraintName cRef tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ - return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) + return $ AlterColumn name (addReference allDefs (refName name cname) refTblName cname) let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + in AlterColumn name (AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ map showAlterDb $ addTable : 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 cRef -> + let fk = crConstraintName cRef in + case find (\f -> fk == foreignConstraintNameDBName f) fdefs of Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ c { cReference = Nothing } Nothing -> c @@ -114,7 +121,8 @@ migrate' allDefs getter val = do -- | Find out the type of a column. -findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn :: + [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType) findTypeOfColumn allDefs name col = maybe (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++ @@ -126,7 +134,7 @@ findTypeOfColumn allDefs name col = -- | Helper for 'AddRefence' that finds out the 'entityId'. -addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn +addReference :: [EntityDef] -> ConstraintNameDB -> EntityNameDB -> FieldNameDB -> AlterColumn addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ AddReference reftable fkeyname [cname] [id_] where @@ -136,26 +144,25 @@ addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname=" entDef <- find ((== reftable) . entityDB) allDefs return (fieldDB $ entityId entDef) -data AlterColumn = Change Column - | Add' Column - | Drop - | Default String - | NoDefault DBName - | Update' String - | AddReference DBName DBName [DBName] [DBName] - | DropReference DBName +data AlterColumn = + Change Column + | Add' Column + | Drop FieldNameDB + | Default FieldNameDB String + | NoDefault ConstraintNameDB + | Update' FieldNameDB String + | AddReference EntityNameDB ConstraintNameDB [FieldNameDB] [FieldNameDB] + | DropReference ConstraintNameDB -type AlterColumn' = (DBName, AlterColumn) - -data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType)] - | DropUniqueConstraint DBName +data AlterTable = + AddUniqueConstraint ConstraintNameDB [(FieldNameDB, FieldType)] + | DropUniqueConstraint ConstraintNameDB data AlterDB = AddTable String - | AlterColumn DBName AlterColumn' - | AlterTable DBName AlterTable - + | AlterColumn EntityNameDB AlterColumn + | AlterTable EntityNameDB AlterTable -udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) ---------------------------------------------------------------------- @@ -165,8 +172,8 @@ udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) -- in the database. getColumns :: (Text -> IO Statement) -> EntityDef - -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column - , [Either Text (Either Column (DBName, [DBName]))] -- everything else + -> IO ( [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] -- ID column + , [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] -- everything else ) getColumns getter def = do -- Find out ID column. @@ -224,8 +231,8 @@ getColumns getter def = do -- Return both return (ids, cs ++ us) where - vals = [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ fieldDB $ entityId def ] + vals = [ PersistText $ unEntityNameDB $ entityDB def + , PersistText $ unFieldNameDB $ fieldDB $ entityId def ] helperClmns = CL.mapM getIt .| CL.consume where @@ -239,13 +246,13 @@ getColumns getter def = do , T.decodeUtf8 clmnName ) check other = fail $ "helperCntrs: unexpected " ++ show other rows <- mapM check =<< CL.consume - return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) + return $ map (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd))) $ groupBy ((==) `on` fst) rows -- | Get the information about a column in a table. getColumn :: (Text -> IO Statement) - -> DBName + -> EntityNameDB -> [PersistValue] -> IO (Either Text Column) getColumn getter tname [ PersistByteString cname @@ -270,13 +277,13 @@ getColumn getter tname [ PersistByteString cname -- Default Constraint name defaultConstraintName_ <- case defaultConstraintName' of PersistNull -> return Nothing - PersistText t -> return $ Just $ DBName t + PersistText t -> return $ Just $ ConstraintNameDB t PersistByteString bs -> case T.decodeUtf8' bs of Left exc -> fail $ "Invalid default constraintname: " ++ show defaultConstraintName' ++ " (error: " ++ show exc ++ ")" - Right t -> return $ Just $ DBName t + Right t -> return $ Just $ ConstraintNameDB t _ -> fail $ "Invalid default constraint name: " ++ show defaultConstraintName' -- Column type type_ <- parseType type' @@ -298,7 +305,7 @@ getColumn getter tname [ PersistByteString cname ,"where KCU1.TABLE_NAME = ? and KCU1.COLUMN_NAME = ? " ,"order by CONSTRAINT_NAME, KCU1.COLUMN_NAME"] - let vars = [ PersistText $ unDBName tname + let vars = [ PersistText $ unEntityNameDB tname , PersistText $ T.decodeUtf8 cname ] cntrs <- liftIO $ with (stmtQuery stmt vars) (`connect` CL.consume) @@ -306,14 +313,15 @@ getColumn getter tname [ PersistByteString cname [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> tracex ("\n\n\nGBREF "++show (tab,ref,pos)++"\n\n") $ - return $ Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) + return $ Just $ ColumnReference (EntityNameDB $ T.decodeUtf8 tab) (ConstraintNameDB $ T.decodeUtf8 ref) noCascade a1 -> fail $ "MSSQL.getColumn/getRef: never here error[" ++ show a1 ++ "]" -- Okay! return Column - { cName = DBName $ T.decodeUtf8 cname + { cName = FieldNameDB $ T.decodeUtf8 cname , cNull = null_ == "YES" , cSqlType = type_ + , cGenerated = Nothing , cDefault = default_ , cDefaultConstraintName = defaultConstraintName_ , cMaxLen = Nothing -- FIXME: maxLen @@ -372,10 +380,10 @@ parseType b = error $ "no idea how to handle this type b=" ++ show b -- | @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]) + -> EntityNameDB + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([AlterColumn], [AlterTable]) getAlters allDefs tblName (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where @@ -385,9 +393,8 @@ getAlters allDefs tblName (c1, u1) (c2, u2) = in alters ++ getAltersC news old' dropColumn col = - map ((,) (cName col)) $ - [DropReference n | Just (_, n) <- [cReference col]] ++ - [Drop] + [DropReference (crConstraintName cRef) | Just cRef <- [cReference col]] ++ + [Drop (cName col)] getAltersU [] old = map (DropUniqueConstraint . fst) old getAltersU ((name, cols):news) old = @@ -408,34 +415,42 @@ getAlters allDefs tblName (c1, u1) (c2, u2) = -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters tblName allDefs col@(Column name isNull type_ def defConstraintName _maxLen ref) cols = +findAlters :: EntityNameDB -> [EntityDef] -> Column -> [Column] -> ([AlterColumn], [Column]) +findAlters tblName allDefs col@(Column name isNull type_ def _generated defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of [] -> case ref of - Nothing -> ([(name, Add' col)], []) - Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ + Nothing -> ([Add' col], []) + Just (ColumnReference tname b _) -> + let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ [addReference allDefs (refName tblName name) tname name] - in (map ((,) name) (Add' col : cnstr), cols) - Column _ isNull' type_' def' defConstraintName' _maxLen' ref':_ -> + in (Add' col : cnstr, cols) + Column _ isNull' type_' def' _generated defConstraintName' _maxLen' ref':_ -> let -- Foreign key - refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ - [(name, DropReference cname)] - _ -> [] - refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ - [(tname, addReference allDefs (refName tblName name) tname name)] - _ -> [] + refDrop = + case (ref == ref', ref') of + (False, Just cRef) -> + let cname = crConstraintName cRef in + tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ + [DropReference cname] + _ -> [] + refAdd = + case (ref == ref', ref) of + (False, Just cRef) -> + let tname = crTableName cRef in + let cname = crConstraintName cRef in + tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ + [addReference allDefs (refName tblName name) tname name] + _ -> [] -- Type and nullability modType | tpcheck type_ type_' && isNull == isNull' = [] - | otherwise = [(name, Change col)] + | otherwise = [Change col] -- Default value modDef | def == def' = [] | otherwise = tracex ("\n\nfindAlters modDef col=" ++ show col ++ " name=" ++ show name ++ " def=" ++ show def ++ " def'=" ++ show def' ++ " defConstraintName=" ++ show defConstraintName++" defConstraintName'=" ++ show defConstraintName' ++ "\n\n") $ case def of - Nothing -> [(name, NoDefault $ maybe (error $ "expected a constraint name col="++show name) id defConstraintName')] - Just s -> if cmpdef def def' then [] else [(name, Default $ T.unpack s)] + Nothing -> [NoDefault $ maybe (error $ "expected a constraint name col="++show name) id defConstraintName'] + Just s -> if cmpdef def def' then [] else [Default name $ T.unpack s] in ( refDrop ++ modType ++ modDef ++ refAdd , filter ((name /=) . cName) cols ) @@ -455,7 +470,7 @@ tpcheck a b = a==b -- | 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 _generated _defConstraintName maxLen _ref) = concat [ escapeDBName n , " " , showSqlType t maxLen @@ -489,16 +504,16 @@ showSqlType (SqlOther t) _ = error ("showSqlType unhandled type t="++show -- | Render an action that must be done on the database. showAlterDb :: AlterDB -> (Bool, Text) showAlterDb (AddTable s) = (False, pack s) -showAlterDb (AlterColumn t (c, ac)) = - (isUnsafe ac, pack $ showAlter t (c, ac)) +showAlterDb (AlterColumn t ac) = + (isUnsafe ac, pack $ showAlter t ac) where - isUnsafe Drop = True - isUnsafe _ = False + isUnsafe (Drop _) = True + isUnsafe _ = False showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) -- | Render an action that must be done on a table. -showAlterTable :: DBName -> AlterTable -> String +showAlterTable :: EntityNameDB -> AlterTable -> String showAlterTable table (AddUniqueConstraint cname cols) = concat [ "ALTER TABLE " , escapeDBName table @@ -517,29 +532,29 @@ showAlterTable table (DropUniqueConstraint cname) = concat -- | 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 :: EntityNameDB -> AlterColumn -> String +showAlter table (Change (Column n nu t def generated defConstraintName maxLen _ref)) = concat [ "ALTER TABLE " , escapeDBName table , " ALTER COLUMN " - , showColumn (Column n nu t def defConstraintName maxLen Nothing) + , showColumn (Column n nu t def generated defConstraintName maxLen Nothing) ] -showAlter table (_, Add' col) = +showAlter table (Add' col) = concat [ "ALTER TABLE " , escapeDBName table , " ADD " , showColumn col ] -showAlter table (n, Drop) = +showAlter table (Drop n) = concat [ "ALTER TABLE " , escapeDBName table , " DROP COLUMN " , escapeDBName n ] -showAlter table (n, Default s) = +showAlter table (Default n s) = concat [ "ALTER TABLE " , escapeDBName table @@ -548,14 +563,14 @@ showAlter table (n, Default s) = , " FOR " , escapeDBName n ] -showAlter table (_n, NoDefault defConstraintName) = +showAlter table (NoDefault defConstraintName) = concat [ "ALTER TABLE " , escapeDBName table , " DROP CONSTRAINT " , escapeDBName defConstraintName ] -showAlter table (n, Update' s) = +showAlter table (Update' n s) = concat [ "UPDATE " , escapeDBName table @@ -567,7 +582,7 @@ showAlter table (n, Update' s) = , escapeDBName n , " IS NULL" ] -showAlter table (_, AddReference reftable fkeyname t2 id2) = concat +showAlter table (AddReference reftable fkeyname t2 id2) = concat [ "ALTER TABLE " , escapeDBName table , " ADD CONSTRAINT " @@ -580,23 +595,24 @@ showAlter table (_, AddReference reftable fkeyname t2 id2) = concat , intercalate "," $ map escapeDBName id2 , ")" ] -showAlter table (_, DropReference cname) = concat +showAlter table (DropReference cname) = concat [ "ALTER TABLE " , escapeDBName table , " DROP CONSTRAINT " , escapeDBName cname ] -refName :: DBName -> DBName -> DBName -refName (DBName table) (DBName column) = - DBName $ T.concat [table, "_", column, "_fkey"] +refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB +refName (EntityNameDB table) (FieldNameDB column) = + ConstraintNameDB $ T.concat [table, "_", column, "_fkey"] ---------------------------------------------------------------------- -- | Escape a database name to be included on a query. -escapeDBName :: DBName -> String -escapeDBName (DBName s) = '[' : go (T.unpack s) +escapeDBName :: DatabaseName name => name -> String +escapeDBName = + escapeWith $ \s -> '[' : go (T.unpack s) where go (']':xs) = ']' : ']' : go xs go ( x :xs) = x : go xs diff --git a/src/Database/Persist/MigrateMySQL.hs b/src/Database/Persist/MigrateMySQL.hs index 1544dd8..902646c 100644 --- a/src/Database/Persist/MigrateMySQL.hs +++ b/src/Database/Persist/MigrateMySQL.hs @@ -45,7 +45,10 @@ getMigrationStrategy dbtype@MySQL {} = { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT 18446744073709551615" ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' - ,dbmsEscape=T.pack . escapeDBName + ,dbmsEscapeFieldName = T.pack . escapeDBName + ,dbmsEscapeTableName = + T.pack . escapeDBName . entityDB + ,dbmsEscapeRawName = T.pack . escapeDBName . FieldNameDB ,dbmsType=dbtype } getMigrationStrategy dbtype = error $ "MySQL: calling with invalid dbtype " ++ show dbtype @@ -59,7 +62,8 @@ migrate' :: [EntityDef] migrate' allDefs getter val = do let name = entityDB val (idClmn, old) <- getColumns getter val - let (newcols, udefs, fdefs) = mkColumns allDefs val + let (newcols, udefs, fdefs) = + mkColumns allDefs val emptyBackendSpecificOverrides {- liftIO $ do putStrLn $ "\nold=" ++ show (length old) @@ -91,18 +95,22 @@ migrate' allDefs getter val = do AddUniqueConstraint uname $ map (findTypeOfColumn allDefs name) ucols ] let foreigns = tracex ("in migrate' newcols=" ++ show newcols) $ do - Column { cName=cname, cReference=Just (refTblName, a) } <- newcols + Column { cName=cname, cReference=Just cRef } <- newcols + let refTblName = crTableName cRef + let a = crConstraintName cRef tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ - return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) + return $ AlterColumn name (addReference allDefs (refName name cname) refTblName cname) let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + in AlterColumn name (AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ map showAlterDb $ addTable : 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 cRef -> + let fk = crConstraintName cRef in + case find (\f -> fk == foreignConstraintNameDBName f) fdefs of Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ c { cReference = Nothing } Nothing -> c @@ -116,7 +124,8 @@ migrate' allDefs getter val = do -- | Find out the type of a column. -findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn :: + [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType) findTypeOfColumn allDefs name col = maybe (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++ @@ -128,7 +137,7 @@ findTypeOfColumn allDefs name col = -- | Helper for 'AddRefence' that finds out the 'entityId'. -addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn +addReference :: [EntityDef] -> ConstraintNameDB -> EntityNameDB -> FieldNameDB -> AlterColumn addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ AddReference reftable fkeyname [cname] [id_] where @@ -138,26 +147,25 @@ addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname=" entDef <- find ((== reftable) . entityDB) allDefs return (fieldDB $ entityId entDef) -data AlterColumn = Change Column - | Add' Column - | Drop - | Default String - | NoDefault - | Update' String - | AddReference DBName DBName [DBName] [DBName] - | DropReference DBName +data AlterColumn = + Change FieldNameDB Column + | Add' Column + | Drop FieldNameDB + | Default FieldNameDB String + | NoDefault FieldNameDB + | Update' FieldNameDB String + | AddReference EntityNameDB ConstraintNameDB [FieldNameDB] [FieldNameDB] + | DropReference ConstraintNameDB -type AlterColumn' = (DBName, AlterColumn) - -data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType)] - | DropUniqueConstraint DBName +data AlterTable = + AddUniqueConstraint ConstraintNameDB [(FieldNameDB, FieldType)] + | DropUniqueConstraint ConstraintNameDB data AlterDB = AddTable String - | AlterColumn DBName AlterColumn' - | AlterTable DBName AlterTable - + | AlterColumn EntityNameDB AlterColumn + | AlterTable EntityNameDB AlterTable -udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) ---------------------------------------------------------------------- @@ -167,8 +175,8 @@ udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) -- in the database. getColumns :: (Text -> IO Statement) -> EntityDef - -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column - , [Either Text (Either Column (DBName, [DBName]))] -- everything else + -> IO ( [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] -- ID column + , [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] -- everything else ) getColumns getter def = do -- Find out ID column. @@ -220,8 +228,8 @@ getColumns getter def = do -- Return both return (ids, cs ++ us) where - vals = [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ fieldDB $ entityId def ] + vals = [ PersistText $ unEntityNameDB $ entityDB def + , PersistText $ unFieldNameDB $ fieldDB $ entityId def ] helperClmns = CL.mapM getIt .| CL.consume where @@ -235,13 +243,13 @@ getColumns getter def = do , T.decodeUtf8 clmnName ) check other = fail $ "helperCntrs: unexpected " ++ show other rows <- mapM check =<< CL.consume - return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) + return $ map (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd))) $ groupBy ((==) `on` fst) rows -- | Get the information about a column in a table. getColumn :: (Text -> IO Statement) - -> DBName + -> EntityNameDB -> [PersistValue] -> IO (Either Text Column) getColumn getter tname [ PersistByteString cname @@ -278,7 +286,7 @@ getColumn getter tname [ PersistByteString cname ,"and ordinal_position = 1 " ,"ORDER BY CONSTRAINT_NAME, " ,"COLUMN_NAME"] - let vars = [ PersistText $ unDBName tname + let vars = [ PersistText $ unEntityNameDB tname , PersistByteString cname ] cntrs <- liftIO $ with (stmtQuery stmt vars) (`connect` CL.consume) @@ -286,14 +294,15 @@ getColumn getter tname [ PersistByteString cname [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> tracex ("\n\n\nGBREF "++show (tab,ref,pos)++"\n\n") $ - return $ Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) + return $ Just $ ColumnReference (EntityNameDB $ T.decodeUtf8 tab) (ConstraintNameDB $ T.decodeUtf8 ref) noCascade a1 -> fail $ "MySQL.getColumn/getRef: never here error[" ++ show a1 ++ "]" -- Okay! return Column - { cName = DBName $ T.decodeUtf8 cname + { cName = FieldNameDB $ T.decodeUtf8 cname , cNull = null_ == "YES" , cSqlType = type_ + , cGenerated = Nothing , cDefault = default_ , cDefaultConstraintName = Nothing , cMaxLen = Nothing -- FIXME: maxLen @@ -351,10 +360,10 @@ parseType b = error $ "no idea how to handle this type b=" ++ show b -- | @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]) + -> EntityNameDB + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([AlterColumn], [AlterTable]) getAlters allDefs tblName (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where @@ -364,9 +373,8 @@ getAlters allDefs tblName (c1, u1) (c2, u2) = in alters ++ getAltersC news old' dropColumn col = - map ((,) (cName col)) $ - [DropReference n | Just (_, n) <- [cReference col]] ++ - [Drop] + [DropReference (crConstraintName cRef) | Just cRef <- [cReference col]] ++ + [Drop (cName col)] getAltersU [] old = map (DropUniqueConstraint . fst) old getAltersU ((name, cols):news) old = @@ -387,34 +395,42 @@ getAlters allDefs tblName (c1, u1) (c2, u2) = -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters tblName allDefs col@(Column name isNull type_ def defConstraintName _maxLen ref) cols = +findAlters :: EntityNameDB -> [EntityDef] -> Column -> [Column] -> ([AlterColumn], [Column]) +findAlters tblName allDefs col@(Column name isNull type_ def _generated defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of [] -> case ref of - Nothing -> ([(name, Add' col)], []) - Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ + Nothing -> ([Add' col], []) + Just (ColumnReference tname b _) -> + let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ [addReference allDefs (refName tblName name) tname name] - in (map ((,) name) (Add' col : cnstr), cols) - Column _ isNull' type_' def' defConstraintName' _maxLen' ref':_ -> + in (Add' col : cnstr, cols) + Column _ isNull' type_' def' _generated defConstraintName' _maxLen' ref':_ -> let -- Foreign key - refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ - [(name, DropReference cname)] - _ -> [] - refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ - [(tname, addReference allDefs (refName tblName name) tname name)] - _ -> [] + refDrop = + case (ref == ref', ref') of + (False, Just cRef) -> + let cname = crConstraintName cRef in + tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ + [DropReference cname] + _ -> [] + refAdd = + case (ref == ref', ref) of + (False, Just cRef) -> + let tname = crTableName cRef in + let cname = crConstraintName cRef in + tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ + [addReference allDefs (refName tblName name) tname name] + _ -> [] -- Type and nullability modType | tpcheck type_ type_' && isNull == isNull' = [] - | otherwise = [(name, Change col)] + | otherwise = [Change name col] -- Default value modDef | cmpdef def def' = [] | otherwise = tracex ("\n\nfindAlters modDef col=" ++ show col ++ " name=" ++ show name ++ " def=" ++ show def ++ " def'=" ++ show def' ++ " defConstraintName=" ++ show defConstraintName++" defConstraintName'=" ++ show defConstraintName' ++ "\n\n") $ case def of - Nothing -> [(name, NoDefault)] - Just s -> [(name, Default $ T.unpack s)] + Nothing -> [NoDefault name] + Just s -> [Default name $ T.unpack s] in ( refDrop ++ modType ++ modDef ++ refAdd , filter ((name /=) . cName) cols ) @@ -436,7 +452,7 @@ tpcheck a b = a==b -- | 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 _generated _defConstraintName maxLen ref) = concat [ escapeDBName n , " " , showSqlType t maxLen @@ -447,7 +463,7 @@ showColumn (Column n nu t def _defConstraintName maxLen ref) = concat Just s -> " DEFAULT " ++ T.unpack s , case ref of Nothing -> "" - Just (s, _) -> " REFERENCES " ++ escapeDBName s + Just cRef -> " REFERENCES " ++ escapeDBName (crTableName cRef) ] @@ -473,16 +489,16 @@ showSqlType (SqlOther t) _ = T.unpack t -- | Render an action that must be done on the database. showAlterDb :: AlterDB -> (Bool, Text) showAlterDb (AddTable s) = (False, pack s) -showAlterDb (AlterColumn t (c, ac)) = - (isUnsafe ac, pack $ showAlter t (c, ac)) +showAlterDb (AlterColumn t ac) = + (isUnsafe ac, pack $ showAlter t ac) where - isUnsafe Drop = True - isUnsafe _ = False + isUnsafe (Drop _) = True + isUnsafe _ = False showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) -- | Render an action that must be done on a table. -showAlterTable :: DBName -> AlterTable -> String +showAlterTable :: EntityNameDB -> AlterTable -> String showAlterTable table (AddUniqueConstraint cname cols) = concat [ "ALTER TABLE " , escapeDBName table @@ -506,31 +522,31 @@ showAlterTable table (DropUniqueConstraint cname) = concat -- | 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 :: EntityNameDB -> AlterColumn -> String +showAlter table (Change oldName (Column n nu t def _generated 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 _generated defConstraintName maxLen Nothing) ] -showAlter table (_, Add' col) = +showAlter table (Add' col) = concat [ "ALTER TABLE " , escapeDBName table , " ADD COLUMN " , showColumn col ] -showAlter table (n, Drop) = +showAlter table (Drop n) = concat [ "ALTER TABLE " , escapeDBName table , " DROP COLUMN " , escapeDBName n ] -showAlter table (n, Default s) = +showAlter table (Default n s) = concat [ "ALTER TABLE " , escapeDBName table @@ -539,7 +555,7 @@ showAlter table (n, Default s) = , " SET DEFAULT " , s ] -showAlter table (n, NoDefault) = +showAlter table (NoDefault n) = concat [ "ALTER TABLE " , escapeDBName table @@ -547,7 +563,7 @@ showAlter table (n, NoDefault) = , escapeDBName n , " DROP DEFAULT" ] -showAlter table (n, Update' s) = +showAlter table (Update' n s) = concat [ "UPDATE " , escapeDBName table @@ -559,7 +575,7 @@ showAlter table (n, Update' s) = , escapeDBName n , " IS NULL" ] -showAlter table (_, AddReference reftable fkeyname t2 id2) = concat +showAlter table (AddReference reftable fkeyname t2 id2) = concat [ "ALTER TABLE " , escapeDBName table , " ADD CONSTRAINT " @@ -572,23 +588,24 @@ showAlter table (_, AddReference reftable fkeyname t2 id2) = concat , intercalate "," $ map escapeDBName id2 , ")" ] -showAlter table (_, DropReference cname) = concat +showAlter table (DropReference cname) = concat [ "ALTER TABLE " , escapeDBName table , " DROP FOREIGN KEY " , escapeDBName cname ] -refName :: DBName -> DBName -> DBName -refName (DBName table) (DBName column) = - DBName $ T.concat [table, "_", column, "_fkey"] +refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB +refName (EntityNameDB table) (FieldNameDB column) = + ConstraintNameDB $ T.concat [table, "_", column, "_fkey"] ---------------------------------------------------------------------- -- | Escape a database name to be included on a query. -escapeDBName :: DBName -> String -escapeDBName (DBName s) = '`' : go (T.unpack s) +escapeDBName :: DatabaseName name => name -> String +escapeDBName = + escapeWith $ \s -> '`' : go (T.unpack s) where go ('`':xs) = '`' : '`' : go xs go ( x :xs) = x : go xs diff --git a/src/Database/Persist/MigrateOracle.hs b/src/Database/Persist/MigrateOracle.hs index 388d387..97e1ca9 100644 --- a/src/Database/Persist/MigrateOracle.hs +++ b/src/Database/Persist/MigrateOracle.hs @@ -43,7 +43,9 @@ getMigrationStrategy dbtype@Oracle { oracle12c=ok} = { dbmsLimitOffset=limitOffset ok ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' - ,dbmsEscape=T.pack . escapeDBName + ,dbmsEscapeFieldName = T.pack . escapeDBName + ,dbmsEscapeTableName = T.pack . escapeDBName . entityDB + ,dbmsEscapeRawName = T.pack . escapeDBName . FieldNameDB ,dbmsType=dbtype } getMigrationStrategy dbtype = error $ "Oracle: calling with invalid dbtype " ++ show dbtype @@ -56,7 +58,8 @@ migrate' :: [EntityDef] migrate' allDefs getter val = do let name = entityDB val (idClmn, old, mseq) <- getColumns getter val - let (newcols, udefs, fdefs) = mkColumns allDefs val + let (newcols, udefs, fdefs) = + mkColumns allDefs val emptyBackendSpecificOverrides let udspair = map udToPair udefs let addSequence = AddSequence $ concat [ "CREATE SEQUENCE " @@ -84,18 +87,22 @@ migrate' allDefs getter val = do AddUniqueConstraint uname $ map (findTypeOfColumn allDefs name) ucols ] let foreigns = tracex ("in migrate' newcols=" ++ show newcols) $ do - Column { cName=cname, cReference=Just (refTblName, a) } <- newcols + Column { cName=cname, cReference=Just cRef } <- newcols + let refTblName = crTableName cRef + let a = crConstraintName cRef tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ - return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) + return $ AlterColumn name (addReference allDefs (refName name cname) refTblName cname) let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + in AlterColumn name (AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ map showAlterDb $ addTable : addSequence : uniques ++ foreigns ++ foreignsAlt -- No errors and something found, migrate (_, _, ([], old'),mseq') -> do let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of - Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of + Just cRef -> + let fk = crConstraintName cRef in + case find (\f -> fk == foreignConstraintNameDBName f) fdefs of Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ c { cReference = Nothing } Nothing -> c @@ -109,7 +116,8 @@ migrate' allDefs getter val = do -- | Find out the type of a column. -findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn :: + [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType) findTypeOfColumn allDefs name col = maybe (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++ @@ -121,7 +129,7 @@ findTypeOfColumn allDefs name col = -- | Helper for 'AddRefence' that finds out the 'entityId'. -addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn +addReference :: [EntityDef] -> ConstraintNameDB -> EntityNameDB -> FieldNameDB -> AlterColumn addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ AddReference reftable fkeyname [cname] [id_] where @@ -131,26 +139,26 @@ addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname=" entDef <- find ((== reftable) . entityDB) allDefs return (fieldDB $ entityId entDef) -data AlterColumn = Change Column - | Add' Column - | Drop - | Default String - | NoDefault - | Update' String - | AddReference DBName DBName [DBName] [DBName] - | DropReference DBName +data AlterColumn = + Change Column + | Add' Column + | Drop FieldNameDB + | Default FieldNameDB String + | NoDefault FieldNameDB + | Update' FieldNameDB String + | AddReference EntityNameDB ConstraintNameDB [FieldNameDB] [FieldNameDB] + | DropReference ConstraintNameDB -type AlterColumn' = (DBName, AlterColumn) - -data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType)] - | DropUniqueConstraint DBName +data AlterTable = + AddUniqueConstraint ConstraintNameDB [(FieldNameDB, FieldType)] + | DropUniqueConstraint ConstraintNameDB data AlterDB = AddTable String - | AlterColumn DBName AlterColumn' - | AlterTable DBName AlterTable + | AlterColumn EntityNameDB AlterColumn + | AlterTable EntityNameDB AlterTable | AddSequence String -udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) ---------------------------------------------------------------------- @@ -160,8 +168,8 @@ udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) -- in the database. getColumns :: (Text -> IO Statement) -> EntityDef - -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column - , [Either Text (Either Column (DBName, [DBName]))] -- everything else + -> IO ( [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] -- ID column + , [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] -- everything else , Maybe PersistValue -- sequence name ) getColumns getter def = do @@ -217,8 +225,8 @@ getColumns getter def = do listAsMaybe [[x]] = Just x listAsMaybe xs = error $ "returned to many sequences xs=" ++ show xs - vals = [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ fieldDB $ entityId def ] + vals = [ PersistText $ unEntityNameDB $ entityDB def + , PersistText $ unFieldNameDB $ fieldDB $ entityId def ] helperClmns = CL.mapM getIt .| CL.consume where @@ -232,13 +240,13 @@ getColumns getter def = do , T.decodeUtf8 clmnName ) check other = fail $ "helperCntrs: unexpected " ++ show other rows <- mapM check =<< CL.consume - return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) + return $ map (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd))) $ groupBy ((==) `on` fst) rows -- | Get the information about a column in a table. getColumn :: (Text -> IO Statement) - -> DBName + -> EntityNameDB -> [PersistValue] -> IO (Either Text Column) getColumn getter tname [ PersistByteString cname @@ -282,21 +290,22 @@ getColumn getter tname [ PersistByteString cname ,"UCC.TABLE_NAME, " ,"UCC.COLUMN_NAME"] - let vars = [ PersistText $ unDBName tname + let vars = [ PersistText $ unEntityNameDB tname , PersistByteString cname ] cntrs <- liftIO $ with (stmtQuery stmt vars) (`connect` CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref]] -> - return $ Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) + return $ Just $ ColumnReference (EntityNameDB $ T.decodeUtf8 tab) (ConstraintNameDB $ T.decodeUtf8 ref) noCascade a1 -> fail $ "Oracle.getColumn/getRef: never here error[" ++ show a1 ++ "]" -- Okay! return Column - { cName = DBName $ T.decodeUtf8 cname + { cName = FieldNameDB $ T.decodeUtf8 cname , cNull = null_ == "Y" , cSqlType = type_ + , cGenerated = Nothing , cDefault = default_ , cDefaultConstraintName = Nothing , cMaxLen = Nothing -- FIXME: maxLen @@ -355,10 +364,10 @@ parseType b = error $ "oracle: parseType no idea how to parse this b= -- | @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]) + -> EntityNameDB + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([AlterColumn], [AlterTable]) getAlters allDefs tblName (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where @@ -368,9 +377,8 @@ getAlters allDefs tblName (c1, u1) (c2, u2) = in alters ++ getAltersC news old' dropColumn col = - map ((,) (cName col)) $ - [DropReference n | Just (_, n) <- [cReference col]] ++ - [Drop] + [DropReference (crConstraintName cRef) | Just cRef <- [cReference col]] ++ + [Drop (cName col)] getAltersU [] old = map (DropUniqueConstraint . fst) old getAltersU ((name, cols):news) old = @@ -391,34 +399,42 @@ getAlters allDefs tblName (c1, u1) (c2, u2) = -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName _maxLen ref) cols = +findAlters :: EntityNameDB -> [EntityDef] -> Column -> [Column] -> ([AlterColumn], [Column]) +findAlters tblName allDefs col@(Column name isNull type_ def _generated _defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of [] -> case ref of - Nothing -> ([(name, Add' col)], []) - Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ + Nothing -> ([Add' col], []) + Just cRef -> + let tname = crTableName cRef in + let b = crConstraintName cRef in + let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ [addReference allDefs (refName tblName name) tname name] - in (map ((,) name) (Add' col : cnstr), cols) - Column _ isNull' type_' def' _defConstraintName' _maxLen' ref':_ -> + in (Add' col : cnstr, cols) + Column _ isNull' type_' def' _generated _defConstraintName' _maxLen' ref':_ -> let -- Foreign key refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ - [(name, DropReference cname)] + (False, Just cRef) -> + let cname = crConstraintName cRef in + tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ + [DropReference cname] _ -> [] refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ - [(tname, addReference allDefs (refName tblName name) tname name)] + (False, Just cRef) -> + let tname = crTableName cRef in + let cname = crConstraintName cRef in + tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ + [addReference allDefs (refName tblName name) tname name] _ -> [] -- Type and nullability modType | tpcheck type_ type_' && isNull == isNull' = [] - | otherwise = [(name, Change col)] + | otherwise = [Change col] -- Default value modDef | cmpdef def def' = [] | otherwise = --tracex ("findAlters col=" ++ show col ++ " def=" ++ show def ++ " def'=" ++ show def') $ case def of - Nothing -> [(name, NoDefault)] - Just s -> [(name, Default $ T.unpack s)] + Nothing -> [NoDefault name] + Just s -> [Default name $ T.unpack s] in ( refDrop ++ modType ++ modDef ++ refAdd , filter ((name /=) . cName) cols ) @@ -442,7 +458,7 @@ tpcheck a b = a==b -- | 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 _generated _defConstraintName maxLen _ref) = concat [ escapeDBName n , " " , showSqlType t maxLen @@ -480,16 +496,16 @@ showSqlType (SqlOther t) _ = error ("oops in showSqlType " ++ show t) showAlterDb :: AlterDB -> (Bool, Text) showAlterDb (AddTable s) = (False, pack s) showAlterDb (AddSequence s) = (False, pack s) -showAlterDb (AlterColumn t (c, ac)) = - (isUnsafe ac, pack $ showAlter t (c, ac)) +showAlterDb (AlterColumn t ac) = + (isUnsafe ac, pack $ showAlter t ac) where - isUnsafe Drop = True - isUnsafe _ = False + isUnsafe (Drop _) = True + isUnsafe _ = False showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) -- | Render an action that must be done on a table. -showAlterTable :: DBName -> AlterTable -> String +showAlterTable :: EntityNameDB -> AlterTable -> String showAlterTable table (AddUniqueConstraint cname cols) = concat [ "ALTER TABLE " , escapeDBName table @@ -508,32 +524,32 @@ showAlterTable table (DropUniqueConstraint cname) = concat -- | 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 :: EntityNameDB -> AlterColumn -> String +showAlter table (Change (Column n nu t def generated defConstraintName maxLen _ref)) = concat [ "ALTER TABLE " , escapeDBName table , " MODIFY (" -- , escapeDBName oldName , " " - , showColumn (Column n nu t def defConstraintName maxLen Nothing) + , showColumn (Column n nu t def generated defConstraintName maxLen Nothing) , ")" ] -showAlter table (_, Add' col) = +showAlter table (Add' col) = concat [ "ALTER TABLE " , escapeDBName table , " ADD " , showColumn col ] -showAlter table (n, Drop) = +showAlter table (Drop n) = concat [ "ALTER TABLE " , escapeDBName table , " DROP COLUMN " , escapeDBName n ] -showAlter table (n, Default s) = +showAlter table (Default n s) = concat [ "ALTER TABLE " , escapeDBName table @@ -543,7 +559,7 @@ showAlter table (n, Default s) = , s , ")" ] -showAlter table (n, NoDefault) = +showAlter table (NoDefault n) = concat [ "ALTER TABLE " , escapeDBName table @@ -551,7 +567,7 @@ showAlter table (n, NoDefault) = , escapeDBName n , " DEFAULT NULL" ] -showAlter table (n, Update' s) = +showAlter table (Update' n s) = concat [ "UPDATE " , escapeDBName table @@ -563,7 +579,7 @@ showAlter table (n, Update' s) = , escapeDBName n , " IS NULL" ] -showAlter table (_, AddReference reftable fkeyname t2 id2) = concat +showAlter table (AddReference reftable fkeyname t2 id2) = concat [ "ALTER TABLE " , escapeDBName table , " ADD CONSTRAINT " @@ -576,7 +592,7 @@ showAlter table (_, AddReference reftable fkeyname t2 id2) = concat , intercalate "," $ map escapeDBName id2 , ")" ] -showAlter table (_, DropReference cname) = concat +showAlter table (DropReference cname) = concat [ "ALTER TABLE " , escapeDBName table , " DROP CONSTRAINT " @@ -584,29 +600,31 @@ showAlter table (_, DropReference cname) = concat ] -- ORA-00972: identifier is too long -refName :: DBName -> DBName -> DBName -refName (DBName table) (DBName column) = - DBName $ T.take 30 $ T.concat [table, "_", column, "_fkey"] +refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB +refName (EntityNameDB table) (FieldNameDB column) = + ConstraintNameDB $ T.take 30 $ T.concat [table, "_", column, "_fkey"] --refNames :: DBName -> [DBName] -> DBName --refNames (DBName table) dbnames = -- let columns = T.intercalate "_" $ map unDBName dbnames -- in DBName $ T.take 30 $ T.concat [table, "_", columns, "_fkey"] -pkeyName :: DBName -> DBName -pkeyName (DBName table) = - DBName $ T.take 30 $ T.concat [table, "_pkey"] +pkeyName :: EntityNameDB -> ConstraintNameDB +pkeyName (EntityNameDB table) = + ConstraintNameDB $ T.take 30 $ T.concat [table, "_pkey"] ---------------------------------------------------------------------- -- | Escape a database name to be included on a query. -escapeDBName :: DBName -> String -escapeDBName (DBName s) = '"' : go (T.unpack s) +escapeDBName :: DatabaseName name => name -> String +escapeDBName = + escapeWith $ \s -> '"' : go (T.unpack s) where go ('"':xs) = '"' : '"' : go xs go ( x :xs) = x : go xs go "" = "\"" + -- | SQL code to be executed when inserting an entity. insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = @@ -638,11 +656,11 @@ insertSql' ent vals = , ")" ] -getSeqNameEscaped :: DBName -> String -getSeqNameEscaped d = escapeDBName $ DBName $ getSeqNameUnescaped d +getSeqNameEscaped :: EntityNameDB -> String +getSeqNameEscaped d = escapeDBName $ ConstraintNameDB $ getSeqNameUnescaped d -getSeqNameUnescaped :: DBName -> Text -getSeqNameUnescaped (DBName s) = "seq_" <> s <> "_id" +getSeqNameUnescaped :: EntityNameDB -> Text +getSeqNameUnescaped (EntityNameDB s) = "seq_" <> s <> "_id" limitOffset :: Bool -> (Int,Int) -> Bool -> Text -> Text limitOffset oracle12c' (limit,offset) hasOrder sql diff --git a/src/Database/Persist/MigratePostgres.hs b/src/Database/Persist/MigratePostgres.hs index 635d25a..1d5c162 100644 --- a/src/Database/Persist/MigratePostgres.hs +++ b/src/Database/Persist/MigratePostgres.hs @@ -44,7 +44,9 @@ getMigrationStrategy dbtype@Postgres {} = { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT ALL" ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' - ,dbmsEscape=escape + ,dbmsEscapeFieldName = escape + ,dbmsEscapeTableName = escape . entityDB + ,dbmsEscapeRawName = escape . FieldNameDB ,dbmsType=dbtype } getMigrationStrategy dbtype = error $ "Postgres: calling with invalid dbtype " ++ show dbtype @@ -59,7 +61,8 @@ migrate' allDefs getter val = fmap (fmap $ map showAlterDb) $ do case partitionEithers old of ([], old'') -> do let old' = partitionEithers old'' - let (newcols', udefs, fdefs) = mkColumns allDefs val + let (newcols', udefs, fdefs) = + mkColumns allDefs val emptyBackendSpecificOverrides let newcols = filter (not . safeToRemove val . cName) newcols' let udspair = map udToPair udefs --let composite = isJust $ entityPrimary val @@ -81,9 +84,9 @@ migrate' allDefs getter val = fmap (fmap $ map showAlterDb) $ do ] let uniques = flip concatMap udspair $ \(uname, ucols) -> [AlterTable name $ AddUniqueConstraint uname ucols] - references = mapMaybe (\c@Column { cName=cname, cReference=Just (refTblName, _) } -> getAddReference allDefs name refTblName cname (cReference c)) $ filter (\c -> cReference c /= Nothing) newcols + references = mapMaybe (\c@Column { cName=cname, cReference=Just colRef } -> getAddReference allDefs name (crTableName colRef) cname (cReference c)) $ filter (\c -> cReference c /= Nothing) newcols foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + in AlterColumn name (AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ addTable : uniques ++ references ++ foreignsAlt else do let (acs, ats) = getAlters allDefs val (newcols, udspair) old' @@ -94,22 +97,29 @@ migrate' allDefs getter val = fmap (fmap $ map showAlterDb) $ do type SafeToRemove = Bool -data AlterColumn = Type SqlType | IsNull | NotNull | Add' Column | Drop SafeToRemove - | Default String | NoDefault | Update' String - | AddReference DBName [DBName] [DBName] | DropReference DBName -type AlterColumn' = (DBName, AlterColumn) - -data AlterTable = AddUniqueConstraint DBName [DBName] - | DropConstraint DBName +data AlterColumn = + Type FieldNameDB SqlType + | IsNull FieldNameDB + | NotNull FieldNameDB + | Add' Column + | Drop FieldNameDB SafeToRemove + | Default FieldNameDB String + | NoDefault FieldNameDB + | Update' FieldNameDB String + | AddReference EntityNameDB ConstraintNameDB [FieldNameDB] [FieldNameDB] + | DropReference ConstraintNameDB + +data AlterTable = AddUniqueConstraint ConstraintNameDB [FieldNameDB] + | DropConstraint ConstraintNameDB data AlterDB = AddTable String - | AlterColumn DBName AlterColumn' - | AlterTable DBName AlterTable + | AlterColumn EntityNameDB AlterColumn + | AlterTable EntityNameDB AlterTable -- | Returns all of the columns in the given table currently in the database. getColumns :: (Text -> IO Statement) -> EntityDef - -> IO [Either Text (Either Column (DBName, [DBName]))] + -> IO [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] getColumns getter def = do let sqlv=concat ["SELECT " ,"column_name " @@ -126,8 +136,8 @@ getColumns getter def = do stmt <- getter $ pack sqlv let vals = - [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ fieldDB $ entityId def + [ PersistText $ unEntityNameDB $ entityDB def + , PersistText $ unFieldNameDB $ fieldDB $ entityId def ] cs <- with (stmtQuery stmt vals) (`connect` helperClmns) let sqlc=concat ["SELECT " @@ -168,7 +178,7 @@ getColumns getter def = do Just xx -> error $ "oops: unexpected datatype returned odbc postgres xx="++show xx helperU = do rows <- getAll id - return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) + return $ map (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd))) $ groupBy ((==) `on` fst) rows helperClmns = CL.mapM getIt .| CL.consume @@ -191,27 +201,27 @@ getColumns getter def = do -} -- | Check if a column name is listed as the "safe to remove" in the entity -- list. -safeToRemove :: EntityDef -> DBName -> Bool -safeToRemove def (DBName colName) - = any (elem "SafeToRemove" . fieldAttrs) - $ filter ((== (DBName colName)) . fieldDB) +safeToRemove :: EntityDef -> FieldNameDB -> Bool +safeToRemove def colName + = any (elem FieldAttrSafeToRemove . fieldAttrs) + $ filter ((== colName) . fieldDB) $ entityFields def getAlters :: [EntityDef] -> EntityDef - -> ([Column], [(DBName, [DBName])]) - -> ([Column], [(DBName, [DBName])]) - -> ([AlterColumn'], [AlterTable]) + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([AlterColumn], [AlterTable]) getAlters allDefs def (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where - getAltersC [] old = map (\x -> (cName x, Drop $ safeToRemove def $ cName x)) old + getAltersC [] old = map (\x -> Drop (cName x) $ safeToRemove def $ cName x) old getAltersC (new:news) old = let (alters, old') = findAlters allDefs (entityDB def) new old in alters ++ getAltersC news old' - getAltersU :: [(DBName, [DBName])] - -> [(DBName, [DBName])] + getAltersU :: [(ConstraintNameDB, [FieldNameDB])] + -> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable] getAltersU [] old = map DropConstraint $ filter (not . isManual) $ map fst old getAltersU ((name, cols):news) old = @@ -226,10 +236,10 @@ getAlters allDefs def (c1, u1) (c2, u2) = : getAltersU news old' -- Don't drop constraints which were manually added. - isManual (DBName x) = "__manual_" `T.isPrefixOf` x + isManual (ConstraintNameDB x) = "__manual_" `T.isPrefixOf` x getColumn :: (Text -> IO Statement) - -> DBName -> [PersistValue] + -> EntityNameDB -> [PersistValue] -> IO (Either Text Column) getColumn getter tname [PersistByteString x, PersistByteString y, PersistByteString z, d, npre, nscl] = do case d' of @@ -238,12 +248,13 @@ getColumn getter tname [PersistByteString x, PersistByteString y, PersistByteStr case getType (T.decodeUtf8 z) of Left s -> return $ Left s Right t -> do - let cname = DBName $ T.decodeUtf8 x + let cname = FieldNameDB $ T.decodeUtf8 x ref <- getRef cname return $ Right Column { cName = cname , cNull = y == "YES" , cSqlType = t + , cGenerated = Nothing , cDefault = d'' , cDefaultConstraintName = Nothing , cMaxLen = Nothing @@ -279,14 +290,14 @@ getColumn getter tname [PersistByteString x, PersistByteString y, PersistByteStr let ref = refName tname cname stmt <- getter sql with (stmtQuery stmt - [ PersistText $ unDBName tname - , PersistText $ unDBName ref + [ PersistText $ unEntityNameDB tname + , PersistText $ unConstraintNameDB ref ]) (`connect` do m <- CL.head return $ case m of - Just [PersistText _table, PersistText _col, PersistText reftable, PersistText _refcol, PersistInt64 _pos] -> Just (DBName reftable, ref) - Just [PersistByteString _table, PersistByteString _col, PersistByteString reftable, PersistByteString _refcol, PersistInt64 _pos] -> Just (DBName (T.decodeUtf8 reftable), ref) + Just [PersistText _table, PersistText _col, PersistText reftable, PersistText _refcol, PersistInt64 _pos] -> Just $ ColumnReference (EntityNameDB reftable) ref noCascade + Just [PersistByteString _table, PersistByteString _col, PersistByteString reftable, PersistByteString _refcol, PersistInt64 _pos] -> Just $ ColumnReference (EntityNameDB (T.decodeUtf8 reftable)) ref noCascade Nothing -> Nothing _ -> error $ "unexpected result found ["++ show m ++ "]" ) d' = case d of @@ -313,40 +324,45 @@ getColumn getter tname [PersistByteString x, PersistByteString y, PersistByteStr getColumn _ a2 x = return $ Left $ pack $ "Invalid result from information_schema: " ++ show x ++ " a2[" ++ show a2 ++ "]" -findAlters :: [EntityDef] -> DBName -> Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters defs tablename col@(Column name isNull sqltype def _defConstraintName _maxLen ref) cols = +findAlters :: [EntityDef] -> EntityNameDB -> Column -> [Column] -> ([AlterColumn], [Column]) +findAlters defs tablename col@(Column name isNull sqltype def _generated _defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tablename++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of - [] -> ([(name, Add' col)], cols) - Column _ isNull' sqltype' def' defConstraintName' _maxLen' ref':_ -> + [] -> ([Add' col], cols) + Column _ isNull' sqltype' def' _generated defConstraintName' _maxLen' ref':_ -> let refDrop Nothing = [] - refDrop (Just (_, cname)) = tracex ("\n\n\n44444 findAlters dropping fkey defConstraintName'="++show defConstraintName' ++" name="++show name++" cname="++show cname++" tablename="++show tablename++"\n\n\n") $ - [(name, DropReference cname)] + refDrop (Just cRef) = + let cname = crConstraintName cRef in + tracex ("\n\n\n44444 findAlters dropping fkey defConstraintName'="++show defConstraintName' ++" name="++show name++" cname="++show cname++" tablename="++show tablename++"\n\n\n") $ + [DropReference cname] refAdd Nothing = [] - refAdd (Just (tname, a)) = tracex ("\n\n\n33333 findAlters adding fkey defConstraintName'="++show defConstraintName' ++" name="++show name++" tname="++show tname++" a="++show a++" tablename="++show tablename++"\n\n\n") $ + refAdd (Just colRef) = + let tname = crTableName colRef in + let a = crConstraintName colRef in + tracex ("\n\n\n33333 findAlters adding fkey defConstraintName'="++show defConstraintName' ++" name="++show name++" tname="++show tname++" a="++show a++" tablename="++show tablename++"\n\n\n") $ case find ((==tname) . entityDB) defs of - Just refdef -> [(tname, AddReference a [name] [fieldDB $ entityId refdef])] + Just refdef -> [AddReference tname a [name] [fieldDB $ entityId refdef]] Nothing -> error $ "could not find the entityDef for reftable[" ++ show tname ++ "]" modRef = tracex ("modType: sqltype[" ++ show sqltype ++ "] sqltype'[" ++ show sqltype' ++ "] name=" ++ show name) $ - if fmap snd ref == fmap snd ref' + if fmap crConstraintName ref == fmap crConstraintName ref' then [] else tracex ("\n\n\nmodRef findAlters drop/add cos ref doesnt match ref[" ++ show ref ++ "] ref'[" ++ show ref' ++ "] tablename="++show tablename++"\n\n\n") $ refDrop ref' ++ refAdd ref modNull = case (isNull, isNull') of - (True, False) -> [(name, IsNull)] + (True, False) -> [IsNull name] (False, True) -> let up = case def of Nothing -> id - Just s -> (:) (name, Update' $ T.unpack s) - in up [(name, NotNull)] + Just s -> (:) (Update' name $ T.unpack s) + in up [NotNull name] _ -> [] modType = tracex ("modType: sqltype[" ++ show sqltype ++ "] sqltype'[" ++ show sqltype' ++ "] name=" ++ show name) $ - if sqltype == sqltype' then [] else [(name, Type sqltype)] + if sqltype == sqltype' then [] else [Type name sqltype] modDef = tracex ("modDef col=" ++ show col ++ " def=" ++ show def ++ " def'=" ++ show def') $ if cmpdef def def' then [] else case def of - Nothing -> [(name, NoDefault)] - Just s -> [(name, Default $ T.unpack s)] + Nothing -> [NoDefault name] + Just s -> [Default name $ T.unpack s] in (modRef ++ modDef ++ modNull ++ modType, filter (\c -> cName c /= name) cols) @@ -362,12 +378,15 @@ cmpdef (Just def) (Just def') | def==def' = True cmpdef _ _ = False -- | Get the references to be added to a table for the given column. -getAddReference :: [EntityDef] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB +getAddReference :: [EntityDef] -> EntityNameDB -> EntityNameDB -> FieldNameDB -> Maybe ColumnReference -> Maybe AlterDB getAddReference allDefs table reftable cname ref = case ref of Nothing -> Nothing - Just (s, z) -> tracex ("\n\ngetaddreference table="++ show table++" reftable="++show reftable++" s="++show s++" z=" ++ show z++"\n\n") $ - Just $ AlterColumn table (s, AddReference (refName table cname) [cname] [id_]) + Just cRef -> + let s = crTableName cRef in + let z = crConstraintName cRef in + tracex ("\n\ngetaddreference table="++ show table++" reftable="++show reftable++" s="++show s++" z=" ++ show z++"\n\n") $ + Just $ AlterColumn table (AddReference s (refName table cname) [cname] [id_]) where id_ = maybe (error $ "Could not find ID of entity " ++ show reftable) id $ do @@ -376,7 +395,7 @@ getAddReference allDefs table reftable cname ref = showColumn :: Column -> String -showColumn (Column n nu sqlType' def _defConstraintName _maxLen _ref) = concat +showColumn (Column n nu sqlType' def _generated _defConstraintName _maxLen _ref) = concat [ T.unpack $ escape n , " " , showSqlType sqlType' _maxLen @@ -404,14 +423,14 @@ showSqlType (SqlOther t) _ = T.unpack t showAlterDb :: AlterDB -> (Bool, Text) showAlterDb (AddTable s) = (False, pack s) -showAlterDb (AlterColumn t (c, ac)) = - (isUnsafe ac, pack $ showAlter t (c, ac)) +showAlterDb (AlterColumn t ac) = + (isUnsafe ac, pack $ showAlter t ac) where - isUnsafe (Drop safeToRem) = not safeToRem + isUnsafe (Drop _ safeToRem) = not safeToRem isUnsafe _ = False showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) -showAlterTable :: DBName -> AlterTable -> String +showAlterTable :: EntityNameDB -> AlterTable -> String showAlterTable table (AddUniqueConstraint cname cols) = concat [ "ALTER TABLE " , T.unpack $ escape table @@ -428,8 +447,8 @@ showAlterTable table (DropConstraint cname) = concat , T.unpack $ escape cname ] -showAlter :: DBName -> AlterColumn' -> String -showAlter table (n, Type t) = +showAlter :: EntityNameDB -> AlterColumn -> String +showAlter table (Type n t) = concat [ "ALTER TABLE " , T.unpack $ escape table @@ -438,7 +457,7 @@ showAlter table (n, Type t) = , " TYPE " , showSqlType t Nothing ] -showAlter table (n, IsNull) = +showAlter table (IsNull n) = concat [ "ALTER TABLE " , T.unpack $ escape table @@ -446,7 +465,7 @@ showAlter table (n, IsNull) = , T.unpack $ escape n , " DROP NOT NULL" ] -showAlter table (n, NotNull) = +showAlter table (NotNull n) = concat [ "ALTER TABLE " , T.unpack $ escape table @@ -454,21 +473,21 @@ showAlter table (n, NotNull) = , T.unpack $ escape n , " SET NOT NULL" ] -showAlter table (_, Add' col) = +showAlter table (Add' col) = concat [ "ALTER TABLE " , T.unpack $ escape table , " ADD COLUMN " , showColumn col ] -showAlter table (n, Drop _) = +showAlter table (Drop n _) = concat [ "ALTER TABLE " , T.unpack $ escape table , " DROP COLUMN " , T.unpack $ escape n ] -showAlter table (n, Default s) = +showAlter table (Default n s) = concat [ "ALTER TABLE " , T.unpack $ escape table @@ -477,14 +496,14 @@ showAlter table (n, Default s) = , " SET DEFAULT " , s ] -showAlter table (n, NoDefault) = concat +showAlter table (NoDefault n) = concat [ "ALTER TABLE " , T.unpack $ escape table , " ALTER COLUMN " , T.unpack $ escape n , " DROP DEFAULT" ] -showAlter table (n, Update' s) = concat +showAlter table (Update' n s) = concat [ "UPDATE " , T.unpack $ escape table , " SET " @@ -495,7 +514,7 @@ showAlter table (n, Update' s) = concat , T.unpack $ escape n , " IS NULL" ] -showAlter table (reftable, AddReference fkeyname t2 id2) = concat +showAlter table (AddReference reftable fkeyname t2 id2) = concat [ "ALTER TABLE " , T.unpack $ escape table , " ADD CONSTRAINT " @@ -508,15 +527,16 @@ showAlter table (reftable, AddReference fkeyname t2 id2) = concat , T.unpack $ T.intercalate "," $ map escape id2 , ")" ] -showAlter table (_, DropReference cname) = concat +showAlter table (DropReference cname) = concat [ "ALTER TABLE " , T.unpack (escape table) , " DROP CONSTRAINT " , T.unpack $ escape cname ] -escape :: DBName -> Text -escape (DBName s) = +escape :: DatabaseName name => name -> Text +escape = + escapeWith $ \s -> T.pack $ '"' : go (T.unpack s) ++ "\"" where go "" = "" @@ -524,11 +544,11 @@ escape (DBName s) = go (x:xs) = x : go xs -refName :: DBName -> DBName -> DBName -refName (DBName table) (DBName column) = - DBName $ T.concat [table, "_", column, "_fkey"] +refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB +refName (EntityNameDB table) (FieldNameDB column) = + ConstraintNameDB $ T.concat [table, "_", column, "_fkey"] -udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult diff --git a/src/Database/Persist/MigrateSqlite.hs b/src/Database/Persist/MigrateSqlite.hs index 31c0854..eb08e60 100644 --- a/src/Database/Persist/MigrateSqlite.hs +++ b/src/Database/Persist/MigrateSqlite.hs @@ -27,7 +27,9 @@ getMigrationStrategy dbtype@Sqlite { sqlite3619 = _fksupport } = { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT -1" ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' - ,dbmsEscape=escape + ,dbmsEscapeFieldName = escape + ,dbmsEscapeTableName = escape . entityDB + ,dbmsEscapeRawName = escape . FieldNameDB ,dbmsType=dbtype } getMigrationStrategy dbtype = error $ "Sqlite: calling with invalid dbtype " ++ show dbtype @@ -78,10 +80,11 @@ migrate' :: [EntityDef] -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = do - let (cols, uniqs, _fdefs) = mkColumns allDefs val + let (cols, uniqs, _fdefs) = + mkColumns allDefs val emptyBackendSpecificOverrides let newSql = mkCreateTable False def (filter (not . safeToRemove val . cName) cols, uniqs) stmt <- getter "SELECT sql FROM sqlite_master WHERE type='table' AND name=?" - oldSql' <- with (stmtQuery stmt [PersistText $ unDBName table]) (`connect` go) + oldSql' <- with (stmtQuery stmt [PersistText $ unEntityNameDB table]) (`connect` go) case oldSql' of Nothing -> return $ Right [(False, newSql)] Just oldSql -> do @@ -103,10 +106,10 @@ migrate' allDefs getter val = do -- | Check if a column name is listed as the "safe to remove" in the entity -- list. -safeToRemove :: EntityDef -> DBName -> Bool -safeToRemove def (DBName colName) - = any (elem "SafeToRemove" . fieldAttrs) - $ filter ((== (DBName colName)) . fieldDB) +safeToRemove :: EntityDef -> FieldNameDB -> Bool +safeToRemove def colName + = any (elem FieldAttrSafeToRemove . fieldAttrs) + $ filter ((== colName) . fieldDB) $ entityFields def getCopyTable :: [EntityDef] @@ -116,7 +119,7 @@ getCopyTable :: [EntityDef] getCopyTable allDefs getter def = do stmt <- getter $ pack $ "PRAGMA table_info(" ++ escape' table ++ ")" oldCols' <- with (stmtQuery stmt []) (`connect` getCols) - let oldCols = map DBName $ filter (/= "id") oldCols' -- need to update for table id attribute ? + let oldCols = map FieldNameDB $ filter (/= "id") oldCols' -- need to update for table id attribute ? let newCols = filter (not . safeToRemove def) $ map cName cols let common = filter (`elem` oldCols) newCols let id_ = fieldDB (entityId def) @@ -137,8 +140,8 @@ getCopyTable allDefs getter def = do return $ name : names Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y table = entityDB def - tableTmp = DBName $ unDBName table <> "_backup" - (cols, uniqs, _) = mkColumns allDefs def + tableTmp = EntityNameDB $ unEntityNameDB table <> "_backup" + (cols, uniqs, _) = mkColumns allDefs def emptyBackendSpecificOverrides cols' = filter (not . safeToRemove def . cName) cols newSql = mkCreateTable False def (cols', uniqs) tmpSql = mkCreateTable True def { entityDB = tableTmp } (cols', uniqs) @@ -164,7 +167,7 @@ getCopyTable allDefs getter def = do ] -escape' :: DBName -> String +escape' :: DatabaseName name => name -> String escape' = T.unpack . escape mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef]) -> Text @@ -206,7 +209,7 @@ mayDefault def = case def of Just d -> " DEFAULT " <> d sqlColumn :: Column -> Text -sqlColumn (Column name isNull typ def _cn _maxLen ref) = T.concat +sqlColumn (Column name isNull typ def _generated _cn _maxLen ref) = T.concat [ "," , escape name , " " @@ -217,7 +220,7 @@ sqlColumn (Column name isNull typ def _cn _maxLen ref) = T.concat Just d -> " DEFAULT " `T.append` d , case ref of Nothing -> "" - Just (table, _) -> " REFERENCES " `T.append` escape table + Just colRef -> " REFERENCES " `T.append` escape (crTableName colRef) ] sqlUnique :: UniqueDef -> Text @@ -229,8 +232,9 @@ sqlUnique (UniqueDef _ cname cols _) = T.concat , ")" ] -escape :: DBName -> Text -escape (DBName s) = +escape :: DatabaseName name => name -> Text +escape = + escapeWith $ \s -> T.concat [q, T.concatMap go s, q] where q = T.singleton '"' diff --git a/src/Database/Persist/ODBC.hs b/src/Database/Persist/ODBC.hs index ba8568b..801d2a0 100644 --- a/src/Database/Persist/ODBC.hs +++ b/src/Database/Persist/ODBC.hs @@ -60,7 +60,7 @@ type ConnectionString = String -- finishes using it. Note that you should not use the given -- 'ConnectionPool' outside the action since it may be already -- been released. -withODBCPool :: (MonadUnliftIO m, MonadLogger m) +withODBCPool :: (MonadUnliftIO m, MonadLoggerIO m) => Maybe DBType -> ConnectionString -- ^ Connection string to the database. @@ -78,7 +78,7 @@ withODBCPool dbt ci = withSqlPool (\lg -> open' lg dbt ci) -- responsibility to properly close the connection pool when -- unneeded. Use 'withODBCPool' for an automatic resource -- control. -createODBCPool :: (MonadUnliftIO m, MonadLogger m) +createODBCPool :: (MonadUnliftIO m, MonadLoggerIO m) => Maybe DBType -> ConnectionString -- ^ Connection string to the database. @@ -90,7 +90,7 @@ createODBCPool dbt ci = createSqlPool (\lg -> open' lg dbt ci) -- | Same as 'withODBCPool', but instead of opening a pool -- of connections, only one connection is opened. -withODBCConn :: (MonadUnliftIO m, MonadLogger m) +withODBCConn :: (MonadUnliftIO m, MonadLoggerIO m) => Maybe DBType -> ConnectionString -> (SqlBackend -> m a) -> m a withODBCConn dbt cs = withSqlConn (\lg -> open' lg dbt cs) @@ -142,7 +142,9 @@ openSimpleConn logFunc mdbtype conn = do -- Transaction begining means that previous commited , connCommit = const $ O.commit conn , connRollback = const $ O.rollback conn - , connEscapeName = dbmsEscape mig + , connEscapeFieldName = dbmsEscapeFieldName mig + , connEscapeTableName = dbmsEscapeTableName mig + , connEscapeRawName = dbmsEscapeRawName mig , connNoLimit = "" -- esqueleto uses this but needs to use connLimitOffset then we can dump this field , connRDBMS = T.pack $ show (dbmsType mig) , connLimitOffset = dbmsLimitOffset mig diff --git a/src/Database/Persist/ODBCTypes.hs b/src/Database/Persist/ODBCTypes.hs index c977280..3b876ff 100644 --- a/src/Database/Persist/ODBCTypes.hs +++ b/src/Database/Persist/ODBCTypes.hs @@ -23,6 +23,8 @@ data MigrationStrategy = MigrationStrategy { dbmsLimitOffset :: (Int,Int) -> Bool -> Text -> Text ,dbmsMigrate :: [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) ,dbmsInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult - ,dbmsEscape :: DBName -> Text + ,dbmsEscapeFieldName :: FieldNameDB -> Text + ,dbmsEscapeTableName :: EntityDef -> Text + ,dbmsEscapeRawName :: Text -> Text ,dbmsType :: DBType }