Add support for column attributes and constraints in create_table

db/migration.yaml

@@ -48,3 +48,24 @@ plan:
       - up: | # sql
           SELECT schema_name
           FROM information_schema.schemata;
+
+  - id: 01J7ZS10D1FWF2E4WVFMBDYWHH
+    description: Create Complex table
+    steps:
+      - create_table:
+          name: examples
+          columns:
+            - name: ulid
+              type: CHAR(26)
+              primary_key: true
+            - name: example_data
+              type: BYTEA
+              required: true
+            - name: example_hash
+              type: CHAR(64)
+              unique: true
+              remarks: SHA-256 hash of the object data
+          constraints:
+            - name: valid_ulid_constraint
+              check: ulid ~ '^[0-9A-HJKMNP-TV-Z]{26}'
+              remarks: Constraint to enforce valid ULID

integration/Test/Data/RdsData/Migration/ConnectionSpec.hs

@@ -37,7 +37,7 @@ import qualified TestContainers.Tasty                   as TC
 -- cabal test rds-data-test --test-options "--pattern \"/RDS integration test/\""
 tasty_rds_integration_test :: Tasty.TestTree
 tasty_rds_integration_test =
-  TC.withContainers (setupContainers' "localstack/localstack-pro:latest") $ \getContainer ->
+  TC.withContainers (setupContainers' "localstack/localstack-pro:3.7.2") $ \getContainer ->
     H.testProperty "RDS integration test" $ propertyOnce $ localWorkspace "rds-data" $ runLocalTestEnv getContainer $ do
       rdsClusterDetails <- createRdsDbCluster "rds_data_migration" getContainer
 
@@ -76,22 +76,7 @@ tasty_rds_integration_test =
 
         let upTables = upResult ^.. the @"records" . each . each . each . the @"stringValue" . _Just
 
-        L.sort upTables === ["migration", "projects", "users"]
-
-        -- upIndexResult <-
-        --   ( executeStatement $ mconcat
-        --       [ "SELECT schemaname, indexname, tablename"
-        --       , "  FROM pg_indexes"
-        --       , "  ORDER BY schemaname, tablename, indexname;"
-        --       ]
-        --   )
-        --   & trapFail @AWS.Error
-        --   & trapFail @RdsDataError
-        --   & jotShowDataLog
-
-        -- let upIndexes = upIndexResult ^.. the @"records" . each . each . each . the @"stringValue" . _Just
-
-        -- L.sort upIndexes === []
+        L.sort upTables === ["examples", "migration", "projects", "users"]
 
         migrateDown "db/migration.yaml"
           & trapFail @AWS.Error

polysemy/Data/RdsData/Polysemy/Migration.hs

@@ -22,6 +22,7 @@ import           Data.RdsData.Aws
 import           Data.RdsData.Migration.Types   hiding (id)
 import           Data.RdsData.Polysemy.Core
 import           Data.RdsData.Polysemy.Error
+import qualified Data.Text                      as T
 import qualified Data.Text.Encoding             as T
 import           HaskellWorks.Polysemy
 import           HaskellWorks.Polysemy.Amazonka
@@ -110,12 +111,14 @@ migrateUp migrationFp = do
       StepOfDown _ -> pure ()
       StepOfCreateTable createTableStatement -> do
         columnClauses <- pure $
-          createTableStatement ^.. the @"createTable" . the @"columns" . each . to \column ->
-            column ^. the @"name" <> " " <> column ^. the @"type_"
+          createTableStatement ^.. the @"createTable" . the @"columns" . each . to columnToText
+
+        constraintClauses <- pure $
+          createTableStatement ^.. the @"createTable" . the @"constraints" . _Just . each . to constraintToText
 
         statement <- pure $ mconcat
           [ "CREATE TABLE " <> createTableStatement ^. the @"createTable" . the @"name" <> " ("
-          , mconcat $ L.intersperse ", " columnClauses
+          , mconcat $ L.intersperse ", " (columnClauses <> constraintClauses)
           , ");\n"
           ]
 
@@ -140,3 +143,41 @@ migrateUp migrationFp = do
         response <- executeStatement statement
 
         info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records")))
+
+columnToText :: Column -> Text
+columnToText c =
+  T.intercalate " " $ concat
+    [ [c ^. the @"name"]
+    , [c ^. the @"type_"]
+    , [ "NOT NULL"
+      | c ^. the @"required"
+      ]
+    , [ "PRIMARY KEY"
+      | c ^. the @"primaryKey"
+      ]
+    , [ "UNIQUE"
+      | c ^. the @"unique"
+      ]
+    , [ "AUTO_INCREMENT"
+      | c ^. the @"autoIncrement"
+      ]
+    , [ [ "REFERENCES"
+        , fk ^. the @"table"
+        , "("
+        , fk ^. the @"column"
+        , ")"
+        ] & T.intercalate " "
+      | Just fk <- [c ^. the @"references"]
+      ]
+    ]
+
+constraintToText :: Constraint -> Text
+constraintToText c =
+  T.intercalate " "
+    [ "CONSTRAINT"
+    , c ^. the @"name"
+    , "CHECK"
+    , "("
+    , c ^. the @"check"
+    , ")"
+    ]

src/Data/RdsData/Migration/Types.hs

@@ -17,6 +17,7 @@ module Data.RdsData.Migration.Types
     CreateTableStep(..),
     TableSchema(..),
     Column(..),
+    Constraint(..),
     ForeignKey(..),
   ) where
 
@@ -26,8 +27,11 @@ import qualified Amazonka.RDS              as AWS
 import qualified Amazonka.SecretsManager   as AWS
 import           Control.Applicative
 import qualified Data.Aeson                as J
+import qualified Data.Aeson.Key            as J
+import qualified Data.Aeson.Types          as J
 import           Data.Bool
 import           Data.Char                 (isAsciiUpper, toLower)
+import           Data.Functor
 import           Data.Generics.Product.Any
 import           Data.Maybe
 import           Data.RdsData.Orphans      ()
@@ -97,18 +101,33 @@ instance ToJSON Step where
   toJSON = \case
     StepOfUp step -> J.toJSON step
     StepOfDown step -> J.toJSON step
-    StepOfCreateTable table -> J.toJSON table
-    StepOfCreateIndex index -> J.toJSON index
+    StepOfCreateTable t -> J.toJSON t
+    StepOfCreateIndex i -> J.toJSON i
 
 instance FromJSON Step where
-  parseJSON v =
-    flip (J.withObject "Step") v $ \_ ->
-      asum
-        [ StepOfUp          <$> J.parseJSON v
-        , StepOfDown        <$> J.parseJSON v
-        , StepOfCreateTable <$> J.parseJSON v
-        , StepOfCreateIndex <$> J.parseJSON v
-        ]
+  parseJSON v = do
+    f <- fieldIn v
+      [ "up"
+      , "down"
+      , "create_table"
+      , "create_index"
+      ]
+
+    case f of
+      "up"           -> StepOfUp          <$> J.parseJSON v
+      "down"         -> StepOfDown        <$> J.parseJSON v
+      "create_table" -> StepOfCreateTable <$> J.parseJSON v
+      "create_index" -> StepOfCreateIndex <$> J.parseJSON v
+      _              -> fail "Invalid Step"
+
+fieldIn :: J.Value -> [Text] -> J.Parser Text
+fieldIn v fs =
+  asum $ fmap (field v) fs
+
+field :: J.Value -> Text -> J.Parser Text
+field v f =
+  flip (J.withObject "Step") v $ \o ->
+    (J..:) @J.Value o (J.fromText f) $> f
 
 newtype UpStep = UpStep
   { up   :: Statement
@@ -155,8 +174,9 @@ instance FromJSON CreateIndexStep where
   parseJSON = J.genericParseJSON snakeCaseOptions
 
 data TableSchema = TableSchema
-  { name    :: Text
-  , columns :: [Column]
+  { name        :: Text
+  , columns     :: [Column]
+  , constraints :: Maybe [Constraint]
   } deriving (Eq, Generic, Show)
 
 instance ToJSON TableSchema where
@@ -168,23 +188,23 @@ instance FromJSON TableSchema where
 data Column = Column
   { name          :: Text
   , type_         :: Text
-  , nullable      :: Bool
+  , required      :: Bool
   , primaryKey    :: Bool
   , unique        :: Bool
   , autoIncrement :: Bool
   , references    :: Maybe ForeignKey
   } deriving (Eq, Generic, Show)
 
 instance ToJSON Column where
-  toJSON column =
+  toJSON v =
     J.object $ catMaybes
-      [ "name"            .=? do column ^. the @"name"          & Just
-      , "type"            .=? do column ^. the @"type_"         & Just
-      , "nullable"        .=? do column ^. the @"nullable"      & bool Nothing (Just True)
-      , "primary_key"     .=? do column ^. the @"primaryKey"    & bool Nothing (Just True)
-      , "unique"          .=? do column ^. the @"unique"        & bool Nothing (Just True)
-      , "auto_increment"  .=? do column ^. the @"autoIncrement" & bool Nothing (Just True)
-      , "references"      .=? do column ^. the @"references"    & Just
+      [ "name"            .=? do v ^. the @"name"           & Just
+      , "type"            .=? do v ^. the @"type_"          & Just
+      , "required"        .=? do v ^. the @"required"       & bool Nothing (Just True)
+      , "primary_key"     .=? do v ^. the @"primaryKey"     & bool Nothing (Just True)
+      , "unique"          .=? do v ^. the @"unique"         & bool Nothing (Just True)
+      , "auto_increment"  .=? do v ^. the @"autoIncrement"  & bool Nothing (Just True)
+      , "references"      .=? do v ^. the @"references"     & Just
       ]
 
 (.=?) :: (J.KeyValue e kv, ToJSON v) => J.Key -> Maybe v -> Maybe kv
@@ -198,7 +218,7 @@ instance FromJSON Column where
     Column
       <$> v .:  "name"
       <*> v .:  "type"
-      <*> v .:? "nullable"        .!= False
+      <*> v .:? "required"        .!= False
       <*> v .:? "primary_key"     .!= False
       <*> v .:? "unique"          .!= False
       <*> v .:? "auto_increment"  .!= False
@@ -216,7 +236,24 @@ instance ToJSON IndexSchema where
 instance FromJSON IndexSchema where
   parseJSON = J.genericParseJSON snakeCaseOptions
 
+data ForeignKey = ForeignKey
+  { table  :: Text
+  , column :: Text
+  } deriving (Eq, Generic, Show)
+
+instance ToJSON ForeignKey where
+  toJSON = J.genericToJSON snakeCaseOptions
 
-newtype ForeignKey = ForeignKey Text
-  deriving newtype (Eq, Show, ToJSON, FromJSON)
-  deriving Generic
+instance FromJSON ForeignKey where
+  parseJSON = J.genericParseJSON snakeCaseOptions
+
+data Constraint = Constraint
+  { name  :: Text
+  , check :: Text
+  } deriving (Eq, Generic, Show)
+
+instance ToJSON Constraint where
+  toJSON = J.genericToJSON snakeCaseOptions
+
+instance FromJSON Constraint where
+  parseJSON = J.genericParseJSON snakeCaseOptions