Skip to content

Commit 855c20c

Browse files
mercury-kubaKuba Karpierz
mercury-kuba
and
Kuba Karpierz
authored
Add Configuration for Default Cascade Option for Foreign Keys (#1616)
* added mock structured * builds * re-export escape * move show * started adding structured representation to AddTable * make AddTable structured * remove unneeded lines * ran fourmolu * added changelog * Ran fourmolu again * manually add restyle * fix version @SInCE, add newtype to SafeToRemove * updated constructors to better names * remove unneeded partition * move to NEL for reference * fourmolu * move structured migration to internal * fourmolu * remove unused * Removed redundant code from mock migration * tests compile * Fourmolu * fixed typo * update type * fourmolu * update changelog * thread default through * update test * update changelog, comments * styling --------- Co-authored-by: Kuba Karpierz <karpierz@MacBook-Pro-51.local>
1 parent 9d74016 commit 855c20c

9 files changed

Lines changed: 126 additions & 35 deletions

File tree

‎persistent-postgresql/ChangeLog.md‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,10 @@
11
# Changelog for persistent-postgresql
22

3+
# 2.14.3.0
4+
5+
* [#1616](https://github.com/yesodweb/persistent/pull/1616)
6+
* Allow overriding the default cascade option for foreign keys.
7+
38
# 2.14.2.0
49

510
* [#1614](https://github.com/yesodweb/persistent/pull/1614)

‎persistent-postgresql/Database/Persist/Postgresql.hs‎

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -506,7 +506,7 @@ createBackend logFunc serverVersion smap conn =
506506
, connStmtMap = smap
507507
, connInsertSql = insertSql'
508508
, connClose = PG.close conn
509-
, connMigrateSql = migrate'
509+
, connMigrateSql = migrate' emptyBackendSpecificOverrides
510510
, connBegin = \_ mIsolation -> case mIsolation of
511511
Nothing -> PG.begin conn
512512
Just iso ->
@@ -683,11 +683,14 @@ withStmt' conn query vals =
683683
Ok v -> return v
684684

685685
migrate'
686-
:: [EntityDef]
686+
:: BackendSpecificOverrides
687+
-> [EntityDef]
687688
-> (Text -> IO Statement)
688689
-> EntityDef
689690
-> IO (Either [Text] CautiousMigration)
690-
migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ migrateStructured allDefs getter entity
691+
migrate' overrides allDefs getter entity =
692+
fmap (fmap $ map showAlterDb) $
693+
migrateStructured overrides allDefs getter entity
691694

692695
-- | Get the SQL string for the table that a PersistEntity represents.
693696
-- Useful for raw SQL queries.
@@ -821,15 +824,16 @@ defaultPostgresConfHooks =
821824
}
822825

823826
mockMigrate
824-
:: [EntityDef]
827+
:: BackendSpecificOverrides
828+
-> [EntityDef]
825829
-> (Text -> IO Statement)
826830
-> EntityDef
827831
-> IO (Either [Text] [(Bool, Text)])
828-
mockMigrate allDefs _ entity =
832+
mockMigrate overrides allDefs _ entity =
829833
fmap (fmap $ map showAlterDb) $
830834
return $
831835
Right $
832-
mockMigrateStructured allDefs entity
836+
mockMigrateStructured overrides allDefs entity
833837

834838
-- | Mock a migration even when the database is not present.
835839
-- This function performs the same functionality of 'printMigration'
@@ -852,7 +856,7 @@ mockMigration mig = do
852856
, connInsertSql = undefined
853857
, connStmtMap = smap
854858
, connClose = undefined
855-
, connMigrateSql = mockMigrate
859+
, connMigrateSql = mockMigrate emptyBackendSpecificOverrides
856860
, connBegin = undefined
857861
, connCommit = undefined
858862
, connRollback = undefined

‎persistent-postgresql/Database/Persist/Postgresql/Internal/Migration.hs‎

Lines changed: 26 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -39,12 +39,13 @@ import qualified Database.Persist.Sql.Util as Util
3939
--
4040
-- @since 2.17.1.0
4141
migrateStructured
42-
:: [EntityDef]
42+
:: BackendSpecificOverrides
43+
-> [EntityDef]
4344
-> (Text -> IO Statement)
4445
-> EntityDef
4546
-> IO (Either [Text] [AlterDB])
46-
migrateStructured allDefs getter entity =
47-
migrateEntitiesStructured getter allDefs [entity]
47+
migrateStructured overrides allDefs getter entity =
48+
migrateEntitiesStructured overrides getter allDefs [entity]
4849

4950
-- | Returns a structured representation of all of the DB changes required to
5051
-- migrate the listed entities from their current state in the database to the
@@ -54,15 +55,16 @@ migrateStructured allDefs getter entity =
5455
--
5556
-- @since 2.14.1.0
5657
migrateEntitiesStructured
57-
:: (Text -> IO Statement)
58+
:: BackendSpecificOverrides
59+
-> (Text -> IO Statement)
5860
-> [EntityDef]
5961
-> [EntityDef]
6062
-> IO (Either [Text] [AlterDB])
61-
migrateEntitiesStructured getStmt allDefs defsToMigrate = do
63+
migrateEntitiesStructured overrides getStmt allDefs defsToMigrate = do
6264
r <- collectSchemaState getStmt (map getEntityDBName defsToMigrate)
6365
pure $ case r of
6466
Right schemaState ->
65-
migrateEntitiesFromSchemaState schemaState allDefs defsToMigrate
67+
migrateEntitiesFromSchemaState overrides schemaState allDefs defsToMigrate
6668
Left err ->
6769
Left [err]
6870

@@ -73,11 +75,12 @@ migrateEntitiesStructured getStmt allDefs defsToMigrate = do
7375
--
7476
-- @since 2.17.1.0
7577
mockMigrateStructured
76-
:: [EntityDef]
78+
:: BackendSpecificOverrides
79+
-> [EntityDef]
7780
-> EntityDef
7881
-> [AlterDB]
79-
mockMigrateStructured allDefs entity =
80-
migrateEntityFromSchemaState EntityDoesNotExist allDefs entity
82+
mockMigrateStructured overrides allDefs entity =
83+
migrateEntityFromSchemaState overrides EntityDoesNotExist allDefs entity
8184

8285
-- | In order to ensure that generating migrations is fast and avoids N+1
8386
-- queries, we split it into two phases. The first phase involves querying the
@@ -532,19 +535,20 @@ mapLeft _ (Right x) = Right x
532535
mapLeft f (Left x) = Left (f x)
533536

534537
migrateEntitiesFromSchemaState
535-
:: SchemaState
538+
:: BackendSpecificOverrides
539+
-> SchemaState
536540
-> [EntityDef]
537541
-> [EntityDef]
538542
-> Either [Text] [AlterDB]
539-
migrateEntitiesFromSchemaState (SchemaState schemaStateMap) allDefs defsToMigrate =
543+
migrateEntitiesFromSchemaState overrides (SchemaState schemaStateMap) allDefs defsToMigrate =
540544
let
541545
go :: EntityDef -> Either Text [AlterDB]
542546
go entity = do
543547
let
544548
name = getEntityDBName entity
545549
case Map.lookup name schemaStateMap of
546550
Just entityState ->
547-
Right $ migrateEntityFromSchemaState entityState allDefs entity
551+
Right $ migrateEntityFromSchemaState overrides entityState allDefs entity
548552
Nothing ->
549553
Left $ T.pack $ "No entry for entity in schemaState: " <> show name
550554
in
@@ -553,11 +557,12 @@ migrateEntitiesFromSchemaState (SchemaState schemaStateMap) allDefs defsToMigrat
553557
(errs, _) -> Left errs
554558

555559
migrateEntityFromSchemaState
556-
:: EntitySchemaState
560+
:: BackendSpecificOverrides
561+
-> EntitySchemaState
557562
-> [EntityDef]
558563
-> EntityDef
559564
-> [AlterDB]
560-
migrateEntityFromSchemaState schemaState allDefs entity =
565+
migrateEntityFromSchemaState overrides schemaState allDefs entity =
561566
case schemaState of
562567
EntityDoesNotExist ->
563568
(addTable newcols entity) : uniques ++ references ++ foreignsAlt
@@ -577,7 +582,7 @@ migrateEntityFromSchemaState schemaState allDefs entity =
577582
acs' ++ ats'
578583
where
579584
name = getEntityDBName entity
580-
(newcols', udefs, fdefs) = postgresMkColumns allDefs entity
585+
(newcols', udefs, fdefs) = postgresMkColumns overrides allDefs entity
581586
newcols = filter (not . safeToRemove entity . cName) newcols'
582587
udspair = map udToPair udefs
583588

@@ -822,10 +827,13 @@ refName (EntityNameDB table) (FieldNameDB column) =
822827
| otherwise = shortenNames overhead (x, y - 1)
823828

824829
postgresMkColumns
825-
:: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
826-
postgresMkColumns allDefs t =
830+
:: BackendSpecificOverrides
831+
-> [EntityDef]
832+
-> EntityDef
833+
-> ([Column], [UniqueDef], [ForeignDef])
834+
postgresMkColumns overrides allDefs t =
827835
mkColumns allDefs t $
828-
setBackendSpecificForeignKeyName refName emptyBackendSpecificOverrides
836+
setBackendSpecificForeignKeyName refName overrides
829837

830838
-- | Check if a column name is listed as the "safe to remove" in the entity
831839
-- list.

‎persistent-postgresql/persistent-postgresql.cabal‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: persistent-postgresql
2-
version: 2.14.2.0
2+
version: 2.14.3.0
33
license: MIT
44
license-file: LICENSE
55
author: Felipe Lessa, Michael Snoyman <michael@snoyman.com>
@@ -28,7 +28,7 @@ library
2828
, file-embed >=0.0.16
2929
, monad-logger >=0.3.25
3030
, mtl
31-
, persistent >=2.18 && <3
31+
, persistent >=2.18.1 && <3
3232
, postgresql-libpq >=0.9.4.2 && <0.12
3333
, postgresql-simple >=0.6.1 && <0.8
3434
, postgresql-simple-interval >=1 && <1.1

‎persistent-postgresql/test/MigrationSpec.hs‎

Lines changed: 48 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -585,7 +585,12 @@ spec = describe "MigrationSpec" $ do
585585

586586
getter <- getStmtGetter
587587
result <-
588-
liftIO $ migrateEntitiesStructured getter allEntityDefs allEntityDefs
588+
liftIO $
589+
migrateEntitiesStructured
590+
emptyBackendSpecificOverrides
591+
getter
592+
allEntityDefs
593+
allEntityDefs
589594

590595
cleanDB
591596

@@ -602,7 +607,12 @@ spec = describe "MigrationSpec" $ do
602607

603608
getter <- getStmtGetter
604609
result <-
605-
liftIO $ migrateEntitiesStructured getter allEntityDefs allEntityDefs
610+
liftIO $
611+
migrateEntitiesStructured
612+
emptyBackendSpecificOverrides
613+
getter
614+
allEntityDefs
615+
allEntityDefs
606616

607617
cleanDB
608618

@@ -614,7 +624,12 @@ spec = describe "MigrationSpec" $ do
614624
Right alters -> do
615625
traverse_ (flip rawExecute [] . snd . showAlterDb) alters
616626
result2 <-
617-
liftIO $ migrateEntitiesStructured getter allEntityDefs allEntityDefs
627+
liftIO $
628+
migrateEntitiesStructured
629+
emptyBackendSpecificOverrides
630+
getter
631+
allEntityDefs
632+
allEntityDefs
618633
result2 `shouldBe` Right []
619634

620635
it "suggests FK constraints for new fields first time" $ runConnAssert $ do
@@ -624,6 +639,7 @@ spec = describe "MigrationSpec" $ do
624639
result <-
625640
liftIO $
626641
migrateEntitiesStructured
642+
emptyBackendSpecificOverrides
627643
getter
628644
(fkChildV2EntityDef : allEntityDefs)
629645
[fkChildV2EntityDef]
@@ -640,3 +656,32 @@ spec = describe "MigrationSpec" $ do
640656
`shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL"
641657
, "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"
642658
]
659+
660+
it "Uses overrides for empty cascade action" $ runConnAssert $ do
661+
migrateManually
662+
663+
getter <- getStmtGetter
664+
665+
let
666+
overrideWithDefault =
667+
setBackendSpecificForeignKeyCascadeDefault Cascade emptyBackendSpecificOverrides
668+
result <-
669+
liftIO $
670+
migrateEntitiesStructured
671+
overrideWithDefault
672+
getter
673+
(fkChildV2EntityDef : allEntityDefs)
674+
[fkChildV2EntityDef]
675+
676+
cleanDB
677+
678+
case result of
679+
Right [] ->
680+
pure ()
681+
Left err ->
682+
expectationFailure $ show err
683+
Right alters ->
684+
map (snd . showAlterDb) alters
685+
`shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL"
686+
, "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"
687+
]

‎persistent/ChangeLog.md‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
11
# Changelog for persistent
22

3-
# Unreleased
3+
# 2.18.1.0
4+
* [#1616](https://github.com/yesodweb/persistent/pull/1616)
5+
* Allow overriding the default cascade option for foreign keys.
46
* [#1608](https://github.com/yesodweb/persistent/pull/1608)
57
* Improves documentation on getBy with nullable fields
68
* Updates the warning text present when you try to make a Unique field that is nullable

‎persistent/Database/Persist/Sql.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,8 @@ module Database.Persist.Sql
6161
, emptyBackendSpecificOverrides
6262
, getBackendSpecificForeignKeyName
6363
, setBackendSpecificForeignKeyName
64+
, getBackendSpecificForeignKeyCascadeDefault
65+
, setBackendSpecificForeignKeyCascadeDefault
6466
, defaultAttribute
6567

6668
-- * Internal

‎persistent/Database/Persist/Sql/Internal.hs‎

Lines changed: 28 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,8 @@ module Database.Persist.Sql.Internal
1010
, BackendSpecificOverrides (..)
1111
, getBackendSpecificForeignKeyName
1212
, setBackendSpecificForeignKeyName
13+
, getBackendSpecificForeignKeyCascadeDefault
14+
, setBackendSpecificForeignKeyCascadeDefault
1315
, emptyBackendSpecificOverrides
1416
) where
1517

@@ -36,6 +38,7 @@ import Database.Persist.Types
3638
data BackendSpecificOverrides = BackendSpecificOverrides
3739
{ backendSpecificForeignKeyName
3840
:: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
41+
, backendSpecificForeignKeyCascadeDefault :: CascadeAction
3942
}
4043

4144
-- | If the override is defined, then this returns a function that accepts an
@@ -61,14 +64,34 @@ setBackendSpecificForeignKeyName
6164
setBackendSpecificForeignKeyName func bso =
6265
bso{backendSpecificForeignKeyName = Just func}
6366

67+
-- | If the override is defined, then this specifies what cascade action
68+
-- should be used if there is none defined for the column.
69+
--
70+
-- @since 2.18.1.0
71+
getBackendSpecificForeignKeyCascadeDefault
72+
:: BackendSpecificOverrides
73+
-> CascadeAction
74+
getBackendSpecificForeignKeyCascadeDefault =
75+
backendSpecificForeignKeyCascadeDefault
76+
77+
-- | Set the backend's default cascade action.
78+
--
79+
-- @since 2.18.1.0
80+
setBackendSpecificForeignKeyCascadeDefault
81+
:: CascadeAction
82+
-> BackendSpecificOverrides
83+
-> BackendSpecificOverrides
84+
setBackendSpecificForeignKeyCascadeDefault action bso =
85+
bso{backendSpecificForeignKeyCascadeDefault = action}
86+
6487
findMaybe :: (a -> Maybe b) -> [a] -> Maybe b
6588
findMaybe p = listToMaybe . mapMaybe p
6689

6790
-- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides)
6891
--
6992
-- @since 2.11
7093
emptyBackendSpecificOverrides :: BackendSpecificOverrides
71-
emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing
94+
emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing Restrict
7295

7396
defaultAttribute :: [FieldAttr] -> Maybe Text
7497
defaultAttribute = findMaybe $ \case
@@ -171,9 +194,11 @@ mkColumns allDefs t overrides =
171194
-- explicitly makes migrations run smoother.
172195
overrideNothings (FieldCascade{fcOnUpdate = upd, fcOnDelete = del}) =
173196
FieldCascade
174-
{ fcOnUpdate = upd <|> Just Restrict
175-
, fcOnDelete = del <|> Just Restrict
197+
{ fcOnUpdate = upd <|> Just defaultAction
198+
, fcOnDelete = del <|> Just defaultAction
176199
}
200+
where
201+
defaultAction = (backendSpecificForeignKeyCascadeDefault overrides)
177202

178203
ref
179204
:: FieldNameDB

‎persistent/persistent.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: persistent
2-
version: 2.18.0.0
2+
version: 2.18.1.0
33
license: MIT
44
license-file: LICENSE
55
author: Michael Snoyman <michael@snoyman.com>

0 commit comments

Comments
 (0)