Add support for foreign key constraints & actions

This commit adds support for foreign key constraints and actions to
`beam-migrate`, with support in the Postgres and SQLite backends:

  - The `ForeignKeyAction` datatype is used to represent possible
    actions to perform when updating or deleting a row with referencing
    foreign keys.
  - `createTableActionProvider` now takes an additional
    `ForeignKeySupport` argument: a witness of evidence for
    `IsSql92ForeignKeyTableConstraintSyntax` for backends that
    support it.
  - Postgres and SQLite support for parsing existing foreign key
    constraints.
  - Introduce the `addTableForeignKey` function for declaring new
    foreign key constraints.

Author: sheaf

beam-migrate/ChangeLog.md

@@ -1,3 +1,19 @@
+
+# Unreleased
+
+## Added features
+
+* Added support for foreign key constraints:
+
+  * New `ForeignKeyAction` datatype representing possible actions when updating
+    or deleting a row with referencing foreign keys.
+  * New `IsSql92ForeignKeyTableConstraintSyntax` typeclass with method
+    `foreignKeyConstraintSyntax` for constructing foreign key constraint syntax.
+  * `createTableActionProvider` now takes an additional `ForeignKeySupport`
+    argument: a witness of evidence for `IsSql92ForeignKeyTableConstraintSyntax`
+    for backends that support it.
+  * Introduce `addTableForeignKey` for declaring new foreign key constraints.
+
 # 0.5.4.0
 
 ## Added features

beam-migrate/Database/Beam/Migrate/Actions.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -78,6 +79,7 @@ module Database.Beam.Migrate.Actions
   , ensuringNot_
   , justOne_
 
+  , ForeignKeySupport(..)
   , createSchemaActionProvider
   , createTableActionProvider
   , dropTableActionProvider
@@ -107,6 +109,7 @@ import           Control.Monad
 import           Control.Parallel.Strategies
 
 import           Data.Foldable
+import qualified Data.List.NonEmpty as NE
 
 import qualified Data.HashMap.Strict as HM
 import qualified Data.HashSet as HS
@@ -279,6 +282,16 @@ createIndexWeight, dropIndexWeight :: Int
 createIndexWeight = 200
 dropIndexWeight = 50
 
+-- | Witness for whether a backend's table constraint syntax supports
+-- @FOREIGN KEY@ clauses in @CREATE TABLE@ statements.
+data ForeignKeySupport be where
+  -- | The backend supports @FOREIGN KEY@ constraints in @CREATE TABLE@.
+  ForeignKeySupported
+    :: IsSql92ForeignKeyTableConstraintSyntax (BeamSqlBackendTableConstraintSyntax be)
+    => ForeignKeySupport be
+  -- | The backend does not support @FOREIGN KEY@ constraints.
+  ForeignKeyUnsupported :: ForeignKeySupport be
+
 -- | Proceeds only if no predicate matches the given pattern. See the
 -- implementation of 'dropTableActionProvider' for an example of usage.
 ensuringNot_ :: Alternative m => [ a ] -> m ()
@@ -342,10 +355,13 @@ dropSchemaActionProvider =
                               ("Drop schema " <> preSchemaNm) dropSchemaWeight)
 
 -- | Action provider for SQL92 @CREATE TABLE@ actions.
-createTableActionProvider :: forall be
-                           . ( Typeable be, BeamMigrateOnlySqlBackend be )
-                          => ActionProvider be
-createTableActionProvider =
+createTableActionProvider
+  :: forall be
+   . ( Typeable be, BeamMigrateOnlySqlBackend be )
+  => ForeignKeySupport be
+       -- ^ a witness of whether the backend supports FOREIGN KEY constraints
+  -> ActionProvider be
+createTableActionProvider fkSupport =
   ActionProvider provider
   where
     provider :: ActionProviderFn be
@@ -377,9 +393,45 @@ createTableActionProvider =
            guard (tblNm == postTblNm)
            pure (primaryKeyP, primaryKey)
 
