Add initial support for identity columns

orville-postgresql/src/Orville/PostgreSQL.hs

@@ -247,6 +247,8 @@ module Orville.PostgreSQL
   , FieldDefinition.getFieldDefinition
   , FieldDefinition.getAlias
   , FieldDefinition.buildAliasedFieldDefinition
+  , FieldDefinition.markAsIdentity
+  , FieldDefinition.unmarkIdentity
   , Marshall.AliasName
   , Marshall.stringToAliasName
   , Marshall.aliasNameToString

orville-postgresql/src/Orville/PostgreSQL/AutoMigration.hs

@@ -56,6 +56,7 @@ import qualified Orville.PostgreSQL as Orville
 import qualified Orville.PostgreSQL.Expr as Expr
 import qualified Orville.PostgreSQL.Internal.IndexDefinition as IndexDefinition
 import qualified Orville.PostgreSQL.Internal.MigrationLock as MigrationLock
+import qualified Orville.PostgreSQL.Marshall as Marshall
 import qualified Orville.PostgreSQL.PgCatalog as PgCatalog
 import qualified Orville.PostgreSQL.Raw.RawSql as RawSql
 import qualified Orville.PostgreSQL.Schema as Schema
@@ -953,8 +954,28 @@ mkAddAlterColumnActions relationDesc fieldDef =
                           ( Just (Expr.alterColumnDropDefault columnName)
                           , Just (Expr.alterColumnSetDefault columnName newDefault)
                           )
+
+              alterIdentity =
+                case (Marshall.fieldIdentityGeneration fieldDef, PgCatalog.pgAttributeIdentity attr) of
+                  (Nothing, Nothing) -> mempty
+                  (Just Marshall.GeneratedAlways, Just Marshall.GeneratedAlways) -> mempty
+                  (Just Marshall.GeneratedByDefault, Just Marshall.GeneratedByDefault) -> mempty
+                  (Nothing, Just _) ->
+                    pure $ Expr.alterColumnDropIdentity columnName Nothing
+                  (Just Marshall.GeneratedAlways, Nothing) ->
+                    pure $ Expr.alterColumnAddIdentity columnName Expr.alwaysColumnIdentityGeneration
+                  (Just Marshall.GeneratedAlways, Just _existing) ->
+                    [Expr.alterColumnDropIdentity columnName Nothing, Expr.alterColumnAddIdentity columnName Expr.alwaysColumnIdentityGeneration]
+                  (Just Marshall.GeneratedByDefault, Nothing) ->
+                    pure $ Expr.alterColumnAddIdentity columnName Expr.byDefaultColumnIdentityGeneration
+                  (Just Marshall.GeneratedByDefault, Just _existing) ->
+                    [Expr.alterColumnDropIdentity columnName Nothing, Expr.alterColumnAddIdentity columnName Expr.byDefaultColumnIdentityGeneration]
             in
-              Maybe.maybeToList dropDefault <> alterType <> Maybe.maybeToList setDefault <> alterNullability
+              Maybe.maybeToList dropDefault
+                <> alterType
+                <> Maybe.maybeToList setDefault
+                <> alterNullability
+                <> alterIdentity
       _ ->
         -- Either the column doesn't exist in the table _OR_ it's a system
         -- column. If it's a system column, attempting to add it will result

orville-postgresql/src/Orville/PostgreSQL/Expr/ColumnDefinition.hs

@@ -15,11 +15,13 @@ module Orville.PostgreSQL.Expr.ColumnDefinition
   , nullConstraint
   , ColumnDefault
   , columnDefault
+  , identityColumnConstraint
+  , ColumnIdentityGeneration
+  , alwaysColumnIdentityGeneration
+  , byDefaultColumnIdentityGeneration
   )
 where
 
-import qualified Data.Maybe as Maybe
-
 import Orville.PostgreSQL.Expr.DataType (DataType)
 import Orville.PostgreSQL.Expr.Name (ColumnName)
 import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression)
@@ -51,20 +53,26 @@ columnDefinition ::
   ColumnName ->
   -- | The SQL type of the column.
   DataType ->
-  -- | The constraint on the column, if any.
-  Maybe ColumnConstraint ->
+  -- | The constraints on the column, if any.
+  [ColumnConstraint] ->
   -- | The default value for the column, if any.
   Maybe ColumnDefault ->
   ColumnDefinition
