Merge pull request #329 from ruhatch/#291-composite-pks

[#291] Allow composite primary keys

IHP/IDE/CodeGen/ControllerGenerator.hs

@@ -24,7 +24,7 @@ buildPlan rawControllerName applicationName = do
         Right statements -> pure statements
     let controllerName = tableNameToControllerName rawControllerName
     let modelName = tableNameToModelName rawControllerName
-    pure $ Right $ buildPlan' schema applicationName controllerName modelName 
+    pure $ Right $ buildPlan' schema applicationName controllerName modelName
 
 buildPlan' schema applicationName controllerName modelName =
     let
@@ -40,7 +40,7 @@ buildPlan' schema applicationName controllerName modelName =
         <> viewPlans
 
 data ControllerConfig = ControllerConfig
-    { controllerName :: Text 
+    { controllerName :: Text
     , applicationName :: Text
     , modelName :: Text
     } deriving (Eq, Show)
@@ -52,7 +52,6 @@ controllerInstance ControllerConfig { controllerName, modelName, applicationName
 
 data HaskellModule = HaskellModule { moduleName :: Text, body :: Text }
 
-
 generateControllerData :: ControllerConfig -> Text
 generateControllerData config =
     let
@@ -61,7 +60,7 @@ generateControllerData config =
         singularName = get #modelName config
         idFieldName = lcfirst singularName <> "Id"
         idType = "Id " <> singularName
-    in 
+    in
         "\n"
         <> "data " <> name <> "Controller\n"
         <> "    = " <> pluralName <> "Action\n"
@@ -127,7 +126,7 @@ generateController schema config =
             ""
             <> "    action Update" <> singularName <> "Action { " <> idFieldName <> " } = do\n"
             <> "        " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n"
-            <> "        " <> modelVariableSingular <> "\n" 
+            <> "        " <> modelVariableSingular <> "\n"
             <> "            |> build" <> singularName <> "\n"
             <> "            |> ifValid \\case\n"
             <> "                Left " <> modelVariableSingular <> " -> render EditView { .. }\n"
@@ -140,7 +139,7 @@ generateController schema config =
             ""
             <> "    action Create" <> singularName <> "Action = do\n"
             <> "        let " <> modelVariableSingular <> " = newRecord @"  <> model <> "\n"
-            <> "        " <> modelVariableSingular <> "\n" 
+            <> "        " <> modelVariableSingular <> "\n"
             <> "            |> build" <> singularName <> "\n"
             <> "            |> ifValid \\case\n"
             <> "                Left " <> modelVariableSingular <> " -> render NewView { .. } \n"
@@ -195,7 +194,7 @@ pathToModuleName :: Text -> Text
 pathToModuleName moduleName = Text.replace "." "/" moduleName
 
 generateViews :: [Statement] -> Text -> Text -> [GeneratorAction]
-generateViews schema applicationName controllerName' = 
+generateViews schema applicationName controllerName' =
     if null controllerName'
         then []
         else do
@@ -213,4 +212,3 @@ generateViews schema applicationName controllerName' =
 
 isAlphaOnly :: Text -> Bool
 isAlphaOnly text = Text.all (\c -> Char.isAlpha c || c == '_') text
-

IHP/IDE/CodeGen/Types.hs

@@ -20,26 +20,26 @@ data GeneratorAction
 fieldsForTable :: [Statement] -> Text -> [Text]
 fieldsForTable database name =
     case getTable database name of
-        Just (CreateTable { columns }) -> columns
-                |> filter columnRelevantForCreateOrEdit
+        Just (StatementCreateTable CreateTable { columns, primaryKeyConstraint }) -> columns
+                |> filter (columnRelevantForCreateOrEdit primaryKeyConstraint)
                 |> map (get #name)
                 |> map columnNameToFieldName
         _ -> []
 
 -- | Returns True when a column should be part of the generated controller or forms
 --
 -- Returrns @False@ for primary keys, or fields such as @created_at@
-columnRelevantForCreateOrEdit :: Column -> Bool
-columnRelevantForCreateOrEdit column
+columnRelevantForCreateOrEdit :: PrimaryKeyConstraint -> Column -> Bool
+columnRelevantForCreateOrEdit _ column
     | (get #columnType column == PTimestamp || get #columnType column == PTimestampWithTimezone)
     && (isJust (get #defaultValue column))
     = False
-columnRelevantForCreateOrEdit column = not (get #primaryKey column)
+columnRelevantForCreateOrEdit (PrimaryKeyConstraint primaryKeyColumns) column =
+    get #name column `notElem` primaryKeyColumns
 
 getTable :: [Statement] -> Text -> Maybe Statement
 getTable schema name = find isTable schema
     where
         isTable :: Statement -> Bool
-        isTable table@(CreateTable { name = name' }) | name == name' = True
+        isTable table@(StatementCreateTable CreateTable { name = name' }) | name == name' = True
         isTable _ = False
-

IHP/IDE/CodeGen/ViewGenerator.hs

@@ -12,7 +12,7 @@ import IHP.IDE.SchemaDesigner.Types
 import qualified Text.Countable as Countable
 
 data ViewConfig = ViewConfig
-    { controllerName :: Text 
+    { controllerName :: Text
     , applicationName :: Text
     , modelName :: Text
     , viewName :: Text
@@ -22,7 +22,7 @@ buildPlan :: Text -> Text -> Text -> IO (Either Text [GeneratorAction])
 buildPlan viewName applicationName controllerName' =
     if (null viewName || null controllerName')
         then pure $ Left "View name and controller name cannot be empty"
-        else do 
+        else do
             schema <- SchemaDesigner.parseSchemaSql >>= \case
                 Left parserError -> pure []
                 Right statements -> pure statements
@@ -37,8 +37,8 @@ qualifiedViewModuleName config viewName =
     get #applicationName config <> ".View." <> get #controllerName config <> "." <> viewName
 
 buildPlan' :: [Statement] -> ViewConfig -> [GeneratorAction]
-buildPlan' schema config = 
-        let 
+buildPlan' schema config =
+        let
             controllerName = get #controllerName config
             name = get #viewName config
             singularName = config |> get #modelName
@@ -48,7 +48,7 @@ buildPlan' schema config =
                 then name
                 else name <> "View" --e.g. "Test" -> "TestView"
             nameWithoutSuffix = if "View" `isSuffixOf` name
-                then Text.replace "View" "" name 
+                then Text.replace "View" "" name
                 else name --e.g. "TestView" -> "Test"
 
             indexAction = Countable.pluralize singularName <> "Action"
@@ -68,8 +68,8 @@ buildPlan' schema config =
                 <> "module " <> qualifiedViewModuleName config nameWithoutSuffix <> " where\n"
                 <> "import " <> get #applicationName config <> ".View.Prelude\n"
                 <> "\n"
-            
-            genericView = 
+
+            genericView =
                 viewHeader
                 <> "data " <> nameWithSuffix <> " = " <> nameWithSuffix <> "\n"
                 <> "\n"
@@ -84,7 +84,7 @@ buildPlan' schema config =
                 <> "        <h1>" <> nameWithSuffix <> "</h1>\n"
                 <> "    |]\n"
 
-            showView = 
+            showView =
                 viewHeader
                 <> "data ShowView = ShowView { " <> singularVariableName <> " :: " <> singularName <> " }\n"
                 <> "\n"
@@ -99,7 +99,7 @@ buildPlan' schema config =
                 <> "        <h1>Show " <> singularName <> "</h1>\n"
                 <> "    |]\n"
 
-            newView = 
+            newView =
                 viewHeader
                 <> "data NewView = NewView { " <> singularVariableName <> " :: " <> singularName <> " }\n"
                 <> "\n"
@@ -121,7 +121,7 @@ buildPlan' schema config =
                 <> "    {submitButton}\n"
                 <> "|]\n"
 
-            editView = 
+            editView =
                 viewHeader
                 <> "data EditView = EditView { " <> singularVariableName <> " :: " <> singularName <> " }\n"
                 <> "\n"
@@ -143,7 +143,7 @@ buildPlan' schema config =
                 <> "    {submitButton}\n"
                 <> "|]\n"
 
-            indexView = 
+            indexView =
                 viewHeader
                 <> "data IndexView = IndexView { " <> pluralVariableName <> " :: [" <> singularName <> "] }\n"
                 <> "\n"

IHP/IDE/Data/Controller.hs

@@ -13,9 +13,10 @@ import IHP.IDE.Data.View.EditValue
 import qualified Database.PostgreSQL.Simple as PG
 import qualified Database.PostgreSQL.Simple.FromField as PG
 import qualified Database.PostgreSQL.Simple.FromRow as PG
+import qualified Database.PostgreSQL.Simple.ToField as PG
 import qualified Database.PostgreSQL.Simple.Types as PG
 import qualified IHP.FrameworkConfig as Config
-import qualified Data.UUID as UUID
+import qualified Data.Text as T
 
 instance Controller DataController where
     action ShowDatabaseAction = do
@@ -27,8 +28,9 @@ instance Controller DataController where
     action ShowTableRowsAction { tableName } = do
         connection <- connectToAppDb
         tableNames <- fetchTableNames connection
+        primaryKeyFields <- tablePrimaryKeyFields connection tableName
 
-        rows :: [[DynamicField]] <- PG.query connection "SELECT * FROM ? ORDER BY id" (PG.Only (PG.Identifier tableName))
+        rows :: [[DynamicField]] <- fetchRows connection tableName
 
         tableCols <- fetchTableCols connection tableName
 
@@ -45,20 +47,21 @@ instance Controller DataController where
         PG.close connection
         render ShowQueryView { .. }
 
-    action DeleteEntryAction { fieldValue, tableName } = do
+    action DeleteEntryAction { primaryKey, tableName } = do
         connection <- connectToAppDb
         tableNames <- fetchTableNames connection
-        let (Just id) = UUID.fromText fieldValue
-        let query = "DELETE FROM " <> tableName <> " WHERE id = ?"
-        PG.execute connection (PG.Query . cs $! query) (PG.Only id)
+        primaryKeyFields <- tablePrimaryKeyFields connection tableName
+        let primaryKeyValues = T.splitOn "---" primaryKey
+        let query = "DELETE FROM " <> tableName <> " WHERE " <> intercalate " AND " ((<> " = ?") <$> primaryKeyFields)
+        PG.execute connection (PG.Query . cs $! query) primaryKeyValues
         PG.close connection
         redirectTo ShowTableRowsAction { .. }
 
     action NewRowAction { tableName } = do
         connection <- connectToAppDb
         tableNames <- fetchTableNames connection
 
-        rows :: [[DynamicField]] <- PG.query connection "SELECT * FROM ? ORDER BY id" (PG.Only (PG.Identifier tableName))
+        rows :: [[DynamicField]] <- fetchRows connection tableName
 
         tableCols <- fetchTableCols connection tableName
 
@@ -71,58 +74,65 @@ instance Controller DataController where
         let tableName = param "tableName"
         tableCols <- fetchTableCols connection tableName
         let values :: [Text] = map (\col -> param @Text (cs (get #columnName col))) tableCols
-        let query = "INSERT INTO " <> tableName <> " VALUES (" <> intercalate "," values <> ")"
-        PG.execute_ connection (PG.Query . cs $! query)
+        let query = "INSERT INTO " <> tableName <> " VALUES (" <> intercalate "," (const "?" <$> values) <> ")"
+        PG.execute connection (PG.Query . cs $! query) values
         PG.close connection
         redirectTo ShowTableRowsAction { .. }
 
-    action EditRowAction { tableName, id } = do
+    action EditRowAction { tableName, targetPrimaryKey } = do
         connection <- connectToAppDb
         tableNames <- fetchTableNames connection
+        primaryKeyFields <- tablePrimaryKeyFields connection tableName
 
-        rows :: [[DynamicField]] <- PG.query connection "SELECT * FROM ? ORDER BY id" (PG.Only (PG.Identifier tableName))
+        rows :: [[DynamicField]] <- fetchRows connection tableName
 
         tableCols <- fetchTableCols connection tableName
-        values <- fetchTable connection (cs tableName) ("'" <> cs id <> "'")
+        let targetPrimaryKeyValues = T.splitOn "---" targetPrimaryKey
+        values <- fetchRow connection (cs tableName) targetPrimaryKeyValues
         let (Just rowValues) = head values
         PG.close connection
         render EditRowView { .. }
-        
+
     action UpdateRowAction = do
-        let id :: String = cs (param @Text "id")
         let tableName = param "tableName"
         connection <- connectToAppDb
         tableNames <- fetchTableNames connection
         tableCols <- fetchTableCols connection tableName
-        let values :: [Text] = map (\col -> param @Text (cs (get #columnName col))) tableCols
+        primaryKeyFields <- tablePrimaryKeyFields connection tableName
+
+        let values = map (PG.Escape . cs . param @Text . cs . get #columnName) tableCols
         let columns :: [Text] = map (\col -> cs (get #columnName col)) tableCols
-        let query = "UPDATE " <> tableName <> " SET " <> intercalate ", " (updateValues (zip columns values)) <> " WHERE id = " <> cs id
-        PG.execute_ connection (PG.Query . cs $! query)
+        let primaryKeyValues = map (PG.Escape . cs . param @Text . (<> "-pk") . cs) primaryKeyFields
+
+        let query = PG.Query . cs $! "UPDATE " <> tableName <> " SET " <> intercalate ", " (map (<> " = ?") columns) <> " WHERE " <> intercalate " AND " ((<> " = ?") <$> primaryKeyFields)
+        PG.execute connection query (values <> primaryKeyValues)
         PG.close connection
         redirectTo ShowTableRowsAction { .. }
 
-    action EditRowValueAction { tableName, targetName, id } = do
+    action EditRowValueAction { tableName, targetName, targetPrimaryKey } = do
         connection <- connectToAppDb
         tableNames <- fetchTableNames connection
-
-        rows :: [[DynamicField]] <- PG.query connection "SELECT * FROM ? ORDER BY id" (PG.Only (PG.Identifier tableName))
+        primaryKeyFields <- tablePrimaryKeyFields connection tableName
+
+        rows :: [[DynamicField]] <- fetchRows connection tableName
 
-        let targetId = cs id
         PG.close connection
         render EditValueView { .. }
 
-    action ToggleBooleanFieldAction { tableName, targetName, id } = do
+    action ToggleBooleanFieldAction { tableName, targetName, targetPrimaryKey } = do
         let id :: String = cs (param @Text "id")
         let tableName = param "tableName"
         connection <- connectToAppDb
         tableNames <- fetchTableNames connection
         tableCols <- fetchTableCols connection tableName
-        let query = PG.Query ("UPDATE ? SET ? = NOT ? WHERE id = ?")
-        let params = (PG.Identifier tableName, PG.Identifier targetName, PG.Identifier targetName, id)
+        primaryKeyFields <- tablePrimaryKeyFields connection tableName
+        let targetPrimaryKeyValues = PG.Escape . cs <$> T.splitOn "---" targetPrimaryKey
+        let query = PG.Query . cs $! "UPDATE ? SET ? = NOT ? WHERE " <> intercalate " AND " ((<> " = ?") <$> primaryKeyFields)
+        let params = [PG.toField $ PG.Identifier tableName, PG.toField $ PG.Identifier targetName, PG.toField $ PG.Identifier targetName] <> targetPrimaryKeyValues
         PG.execute connection query params
         PG.close connection
         redirectTo ShowTableRowsAction { .. }
-        
+
 
 connectToAppDb = do
     databaseUrl <- Config.appDatabaseUrl
@@ -137,16 +147,29 @@ fetchTableCols :: PG.Connection -> Text -> IO [ColumnDefinition]
 fetchTableCols connection tableName = do
     PG.query connection "SELECT column_name,data_type,column_default FROM information_schema.columns where table_name = ?" (PG.Only tableName)
 
-fetchTable :: PG.Connection -> String -> String -> IO [[DynamicField]]
-fetchTable connection tableName rowId = do
-    PG.query_ connection (fromString ("SELECT * FROM " <> tableName <> " where id = " <> rowId))
-
-updateValues list = map (\elem -> fst elem <> " = " <> snd elem) list
+fetchRow :: PG.Connection -> Text -> [Text] -> IO [[DynamicField]]
+fetchRow connection tableName primaryKeyValues = do
+    pkFields <- tablePrimaryKeyFields connection tableName
+    let query = "SELECT * FROM " <> tableName <> " WHERE " <> intercalate " AND " ((<> " = ?") <$> pkFields)
+    PG.query connection (PG.Query . cs $! query) primaryKeyValues
 
 instance PG.FromField DynamicField where
     fromField field fieldValue = pure DynamicField { .. }
         where
             fieldName = fromMaybe "" (PG.name field)
 
 instance PG.FromRow ColumnDefinition where
-    fromRow = ColumnDefinition <$> PG.field <*> PG.field <*> PG.field
+    fromRow = ColumnDefinition <$> PG.field <*> PG.field <*> PG.field
+
+tablePrimaryKeyFields :: PG.Connection -> Text -> IO [Text]
+tablePrimaryKeyFields connection tableName = do
+    fields <- PG.query connection "SELECT a.attname FROM pg_index i JOIN pg_attribute a ON a.attrelid = i.indrelid AND a.attnum = ANY(i.indkey) WHERE i.indrelid = ?::regclass AND i.indisprimary" (PG.Only tableName) :: IO [PG.Only Text]
+    pure $ PG.fromOnly <$> fields
+
+fetchRows :: FromRow r => PG.Connection -> Text -> IO [r]
+fetchRows connection tableName = do
+    pkFields <- tablePrimaryKeyFields connection tableName
+
+    let query = "SELECT * FROM " <> tableName <> " ORDER BY " <> intercalate ", " pkFields
+
+    PG.query_ connection (PG.Query . cs $! query)