diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent-postgresql +# 2.14.3.0 + +* [#1616](https://github.com/yesodweb/persistent/pull/1616) + * Allow overriding the default cascade option for foreign keys. + # 2.14.2.0 * [#1614](https://github.com/yesodweb/persistent/pull/1614) diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -506,7 +506,7 @@ , connStmtMap = smap , connInsertSql = insertSql' , connClose = PG.close conn - , connMigrateSql = migrate' + , connMigrateSql = migrate' emptyBackendSpecificOverrides , connBegin = \_ mIsolation -> case mIsolation of Nothing -> PG.begin conn Just iso -> @@ -683,11 +683,14 @@ Ok v -> return v migrate' - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] CautiousMigration) -migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ migrateStructured allDefs getter entity +migrate' overrides allDefs getter entity = + fmap (fmap $ map showAlterDb) $ + migrateStructured overrides allDefs getter entity -- | Get the SQL string for the table that a PersistEntity represents. -- Useful for raw SQL queries. @@ -821,15 +824,16 @@ } mockMigrate - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) -mockMigrate allDefs _ entity = +mockMigrate overrides allDefs _ entity = fmap (fmap $ map showAlterDb) $ return $ Right $ - mockMigrateStructured allDefs entity + mockMigrateStructured overrides allDefs entity -- | Mock a migration even when the database is not present. -- This function performs the same functionality of 'printMigration' @@ -852,7 +856,7 @@ , connInsertSql = undefined , connStmtMap = smap , connClose = undefined - , connMigrateSql = mockMigrate + , connMigrateSql = mockMigrate emptyBackendSpecificOverrides , connBegin = undefined , connCommit = undefined , connRollback = undefined diff --git a/Database/Persist/Postgresql/Internal/Migration.hs b/Database/Persist/Postgresql/Internal/Migration.hs --- a/Database/Persist/Postgresql/Internal/Migration.hs +++ b/Database/Persist/Postgresql/Internal/Migration.hs @@ -39,12 +39,13 @@ -- -- @since 2.17.1.0 migrateStructured - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [AlterDB]) -migrateStructured allDefs getter entity = - migrateEntitiesStructured getter allDefs [entity] +migrateStructured overrides allDefs getter entity = + migrateEntitiesStructured overrides getter allDefs [entity] -- | Returns a structured representation of all of the DB changes required to -- migrate the listed entities from their current state in the database to the @@ -54,15 +55,16 @@ -- -- @since 2.14.1.0 migrateEntitiesStructured - :: (Text -> IO Statement) + :: BackendSpecificOverrides + -> (Text -> IO Statement) -> [EntityDef] -> [EntityDef] -> IO (Either [Text] [AlterDB]) -migrateEntitiesStructured getStmt allDefs defsToMigrate = do +migrateEntitiesStructured overrides getStmt allDefs defsToMigrate = do r <- collectSchemaState getStmt (map getEntityDBName defsToMigrate) pure $ case r of Right schemaState -> - migrateEntitiesFromSchemaState schemaState allDefs defsToMigrate + migrateEntitiesFromSchemaState overrides schemaState allDefs defsToMigrate Left err -> Left [err] @@ -73,11 +75,12 @@ -- -- @since 2.17.1.0 mockMigrateStructured - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> EntityDef -> [AlterDB] -mockMigrateStructured allDefs entity = - migrateEntityFromSchemaState EntityDoesNotExist allDefs entity +mockMigrateStructured overrides allDefs entity = + migrateEntityFromSchemaState overrides EntityDoesNotExist allDefs entity -- | In order to ensure that generating migrations is fast and avoids N+1 -- queries, we split it into two phases. The first phase involves querying the @@ -532,11 +535,12 @@ mapLeft f (Left x) = Left (f x) migrateEntitiesFromSchemaState - :: SchemaState + :: BackendSpecificOverrides + -> SchemaState -> [EntityDef] -> [EntityDef] -> Either [Text] [AlterDB] -migrateEntitiesFromSchemaState (SchemaState schemaStateMap) allDefs defsToMigrate = +migrateEntitiesFromSchemaState overrides (SchemaState schemaStateMap) allDefs defsToMigrate = let go :: EntityDef -> Either Text [AlterDB] go entity = do @@ -544,7 +548,7 @@ name = getEntityDBName entity case Map.lookup name schemaStateMap of Just entityState -> - Right $ migrateEntityFromSchemaState entityState allDefs entity + Right $ migrateEntityFromSchemaState overrides entityState allDefs entity Nothing -> Left $ T.pack $ "No entry for entity in schemaState: " <> show name in @@ -553,11 +557,12 @@ (errs, _) -> Left errs migrateEntityFromSchemaState - :: EntitySchemaState + :: BackendSpecificOverrides + -> EntitySchemaState -> [EntityDef] -> EntityDef -> [AlterDB] -migrateEntityFromSchemaState schemaState allDefs entity = +migrateEntityFromSchemaState overrides schemaState allDefs entity = case schemaState of EntityDoesNotExist -> (addTable newcols entity) : uniques ++ references ++ foreignsAlt @@ -577,7 +582,7 @@ acs' ++ ats' where name = getEntityDBName entity - (newcols', udefs, fdefs) = postgresMkColumns allDefs entity + (newcols', udefs, fdefs) = postgresMkColumns overrides allDefs entity newcols = filter (not . safeToRemove entity . cName) newcols' udspair = map udToPair udefs @@ -822,10 +827,13 @@ | otherwise = shortenNames overhead (x, y - 1) postgresMkColumns - :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -postgresMkColumns allDefs t = + :: BackendSpecificOverrides + -> [EntityDef] + -> EntityDef + -> ([Column], [UniqueDef], [ForeignDef]) +postgresMkColumns overrides allDefs t = mkColumns allDefs t $ - setBackendSpecificForeignKeyName refName emptyBackendSpecificOverrides + setBackendSpecificForeignKeyName refName overrides -- | Check if a column name is listed as the "safe to remove" in the entity -- list. diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.14.2.0 +version: 2.14.3.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -28,7 +28,7 @@ , file-embed >=0.0.16 , monad-logger >=0.3.25 , mtl - , persistent >=2.18 && <3 + , persistent >=2.18.1 && <3 , postgresql-libpq >=0.9.4.2 && <0.12 , postgresql-simple >=0.6.1 && <0.8 , postgresql-simple-interval >=1 && <1.1 diff --git a/test/MigrationSpec.hs b/test/MigrationSpec.hs --- a/test/MigrationSpec.hs +++ b/test/MigrationSpec.hs @@ -585,7 +585,12 @@ getter <- getStmtGetter result <- - liftIO $ migrateEntitiesStructured getter allEntityDefs allEntityDefs + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + allEntityDefs + allEntityDefs cleanDB @@ -602,7 +607,12 @@ getter <- getStmtGetter result <- - liftIO $ migrateEntitiesStructured getter allEntityDefs allEntityDefs + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + allEntityDefs + allEntityDefs cleanDB @@ -614,7 +624,12 @@ Right alters -> do traverse_ (flip rawExecute [] . snd . showAlterDb) alters result2 <- - liftIO $ migrateEntitiesStructured getter allEntityDefs allEntityDefs + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + allEntityDefs + allEntityDefs result2 `shouldBe` Right [] it "suggests FK constraints for new fields first time" $ runConnAssert $ do @@ -624,6 +639,7 @@ result <- liftIO $ migrateEntitiesStructured + emptyBackendSpecificOverrides getter (fkChildV2EntityDef : allEntityDefs) [fkChildV2EntityDef] @@ -639,4 +655,33 @@ map (snd . showAlterDb) alters `shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL" , "ALTER TABLE \"migration_fk_child\" ADD CONSTRAINT \"migration_fk_child_parent_id_fkey\" FOREIGN KEY(\"parent_id\") REFERENCES \"migration_fk_parent\"(\"id\") ON DELETE RESTRICT ON UPDATE RESTRICT" + ] + + it "Uses overrides for empty cascade action" $ runConnAssert $ do + migrateManually + + getter <- getStmtGetter + + let + overrideWithDefault = + setBackendSpecificForeignKeyCascadeDefault Cascade emptyBackendSpecificOverrides + result <- + liftIO $ + migrateEntitiesStructured + overrideWithDefault + getter + (fkChildV2EntityDef : allEntityDefs) + [fkChildV2EntityDef] + + cleanDB + + case result of + Right [] -> + pure () + Left err -> + expectationFailure $ show err + Right alters -> + map (snd . showAlterDb) alters + `shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL" + , "ALTER TABLE \"migration_fk_child\" ADD CONSTRAINT \"migration_fk_child_parent_id_fkey\" FOREIGN KEY(\"parent_id\") REFERENCES \"migration_fk_parent\"(\"id\") ON DELETE CASCADE ON UPDATE CASCADE" ]