-columnDefinition columnName dataType maybeColumnConstraint maybeColumnDefault =
-  ColumnDefinition
-    . RawSql.intercalate RawSql.space
-    $ Maybe.catMaybes
-      [ Just $ RawSql.toRawSql columnName
-      , Just $ RawSql.toRawSql dataType
-      , fmap RawSql.toRawSql maybeColumnConstraint
-      , fmap RawSql.toRawSql maybeColumnDefault
-      ]
+columnDefinition columnName dataType columnConstraints maybeColumnDefault =
+  let
+    constraintRawSql =
+      RawSql.intercalate RawSql.space columnConstraints
+  in
+    ColumnDefinition $
+      RawSql.toRawSql columnName
+        <> RawSql.space
+        <> RawSql.toRawSql dataType
+        <> RawSql.space
+        <> constraintRawSql
+        <> case maybeColumnDefault of
+          Nothing -> mempty
+          Just colDefault ->
+            RawSql.space <> RawSql.toRawSql colDefault
 
 {- | Represent constraints, such as nullability, on a column. E.G.
 
@@ -99,6 +107,50 @@ nullConstraint :: ColumnConstraint
 nullConstraint =
   ColumnConstraint (RawSql.fromString "NULL")
 
+{- | Represent the generation definition of an identity column. E.G.
+
+> ALWAYS
+
+'ColumnIdentityGeneration' provides a 'RawSql.SqlExpression' instance. See
+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom
+SQL.
+
+@since 1.1.0.0
+-}
+newtype ColumnIdentityGeneration
+  = ColumnIdentityGeneration RawSql.RawSql
+  deriving
+    ( -- | @since 1.1.0.0
+      RawSql.SqlExpression
+    )
+
+{- | Express that a column is an identity column.
+
+@since 1.1.0.0
+-}
+identityColumnConstraint ::
+  ColumnIdentityGeneration ->
+  ColumnConstraint
+identityColumnConstraint identityGeneration =
+  ColumnConstraint $
+    RawSql.fromString "GENERATE "
+      <> RawSql.toRawSql identityGeneration
+      <> RawSql.fromString " AS IDENTITY"
+
+{- | The @ALWAYS@ generation for an identity column
+
+@since 1.1.0.0
+-}
+alwaysColumnIdentityGeneration :: ColumnIdentityGeneration
+alwaysColumnIdentityGeneration = ColumnIdentityGeneration $ RawSql.fromString "ALWAYS"
+
+{- | The @BY DEFAULT@ generation for an identity column
+
+@since 1.1.0.0
+-}
+byDefaultColumnIdentityGeneration :: ColumnIdentityGeneration
+byDefaultColumnIdentityGeneration = ColumnIdentityGeneration $ RawSql.fromString "BY DEFAULT"
+
 {- | Represents the default value of a column. E.G.
 
 > now()

orville-postgresql/src/Orville/PostgreSQL/Expr/TableDefinition.hs

@@ -23,6 +23,8 @@ module Orville.PostgreSQL.Expr.TableDefinition
   , alterColumnType
   , alterColumnSetDefault
   , alterColumnDropDefault
+  , alterColumnAddIdentity
+  , alterColumnDropIdentity
   , UsingClause
   , usingCast
   , alterColumnNullability
@@ -39,7 +41,7 @@ where
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (catMaybes, maybeToList)
 
-import Orville.PostgreSQL.Expr.ColumnDefinition (ColumnDefinition)
+import Orville.PostgreSQL.Expr.ColumnDefinition (ColumnDefinition, ColumnIdentityGeneration)
 import Orville.PostgreSQL.Expr.DataType (DataType)
 import Orville.PostgreSQL.Expr.IfExists (IfExists)
 import Orville.PostgreSQL.Expr.Name (ColumnName, ConstraintName, QualifiedOrUnqualified, TableName)
@@ -365,6 +367,38 @@ alterColumnSetDefault columnName defaultValue =
       , RawSql.toRawSql defaultValue
       ]
 
+{- | Constructs an 'AlterTableAction' that will use @ADD GENERATED .. AS IDENTITY@ to set the
+   specified column to be an identity column.
+
+  @since 1.1.0.0
+-}
+alterColumnAddIdentity ::
+  ColumnName ->
+  ColumnIdentityGeneration ->
+  AlterTableAction
+alterColumnAddIdentity columnName columnIdentityGeneration =
+  AlterTableAction $
+    RawSql.fromString "ALTER COLUMN "
+      <> RawSql.toRawSql columnName
+      <> RawSql.fromString " ADD GENERATED "
+      <> RawSql.toRawSql columnIdentityGeneration
+      <> RawSql.fromString " AS IDENTITY"
+
+{- | Constructs an 'AlterTableAction' that will drop the identity requirement of a column
+
+  @since 1.1.0.0
+-}
+alterColumnDropIdentity ::
+  ColumnName ->
+  Maybe IfExists ->
+  AlterTableAction
+alterColumnDropIdentity columnName maybeIfExists =
+  AlterTableAction $
+    RawSql.fromString "ALTER COLUMN "
+      <> RawSql.toRawSql columnName
+      <> RawSql.fromString " DROP IDENTITY"
+      <> maybe mempty (\i -> RawSql.space <> RawSql.toRawSql i) maybeIfExists
+
 {- | Type to represent a @DROP TABLE@ statement. E.G.
 
 > DROP TABLE FOO

orville-postgresql/src/Orville/PostgreSQL/Marshall/FieldDefinition.hs

@@ -104,6 +104,10 @@ module Orville.PostgreSQL.Marshall.FieldDefinition
   , getFieldDefinition
   , getAlias
   , buildAliasedFieldDefinition
+  , FieldIdentityGeneration (GeneratedAlways, GeneratedByDefault)
+  , markAsIdentity
+  , unmarkIdentity
+  , fieldIdentityGeneration
   )
 where
 
@@ -141,6 +145,7 @@ data FieldDefinition nullability a = FieldDefinition
   , i_fieldDefaultValue :: Maybe (DefaultValue.DefaultValue a)
   , i_fieldDescription :: Maybe String
   , i_fieldTableConstraints :: [FieldName -> ConstraintDefinition.ConstraintDefinition]
+  , i_fieldIdentity :: IdentityGADT nullability
   }
 
 {- | Constructs the 'Expr.ValueExpression' for a field for use in SQL expressions
@@ -414,22 +419,26 @@ fieldColumnDefinition fieldDef =
   Expr.columnDefinition
     (fieldNameToColumnName $ fieldName fieldDef)
     (SqlType.sqlTypeExpr $ fieldType fieldDef)
-    (Just $ fieldColumnConstraint fieldDef)
+    (fieldColumnConstraints fieldDef)
     (fmap (Expr.columnDefault . DefaultValue.defaultValueExpression) $ i_fieldDefaultValue fieldDef)
 
-{- | INTERNAL - Builds the appropriate ColumnConstraint for a field. Currently
-  this only handles nullability, but if we add support for more constraints
-  directly on columns it may end up handling those as well.
+{- | INTERNAL - Builds the appropriate [ColumnConstraint] for a field.
 
 @since 1.0.0.0
 -}
-fieldColumnConstraint :: FieldDefinition nullabily a -> Expr.ColumnConstraint
-fieldColumnConstraint fieldDef =
+fieldColumnConstraints :: FieldDefinition nullabily a -> [Expr.ColumnConstraint]
+fieldColumnConstraints fieldDef =
   case fieldNullability fieldDef of
-    NotNullField _ ->
-      Expr.notNullConstraint
+    NotNullField nnf ->
+      case i_fieldIdentity nnf of
+        IsIdentityGADT GeneratedAlways ->
+          [Expr.notNullConstraint, Expr.identityColumnConstraint Expr.alwaysColumnIdentityGeneration]
+        IsIdentityGADT GeneratedByDefault ->
+          [Expr.notNullConstraint, Expr.identityColumnConstraint Expr.byDefaultColumnIdentityGeneration]
+        AllowedIdentityButNotSetGADT ->
+          pure Expr.notNullConstraint
     NullableField _ ->
-      Expr.nullConstraint
+      pure Expr.nullConstraint
 
 {- | The type in considered internal because it requires GADTs to make use of
   it meaningfully. The 'FieldNullability' type is used as the public interface
@@ -671,12 +680,13 @@ fieldOfType sqlType name =
     , i_fieldDefaultValue = Nothing
     , i_fieldDescription = Nothing
     , i_fieldTableConstraints = mempty
+    , i_fieldIdentity = AllowedIdentityButNotSetGADT
     }
 
-{- | Makes a 'NotNull' field 'Nullable' by wrapping the Haskell type of the field
-  in 'Maybe'. The field will be marked as @NULL@ in the database schema and
-  the value 'Nothing' will be used to represent @NULL@ values when converting
-  to and from SQL.
+{- | Makes a 'NotNull' field 'Nullable' by wrapping the Haskell type of the field in 'Maybe'. The
+  field will be marked as @NULL@ in the database schema and the value 'Nothing' will be used to
+  represent @NULL@ values when converting to and from SQL. If the field was previously an indentity
+  column, that will be removed.
 
 @since 1.0.0.0
 -}
@@ -701,6 +711,7 @@ nullableField field =
       , i_fieldDefaultValue = fmap DefaultValue.coerceDefaultValue (i_fieldDefaultValue field)
       , i_fieldDescription = fieldDescription field
       , i_fieldTableConstraints = i_fieldTableConstraints field
+      , i_fieldIdentity = NotIdentityGADT
       }
 
 {- | Adds a 'Maybe' wrapper to a field that is already nullable. (If your field is
@@ -734,6 +745,7 @@ asymmetricNullableField field =
       , i_fieldDefaultValue = fmap DefaultValue.coerceDefaultValue (i_fieldDefaultValue field)
       , i_fieldDescription = fieldDescription field
       , i_fieldTableConstraints = i_fieldTableConstraints field
+      , i_fieldIdentity = i_fieldIdentity field
       }
 
 {- | Applies a 'SqlType.SqlType' conversion to a 'FieldDefinition'. You can
@@ -799,6 +811,26 @@ removeDefaultValue fieldDef =
     { i_fieldDefaultValue = Nothing
     }
 
+{- | Use the supplied options to mark a column as an identity column.
+
+@since 1.1.0.0
+-}
+markAsIdentity :: FieldIdentityGeneration -> FieldDefinition NotNull a -> FieldDefinition NotNull a
+markAsIdentity identityGen fieldDef =
+  fieldDef
+    { i_fieldIdentity = IsIdentityGADT identityGen
+    }
+
+{- | Remove the identity portion of a field. Note that if a field
+
+@since 1.1.0.0
+-}
+unmarkIdentity :: FieldDefinition NotNull a -> FieldDefinition NotNull a
+unmarkIdentity fieldDef =
+  fieldDef
+    { i_fieldIdentity = AllowedIdentityButNotSetGADT
+    }
+
 {- | Adds a prefix, followed by an underscore, to a field's name.
 
 @since 1.0.0.0
@@ -1102,3 +1134,42 @@ getFieldDefinition = i_fieldDef
 buildAliasedFieldDefinition :: FieldDefinition nullability a -> AliasName -> AliasedFieldDefinition nullability a
 buildAliasedFieldDefinition f ma =
   AliasedFieldDefinition ma f
+
+{- | INTERNAL: This type is an internal tracking of if a column is an identity column. We tie this to
+   the nullability because a nullable column is not allowed to be an identity column.
+
+@since 1.1.0.0
+-}
+data IdentityGADT nullability where
+  IsIdentityGADT :: FieldIdentityGeneration -> IdentityGADT NotNull
+  AllowedIdentityButNotSetGADT :: IdentityGADT NotNull
+  NotIdentityGADT :: IdentityGADT Nullable
+
+{- | Get the 'FieldIdentityGeneration', if there is one, of a 'FieldDefinition'.
+
+@since 1.1.0.0
+-}
+fieldIdentityGeneration :: FieldDefinition nullability a -> Maybe FieldIdentityGeneration
+fieldIdentityGeneration fieldDef =
+  case i_fieldIdentity fieldDef of
+    AllowedIdentityButNotSetGADT -> Nothing
+    NotIdentityGADT -> Nothing
+    IsIdentityGADT colId -> Just colId
+
+{- | Represents how the identity field be will generated.
+
+@since 1.1.0.0
+-}
+data FieldIdentityGeneration
+  = -- | The field will always be generated, and user supplied values during write for it is expressly not allowed.
+    --
+    -- @since 1.1.0.0
+    GeneratedAlways
+  | -- | The field will be generated by default, allowing for user defined values for writes will be allowed.
+    --
+    -- @since 1.1.0.0
+    GeneratedByDefault
+  deriving
+    ( -- | @since 1.1.0.0
+      Eq
+    )