Add support for foreign key constraints and foreign key actions

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/Haskell/Syntax.hs

@@ -25,6 +25,7 @@ import           Data.Char (toLower, toUpper)
 import           Data.Hashable
 import           Data.Int
 import           Data.List (find, nub)
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as M
 import           Data.Maybe
 import qualified Data.Set as S
@@ -591,7 +592,9 @@ instance IsSql92TableConstraintSyntax HsTableConstraint where
         tableTypeNm = tblNm <> "T"
         tableTypeKeyNm = tblNm <> "Key"
 
-        (fieldRecordNames, fieldTys) = unzip (fromMaybe (error "fieldTys") (mapM (hsFieldLookup tblFields) fields))
+        (fieldRecordNames, fieldTys) =
+          unzip (fromMaybe (error "fieldTys")
+          (mapM (hsFieldLookup tblFields) $ NE.toList fields))
 
         primaryKeyType = tyApp (tyConNamed "PrimaryKey") [ tyConNamed (T.unpack tableTypeNm), tyVarNamed "f" ]
         primaryKeyConDecl  = Hs.QualConDecl () Nothing Nothing (Hs.ConDecl () (Hs.Ident () (T.unpack tableTypeKeyNm)) fieldTys)

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/Builder.hs

@@ -14,6 +14,9 @@ import           Control.Applicative
 import           Data.ByteString.Builder (Builder, byteString, toLazyByteString)
 import qualified Data.ByteString.Lazy.Char8 as BCL
 
+import qualified Data.List.NonEmpty as NE
+
+
 
 -- | Options for @CREATE TABLE@. Given as a separate ADT because the options may
 -- go in different places syntactically.
@@ -124,7 +127,7 @@ instance IsSql92CreateTableSyntax SqlSyntaxBuilder where
 instance IsSql92TableConstraintSyntax SqlSyntaxBuilder where
   primaryKeyConstraintSyntax fs =
     SqlSyntaxBuilder $
-    byteString "PRIMARY KEY(" <> buildSepBy (byteString ", ") (map quoteSql fs) <> byteString ")"
+    byteString "PRIMARY KEY(" <> buildSepBy (byteString ", ") (map quoteSql $ NE.toList fs) <> byteString ")"
 
 -- | Some backends use this to represent their constraint attributes. Does not
 -- need to be used in practice.

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/Tables.hs

@@ -55,6 +55,7 @@ import Control.Monad.State
 
 import Data.Coerce (coerce)
 import Data.Kind (Type)
+import qualified Data.List.NonEmpty as NE
 import Data.Text (Text)
 import Data.Typeable
 import qualified Data.Kind as Kind (Constraint)
@@ -63,6 +64,7 @@ import GHC.TypeLits
 
 import Lens.Micro ((^.))
 
+
 -- * Table manipulation
 
 -- | Add a @CREATE TABLE@ statement to this migration
@@ -143,7 +145,10 @@ createTableWithSchema :: ( Beamable table, Table table
                       -> Migration be (CheckedDatabaseEntity be db (TableEntity table))
 createTableWithSchema maybeSchemaName newTblName tblSettings =
   do let pkFields = allBeamValues (\(Columnar' (TableFieldSchema name _ _)) -> name) (primaryKey tblSettings)
-         tblConstraints = if null pkFields then [] else [ primaryKeyConstraintSyntax pkFields ]
+         tblConstraints =
+          case NE.nonEmpty pkFields of
+            Nothing  -> []
+            Just pks -> [ primaryKeyConstraintSyntax pks ]
          createTableCommand =
            createTableSyntax Nothing (tableName (coerce <$> maybeSchemaName) newTblName)
                              (allBeamValues (\(Columnar' (TableFieldSchema name (FieldSchema schema) _)) -> (name, schema)) tblSettings)

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   ->