-         let postConditions = [ p tblP, p primaryKeyP ] ++ concat columnsP
+         let (fkPs, fkConstraints) = case fkSupport of
+               ForeignKeySupported ->
+                 unzip
+                   [ ( p fkP
+                     , foreignKeyConstraintSyntax localCols (qnameAsText refTbl) refCols onUpd onDel )
+                   | fkP@(TableHasForeignKey tblNm localCols refTbl refCols onUpd onDel)
+                       <- findPostConditions
+                   , tblNm == postTblNm
+                   ]
+               ForeignKeyUnsupported -> ([], [])
+
+         -- For each foreign key constraint, ensure the referenced table
+         -- already exists in the current state.
+         -- This enforces a topological ordering, so that the solver schedules
+         -- CREATE TABLE for all referenced tables first.
+         --
+         -- Note: this does not support cycles in the foreign key reference graph,
+         -- for which we would need ALTER TABLE ADD CONSTRAINT, which we don't
+         -- currently support.
+         case fkSupport of
+           ForeignKeyUnsupported -> pure ()
+           ForeignKeySupported -> do
+             let refTbls =
+                   [ refTbl
+                   | TableHasForeignKey tblNm _ refTbl _ _ _ <- findPostConditions
+                   , tblNm == postTblNm
+                   , refTbl /= postTblNm
+                   ]
+             for_ refTbls $ \refTbl -> do
+               TableExistsPredicate nm <- findPreConditions
+               guard (nm == refTbl)
+
+
+         let postConditions = [ p tblP, p primaryKeyP ] ++ concat columnsP ++ fkPs
              cmd = createTableCmd (createTableSyntax Nothing (qnameAsTableName postTblNm) colsSyntax tblConstraints)
