Skip to content

Commit a11ccc2

Browse files
Kuba KarpierzKuba Karpierz
Kuba Karpierz
authored and
Kuba Karpierz
committed
thread default through
1 parent 4e18715 commit a11ccc2

File tree

5 files changed

+122
-34
lines changed

5 files changed

+122
-34
lines changed

‎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/test/MigrationSpec.hs‎

Lines changed: 51 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -67,7 +67,7 @@ FKChildV1 sql=migration_fk_child
6767

6868
-- Simulate creating a new FK field on an existing table
6969
FKChildV2 sql=migration_fk_child
70-
parentId FKParentId
70+
parentId FKParentId OnUpdateNoAction
7171

7272
ExplicitPrimaryKey sql=explicit_primary_key
7373
Id Text
@@ -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,37 @@ spec = describe "MigrationSpec" $ do
624639
result <-
625640
liftIO $
626641
migrateEntitiesStructured
642+
emptyBackendSpecificOverrides
643+
getter
644+
(fkChildV2EntityDef : allEntityDefs)
645+
[fkChildV2EntityDef]
646+
647+
cleanDB
648+
649+
case result of
650+
Right [] ->
651+
pure ()
652+
Left err ->
653+
expectationFailure $ show err
654+
Right alters ->
655+
map (snd . showAlterDb) alters
656+
`shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL"
657+
, "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 NO ACTION"
658+
]
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+
)
669+
result <-
670+
liftIO $
671+
migrateEntitiesStructured
672+
overrideWithDefault
627673
getter
628674
(fkChildV2EntityDef : allEntityDefs)
629675
[fkChildV2EntityDef]
@@ -638,5 +684,5 @@ spec = describe "MigrationSpec" $ do
638684
Right alters ->
639685
map (snd . showAlterDb) alters
640686
`shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL"
641-
, "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"
687+
, "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 NO ACTION"
642688
]

‎persistent/Database/Persist/Sql.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@
99
-- Then, you'll use the operations
1010
module Database.Persist.Sql
1111
( -- * 'RawSql' and 'PersistFieldSql'
12-
module Database.Persist.Sql.Class
12+
module Database.Persist.Sql.Class
1313

1414
-- * Running actions
1515

@@ -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: 31 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,37 @@ setBackendSpecificForeignKeyName
6164
setBackendSpecificForeignKeyName func bso =
6265
bso{backendSpecificForeignKeyName = Just func}
6366

67+
-- | If the override is defined, then this returns a function that accepts an
68+
-- entity name and field name and provides the 'ConstraintNameDB' for the
69+
-- foreign key constraint.
70+
--
71+
-- An abstract accessor for the 'BackendSpecificOverrides'
72+
--
73+
-- @since 2.13.0.0
74+
getBackendSpecificForeignKeyCascadeDefault
75+
:: BackendSpecificOverrides
76+
-> CascadeAction
77+
getBackendSpecificForeignKeyCascadeDefault =
78+
backendSpecificForeignKeyCascadeDefault
79+
80+
-- | Set the backend's foreign key generation function to this value.
81+
--
82+
-- @since 2.13.0.0
83+
setBackendSpecificForeignKeyCascadeDefault
84+
:: CascadeAction
85+
-> BackendSpecificOverrides
86+
-> BackendSpecificOverrides
87+
setBackendSpecificForeignKeyCascadeDefault action bso =
88+
bso{backendSpecificForeignKeyCascadeDefault = action}
89+
6490
findMaybe :: (a -> Maybe b) -> [a] -> Maybe b
6591
findMaybe p = listToMaybe . mapMaybe p
6692

6793
-- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides)
6894
--
6995
-- @since 2.11
7096
emptyBackendSpecificOverrides :: BackendSpecificOverrides
71-
emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing
97+
emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing Restrict
7298

7399
defaultAttribute :: [FieldAttr] -> Maybe Text
74100
defaultAttribute = findMaybe $ \case
@@ -171,9 +197,11 @@ mkColumns allDefs t overrides =
171197
-- explicitly makes migrations run smoother.
172198
overrideNothings (FieldCascade{fcOnUpdate = upd, fcOnDelete = del}) =
173199
FieldCascade
174-
{ fcOnUpdate = upd <|> Just Restrict
175-
, fcOnDelete = del <|> Just Restrict
200+
{ fcOnUpdate = upd <|> Just defaultAction
201+
, fcOnDelete = del <|> Just defaultAction
176202
}
203+
where
204+
defaultAction = (backendSpecificForeignKeyCascadeDefault overrides)
177205

178206
ref
179207
:: FieldNameDB

0 commit comments

Comments
 (0)