Merge pull request #13 from haskell-works/newhoggy/support-for-compos…

…ite-primary-keys Support for composite primary keys
haskell-works · Sep 17, 2024 · 16b99f4 · 16b99f4
2 parents b163e1d + d3acd88
commit 16b99f4
Show file tree

Hide file tree

Showing 3 changed files with 17 additions and 2 deletions.
diff --git a/db/migration.yaml b/db/migration.yaml
@@ -57,14 +57,16 @@ plan:
           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
+          primary_key:
+            - ulid
+            - example_hash
           constraints:
             - name: valid_ulid_constraint
               check: ulid ~ '^[0-9A-HJKMNP-TV-Z]{26}'

diff --git a/polysemy/Data/RdsData/Polysemy/Migration.hs b/polysemy/Data/RdsData/Polysemy/Migration.hs
@@ -113,12 +113,15 @@ migrateUp migrationFp = do
         columnClauses <- pure $
           createTableStatement ^.. the @"createTable" . the @"columns" . each . to columnToText
 
+        primaryKeyClause <- pure $
+          createTableStatement ^.. the @"createTable" . the @"primaryKey" . _Just . to primaryKeyToText
+
         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 <> constraintClauses)
+          , mconcat $ L.intersperse ", " (columnClauses <> primaryKeyClause <> constraintClauses)
           , ");\n"
           ]
 
@@ -171,6 +174,15 @@ columnToText c =
       ]
     ]
 
+primaryKeyToText :: [Text] -> Text
+primaryKeyToText cs =
+  T.intercalate " "
+    [ "PRIMARY KEY"
+    , "("
+    , T.intercalate ", " cs
+    , ")"
+    ]
+
 constraintToText :: Constraint -> Text
 constraintToText c =
   T.intercalate " "

diff --git a/src/Data/RdsData/Migration/Types.hs b/src/Data/RdsData/Migration/Types.hs
@@ -176,6 +176,7 @@ instance FromJSON CreateIndexStep where
 data TableSchema = TableSchema
   { name        :: Text
   , columns     :: [Column]
+  , primaryKey  :: Maybe [Text]
   , constraints :: Maybe [Constraint]
   } deriving (Eq, Generic, Show)