-             tblConstraints = if null primaryKey then [] else [ primaryKeyConstraintSyntax primaryKey ]
+             tblConstraints = (case NE.nonEmpty primaryKey of
+                                Nothing   -> []
+                                Just pkey -> [primaryKeyConstraintSyntax pkey])
+                           ++ fkConstraints
              colsSyntax = map (\(colNm, type_, cs) -> (colNm, columnSchemaSyntax type_ Nothing cs Nothing)) columns
          pure (PotentialAction mempty (HS.fromList postConditions)
                                (Seq.singleton (MigrationCommand cmd MigrationKeepsData))
@@ -590,17 +642,18 @@ dropIndexActionProvider = ActionProvider provider
 -- For default schema actions, see 'defaultSchemaActionProvider'.
 defaultActionProvider :: ( Typeable be
                          , BeamMigrateOnlySqlBackend be )
-                      => ActionProvider be
-defaultActionProvider =
+                      => ForeignKeySupport be
+                      -> ActionProvider be
+defaultActionProvider fkSupport =
   mconcat
-  [ createTableActionProvider
+  [ createTableActionProvider fkSupport
   , dropTableActionProvider
 
   , addColumnProvider
   , dropColumnProvider
 
   , addColumnNullProvider
-  , dropColumnNullProvider 
+  , dropColumnNullProvider
   ]
 
 -- | Default action providers for any syntax which supports schemas.

beam-migrate/Database/Beam/Migrate/Checks.hs

@@ -11,7 +11,8 @@ import Database.Beam.Migrate.SQL.Types
 import Database.Beam.Migrate.Serialization
 import Database.Beam.Migrate.Types.Predicates
 
-import Data.Aeson ((.:), (.=), withObject, object)
+import Data.Aeson ((.:), (.:?), (.=), withObject, object)
+import Data.Maybe (fromMaybe)
 import Data.Aeson.Types (Parser, Value)
 import Data.Hashable (Hashable(..))
 import qualified Data.List.NonEmpty as NE (NonEmpty)
@@ -168,6 +169,67 @@ instance DatabasePredicate TableHasPrimaryKey where
     | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm
     | otherwise = False
 
+-- | Asserts that the given table has a foreign key referencing another table.
+-- Create these predicates with
+-- 'Database.Beam.Migrate.Types.CheckedEntities.addTableForeignKey'.
+data TableHasForeignKey
+  = TableHasForeignKey
+  { hasForeignKey_table      :: QualifiedName      -- ^ source table
+  , hasForeignKey_columns    :: NE.NonEmpty Text   -- ^ local columns (in order)
+  , hasForeignKey_refTable   :: QualifiedName      -- ^ referenced table
+  , hasForeignKey_refColumns :: NE.NonEmpty Text   -- ^ referenced columns (in order)
+  , hasForeignKey_onUpdate   :: ForeignKeyAction
+  , hasForeignKey_onDelete   :: ForeignKeyAction
+  } deriving (Show, Eq, Generic)
+instance Hashable TableHasForeignKey
+instance DatabasePredicate TableHasForeignKey where
+  englishDescription (TableHasForeignKey { hasForeignKey_table = tbl
+                                         , hasForeignKey_columns = cols
+                                         , hasForeignKey_refTable = refTbl
+                                         , hasForeignKey_refColumns = refCols
+                                         , hasForeignKey_onUpdate = onUpd
+                                         , hasForeignKey_onDelete = onDel }) =
+    "Table " <> show tbl <> " has foreign key on " <> show cols <>
+    " referencing " <> show refTbl <> " " <> show refCols <>
+    " ON UPDATE " <> show onUpd <>
+    " ON DELETE " <> show onDel
+
+  predicateSpecificity _ = PredicateSpecificityAllBackends
+
+  serializePredicate (TableHasForeignKey { hasForeignKey_table = tbl
+                                         , hasForeignKey_columns = cols
+                                         , hasForeignKey_refTable = refTbl
+                                         , hasForeignKey_refColumns = refCols
+                                         , hasForeignKey_onUpdate = onUpd
+                                         , hasForeignKey_onDelete = onDel }) =
+    object [ "has-foreign-key" .= object
+               [ "table"       .= tbl
+               , "columns"     .= cols
+               , "ref-table"   .= refTbl
+               , "ref-columns" .= refCols
+               , "on-update"   .= serializeForeignKeyAction onUpd
+               , "on-delete"   .= serializeForeignKeyAction onDel
+               ] ]
+
+  predicateCascadesDropOn (TableHasForeignKey { hasForeignKey_table = tblNm }) p'
+    | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm
+    | otherwise = False
+
+serializeForeignKeyAction :: ForeignKeyAction -> Text
+serializeForeignKeyAction ForeignKeyActionCascade    = "cascade"
+serializeForeignKeyAction ForeignKeyActionSetNull    = "set-null"
+serializeForeignKeyAction ForeignKeyActionSetDefault = "set-default"
+serializeForeignKeyAction ForeignKeyActionRestrict   = "restrict"
+serializeForeignKeyAction ForeignKeyNoAction         = "no-action"
+
+deserializeForeignKeyAction :: Text -> Maybe ForeignKeyAction
+deserializeForeignKeyAction "cascade"     = Just ForeignKeyActionCascade
+deserializeForeignKeyAction "set-null"    = Just ForeignKeyActionSetNull
+deserializeForeignKeyAction "set-default" = Just ForeignKeyActionSetDefault
+deserializeForeignKeyAction "restrict"    = Just ForeignKeyActionRestrict
+deserializeForeignKeyAction "no-action"   = Just ForeignKeyNoAction
+deserializeForeignKeyAction _             = Nothing
+
 -- * Deserialization
 
 -- | 'BeamDeserializers' for all the predicates defined in this module
@@ -182,6 +244,7 @@ beamCheckDeserializers = mconcat
   , beamDeserializer (const deserializeTableExistsPredicate)
   , beamDeserializer (const deserializeTableHasPrimaryKeyPredicate)
   , beamDeserializer (const deserializeTableHasIndexPredicate)
+  , beamDeserializer (const deserializeTableHasForeignKeyPredicate)
   , beamDeserializer deserializeTableHasColumnPredicate
   , beamDeserializer deserializeTableColumnHasConstraintPredicate
   ]
@@ -214,6 +277,20 @@ beamCheckDeserializers = mconcat
                         <*> v' .: "columns"
                         <*> (deserializeIndexOptions @(BeamSqlBackendSyntax be) =<< v' .: "options")))
 
+    deserializeTableHasForeignKeyPredicate :: Value -> Parser SomeDatabasePredicate
+    deserializeTableHasForeignKeyPredicate =
+      withObject "TableHasForeignKey" $ \v ->
+      v .: "has-foreign-key" >>=
+      (withObject "TableHasForeignKey" $ \v' ->
+       SomeDatabasePredicate <$>
+         (TableHasForeignKey
+           <$> v' .: "table"
+           <*> v' .: "columns"
+           <*> v' .: "ref-table"
+           <*> v' .: "ref-columns"
+           <*> (fromMaybe ForeignKeyNoAction . (>>= deserializeForeignKeyAction) <$> v' .:? "on-update")
+           <*> (fromMaybe ForeignKeyNoAction . (>>= deserializeForeignKeyAction) <$> v' .:? "on-delete")))
+
     deserializeTableHasColumnPredicate :: BeamDeserializers be'
                                        -> Value -> Parser SomeDatabasePredicate
     deserializeTableHasColumnPredicate d =

beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs

@@ -17,7 +17,8 @@ import Data.Hashable
 import Data.Kind (Type)
 import qualified Data.List.NonEmpty as NE (NonEmpty)
 import Data.Text (Text)
-import Data.Typeable
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
 
 -- * Convenience type synonyms
 
@@ -184,8 +185,40 @@ class ( IsSql92ColumnConstraintDefinitionSyntax (Sql92ColumnSchemaColumnConstrai
                      -> Maybe Text {-^ Default collation -}
                      -> columnSchema
 
+-- | Action to perform on referencing foreign keys when a row is modified.
+data ForeignKeyAction
+  = ForeignKeyActionCascade
+    -- ^ @CASCADE@: propagate the action to referencing foreign key columns.
+  | ForeignKeyActionSetNull
+    -- ^ @SET NULL@: set the referencing foreign key colums to @NULL@.
+  | ForeignKeyActionSetDefault
+    -- ^ @SET DEFAULT@: set the referencing foreign key columns to their default
+    -- values.
+  | ForeignKeyActionRestrict
+    -- ^ @RESTRICT@: prohibit modification of a row when foreign key references
+    -- to that row exist.
+  | ForeignKeyNoAction
+    -- ^ @NO ACTION@
+  deriving (Show, Eq, Ord, Generic)
+instance Hashable ForeignKeyAction
+
 class Typeable constraint => IsSql92TableConstraintSyntax constraint where
-  primaryKeyConstraintSyntax :: [ Text ] -> constraint
+  primaryKeyConstraintSyntax :: NE.NonEmpty Text -> constraint
+
+-- | Class for table constraint syntaxes that support the SQL @FOREIGN KEY@
+-- clause.
+class IsSql92TableConstraintSyntax constraint =>
+    IsSql92ForeignKeyTableConstraintSyntax constraint where
+  -- | Emit a @FOREIGN KEY (cols) REFERENCES tbl (refCols)@ table constraint.
+  --
+  -- Use 'addTableForeignKey' to attach a foreign key to a schema definition.
+  foreignKeyConstraintSyntax
+    :: NE.NonEmpty Text  -- ^ local columns
+    -> Text              -- ^ referenced table name
+    -> NE.NonEmpty Text  -- ^ referenced columns
+    -> ForeignKeyAction  -- ^ ON UPDATE action
+    -> ForeignKeyAction  -- ^ ON DELETE action
+    -> constraint
 
 class Typeable match => IsSql92MatchTypeSyntax match where
   fullMatchSyntax :: match

beam-migrate/Database/Beam/Migrate/SQL/Types.hs

@@ -19,6 +19,7 @@ module Database.Beam.Migrate.SQL.Types
   , BeamSqlBackendReferentialActionSyntax
   , BeamSqlBackendConstraintAttributesSyntax
   , BeamSqlBackendIndexSyntax
+  , BeamSqlBackendTableConstraintSyntax
   ) where
 
 import Database.Beam.Migrate.Types.Predicates
@@ -93,4 +94,6 @@ type BeamSqlBackendReferentialActionSyntax be
 type BeamSqlBackendConstraintAttributesSyntax be
   = Sql92DdlCommandConstraintAttributesSyntax (BeamSqlBackendSyntax be)
 type BeamSqlBackendIndexSyntax be
-  = Sql92CreateIndexOptionsSyntax (BeamSqlBackendSyntax be)
+  = Sql92CreateIndexOptionsSyntax (BeamSqlBackendSyntax be)
+type BeamSqlBackendTableConstraintSyntax be
+  = Sql92CreateTableTableConstraintSyntax (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))

beam-migrate/Database/Beam/Migrate/Simple.hs

@@ -372,7 +372,7 @@ haskellSchema BeamMigrationBackend { backendGetDbConstraints = getCs
   constraints <- getCs
   let hsConstraints = [ hsConstraint | c <- constraints, Just hsConstraint <- [ conv2Hs c ] ]
 
-      solver = heuristicSolver (defaultActionProvider @HsMigrateBackend) [] hsConstraints
+      solver = heuristicSolver (defaultActionProvider @HsMigrateBackend ForeignKeyUnsupported) [] hsConstraints
 
   case finalSolution solver of
     Solved cmds   ->

beam-migrate/Database/Beam/Migrate/Types.hs

@@ -30,6 +30,9 @@ module Database.Beam.Migrate.Types
 
   , IsSql92CreateDropIndexSyntax(..)
 
+  , addTableForeignKey
+  , primaryKeyColumns
+
     -- * Predicates
   , DatabasePredicate(..)
   , SomeDatabasePredicate(..)

beam-migrate/Database/Beam/Migrate/Types/CheckedEntities.hs

@@ -298,6 +298,43 @@ addTableIndex idxNm opts getCols =
     in CheckedDatabaseEntity (CheckedDatabaseTable dt (tblChecks ++ [idxCheck]) fieldChecks)
                              extraChecks
 
+-- | Declare a foreign key constraint on a checked table entity.
+--
+-- Example referencing the primary key of a @UserT@ table:
+--
+-- @
+-- addTableForeignKey (db ^. usersTable)
+--   (\\ t -> selectorColumnName _postAuthorId t NE.:| [])
+--   primaryKeyColumns
+--   ForeignKeyNoAction    -- ON UPDATE action
+--   ForeignKeyActionCascade -- ON DELETE action
+-- @
+addTableForeignKey
+  :: forall be db localTbl refTbl.
+     (Table localTbl, Table refTbl)
+  => CheckedDatabaseEntity be db (TableEntity refTbl)         -- ^ referenced table
+  -> (localTbl (TableField localTbl) -> NE.NonEmpty Text)     -- ^ local columns
+  -> (refTbl (TableField refTbl) -> NE.NonEmpty Text)         -- ^ referenced columns
+  -> ForeignKeyAction -- ^ ON UPDATE action
+  -> ForeignKeyAction -- ^ ON DELETE action
+  -> EntityModification (CheckedDatabaseEntity be db) be (TableEntity localTbl)
+addTableForeignKey refTableEntity getLocalFk getRefFk onUpdate onDelete =
+  EntityModification $ Endo $
+  \(CheckedDatabaseEntity (CheckedDatabaseTable dt tblChecks fieldChecks) extraChecks) ->
+    let
+        CheckedDatabaseEntity (CheckedDatabaseTable refDt _ _) _ = refTableEntity
+        refTableName = QualifiedName (dbTableSchema refDt) (dbTableCurrentName refDt)
+
+        localCols = getLocalFk (dbTableSettings dt)
+        refCols   = getRefFk (dbTableSettings refDt)
+
+        fkCheck = TableCheck $ \tblNm _flds ->
+          Just (SomeDatabasePredicate
+                  (TableHasForeignKey tblNm localCols refTableName refCols onUpdate onDelete))
+
+    in CheckedDatabaseEntity (CheckedDatabaseTable dt (tblChecks ++ [fkCheck]) fieldChecks)
+                             extraChecks
+
 -- | Produce a table field modification that does nothing
 --
 --   Most commonly supplied as the second argument to 'modifyCheckedTable' when

beam-postgres/ChangeLog.md

@@ -1,3 +1,10 @@
+# Unreleased
+
+## Added features
+
+* `getDbConstraintsForSchemas` now discovers foreign key constraints
+  via `pg_constraint`, including `ON DELETE` / `ON UPDATE` actions.
+
 # 0.5.5.0
 
 ## Added features