Merge pull request #1925 from MonaMayrhofer/support_non_id_pks

Add more support for non-id primary keys

IHP/Fetch.hs

@@ -188,16 +188,16 @@ genericFetchIdOne :: forall table model. (Table model, KnownSymbol table, PG.Fro
 genericFetchIdOne !id = query @model |> filterWhereId id |> fetchOne
 
 {-# INLINE genericFetchIds #-}
-genericFetchIds :: forall table model value. (Table model, KnownSymbol table, PG.FromRow model, ?modelContext :: ModelContext, ToField value, EqOrIsOperator value, HasField "id" model value, model ~ GetModelByTableName table, GetTableName model ~ table) => [value] -> IO [model]
-genericFetchIds !ids = query @model |> filterWhereIn (#id, ids) |> fetch
+genericFetchIds :: forall table model. (Table model, KnownSymbol table, PG.FromRow model, ?modelContext :: ModelContext, model ~ GetModelByTableName table, GetTableName model ~ table) => [Id model] -> IO [model]
+genericFetchIds !ids = query @model |> filterWhereIdIn ids |> fetch
 
 {-# INLINE genericfetchIdsOneOrNothing #-}
-genericfetchIdsOneOrNothing :: forall model value table. (Table model, KnownSymbol table, PG.FromRow model, ?modelContext :: ModelContext, ToField value, EqOrIsOperator value, HasField "id" model value, model ~ GetModelByTableName table, GetTableName model ~ table) => [value] -> IO (Maybe model)
-genericfetchIdsOneOrNothing !ids = query @model |> filterWhereIn (#id, ids) |> fetchOneOrNothing
+genericfetchIdsOneOrNothing :: forall table model. (Table model, KnownSymbol table, PG.FromRow model, ?modelContext :: ModelContext, model ~ GetModelByTableName table, GetTableName model ~ table) => [Id model] -> IO (Maybe model)
+genericfetchIdsOneOrNothing !ids = query @model |> filterWhereIdIn ids |> fetchOneOrNothing
 
 {-# INLINE genericFetchIdsOne #-}
-genericFetchIdsOne :: forall model value table. (Table model, KnownSymbol table, PG.FromRow model, ?modelContext :: ModelContext, ToField value, EqOrIsOperator value, HasField "id" model value, model ~ GetModelByTableName table, GetTableName model ~ table) => [value] -> IO model
-genericFetchIdsOne !ids = query @model |> filterWhereIn (#id, ids) |> fetchOne
+genericFetchIdsOne :: forall table model. (Table model, KnownSymbol table, PG.FromRow model, ?modelContext :: ModelContext, model ~ GetModelByTableName table, GetTableName model ~ table) => [Id model] -> IO model
+genericFetchIdsOne !ids = query @model |> filterWhereIdIn ids |> fetchOne
 
 {-# INLINE findBy #-}
 findBy !field !value !queryBuilder = queryBuilder |> filterWhere (field, value) |> fetchOne
@@ -231,7 +231,7 @@ instance (model ~ GetModelById (Id' table), GetTableName model ~ table, FilterPr
     fetchOne (Just a) = genericFetchIdOne a
     fetchOne Nothing = error "Fetchable (Maybe Id): Failed to fetch because given id is 'Nothing', 'Just id' was expected"
 
-instance (model ~ GetModelById (Id' table), value ~ Id' table, HasField "id" model value, ToField (PrimaryKey table), GetModelByTableName (GetTableName model) ~ model) => Fetchable [Id' table] model where
+instance (model ~ GetModelById (Id' table), GetModelByTableName table ~ model, GetTableName model ~ table) => Fetchable [Id' table] model where
     type FetchResult [Id' table] model = [model]
     {-# INLINE fetch #-}
     fetch = genericFetchIds

IHP/FetchRelated.hs

@@ -71,6 +71,7 @@ instance (
         , Show (PrimaryKey tableName)
         , HasField "id" relatedModel (Id' tableName)
         , relatedModel ~ GetModelByTableName (GetTableName relatedModel)
+        , GetTableName relatedModel ~ tableName
         , Table relatedModel
         ) => CollectionFetchRelated (Id' tableName) relatedModel where
     collectionFetchRelated :: forall model relatedField. (
@@ -84,7 +85,7 @@ instance (
             Table relatedModel
         ) => Proxy relatedField -> [model] -> IO [Include relatedField model]
     collectionFetchRelated relatedField model = do
-        relatedModels :: [relatedModel] <- query @relatedModel |> filterWhereIn (#id, map (getField @relatedField) model) |> fetch
+        relatedModels :: [relatedModel] <- query @relatedModel |> filterWhereIdIn (map (getField @relatedField) model) |> fetch
         let
             assignRelated :: model -> Include relatedField model
             assignRelated model =
@@ -121,6 +122,7 @@ instance (
         , ToField (PrimaryKey tableName)
         , HasField "id" relatedModel (Id' tableName)
         , relatedModel ~ GetModelByTableName (GetTableName relatedModel)
+        , GetTableName relatedModel ~ tableName
         , Table relatedModel
         ) => CollectionFetchRelatedOrNothing (Id' tableName) relatedModel where
     collectionFetchRelatedOrNothing :: forall model relatedField. (
@@ -133,7 +135,7 @@ instance (
             KnownSymbol relatedField
         ) => Proxy relatedField -> [model] -> IO [Include relatedField model]
     collectionFetchRelatedOrNothing relatedField model = do
-        relatedModels :: [relatedModel] <- query @relatedModel |> filterWhereIn (#id, mapMaybe (getField @relatedField) model) |> fetch
+        relatedModels :: [relatedModel] <- query @relatedModel |> filterWhereIdIn (mapMaybe (getField @relatedField) model) |> fetch
         let
             assignRelated :: model -> Include relatedField model
             assignRelated model =

IHP/IDE/SchemaDesigner/View/Columns/Edit.hs

@@ -1,6 +1,6 @@
 module IHP.IDE.SchemaDesigner.View.Columns.Edit where
 
-import IHP.ViewPrelude
+import IHP.ViewPrelude hiding (primaryKeyColumnNames)
 import IHP.IDE.SchemaDesigner.Types
 import qualified IHP.IDE.SchemaDesigner.Compiler as Compiler
 import IHP.IDE.ToolServer.Types

IHP/IDE/SchemaDesigner/View/Layout.hs

@@ -15,7 +15,7 @@ module IHP.IDE.SchemaDesigner.View.Layout
 , emptyColumnSelectorContainer
 ) where
 
-import IHP.ViewPrelude
+import IHP.ViewPrelude hiding (primaryKeyColumnNames)
 import IHP.IDE.SchemaDesigner.Types
 import IHP.IDE.ToolServer.Types
 import IHP.IDE.ToolServer.Helper.View

IHP/ModelSupport.hs

@@ -566,21 +566,62 @@ class
     --
     columnNames :: [ByteString]
 
-    -- | Returns WHERE conditions to match an entity by it's primary key
+    -- | Returns the list of column names, that are contained in the primary key for a given model
     --
-    -- For tables with a simple primary key this returns a tuple with the id:
+    -- __Example:__
     --
-    -- >>> primaryKeyCondition project
-    -- [("id", "d619f3cf-f355-4614-8a4c-e9ea4f301e39")]
+    -- >>> primaryKeyColumnNames @User
+    -- ["id"]
     --
-    -- If the table has a composite primary key, this returns multiple elements:
+    -- >>> primaryKeyColumnNames @PostTagging
+    -- ["post_id", "tag_id"]
+    --
+    primaryKeyColumnNames :: [ByteString]
+
+    -- | Returns the parameters for a WHERE conditions to match an entity by it's primary key, given the entities id
     --
-    -- >>> primaryKeyCondition postTag
-    -- [("post_id", "0ace9270-568f-4188-b237-3789aa520588"), ("tag_id", "0b58fdf5-4bbb-4e57-a5b7-aa1c57148e1c")]
+    -- For tables with a simple primary key this simply the id:
     --
-    primaryKeyCondition :: record -> [(Text, PG.Action)]
-    default primaryKeyCondition :: forall id. (HasField "id" record id, ToField id) => record -> [(Text, PG.Action)]
-    primaryKeyCondition record = [("id", toField record.id)]
+    -- >>> primaryKeyConditionForId project.id
+    -- Plain "d619f3cf-f355-4614-8a4c-e9ea4f301e39"
+    --
+    -- If the table has a composite primary key, this returns multiple elements:
+    --
+    -- >>> primaryKeyConditionForId postTag.id
+    -- Many [Plain "(", Plain "0ace9270-568f-4188-b237-3789aa520588", Plain ",", Plain "0b58fdf5-4bbb-4e57-a5b7-aa1c57148e1c", Plain ")"]
+    -- 
+    -- The order of the elements for a composite primary key must match the order of the columns returned by 'primaryKeyColumnNames'
+    primaryKeyConditionForId :: Id record -> PG.Action
+
+-- | Returns ByteString, that represents the part of an SQL where clause, that matches on a tuple consisting of all the primary keys
+-- For table with simple primary keys this simply returns the name of the primary key column, without wrapping in a tuple
+-- >>> primaryKeyColumnSelector @PostTag
+-- "(post_tags.post_id, post_tags.tag_id)"
+-- >>> primaryKeyColumnSelector @Post
+-- "post_tags.post_id"
+primaryKeyConditionColumnSelector :: forall record. (Table record) => ByteString
+primaryKeyConditionColumnSelector = 
+    let 
+        qualifyColumnName col = tableNameByteString @record <> "." <> col
+    in
+    case primaryKeyColumnNames @record of
+            [] -> error . cs $ "Impossible happened in primaryKeyConditionColumnSelector. No primary keys found for table " <> tableName @record <> ". At least one primary key is required."
+            [s] -> qualifyColumnName s
+            conds -> "(" <> intercalate ", " (map qualifyColumnName conds) <> ")"
+
+-- | Returns WHERE conditions to match an entity by it's primary key
+--
+-- For tables with a simple primary key this returns a tuple with the id:
+--
+-- >>> primaryKeyCondition project
+-- Plain "d619f3cf-f355-4614-8a4c-e9ea4f301e39"
+--
+-- If the table has a composite primary key, this returns multiple elements:
+--
+-- >>> primaryKeyCondition postTag
+-- Many [Plain "(", Plain "0ace9270-568f-4188-b237-3789aa520588", Plain ",", Plain "0b58fdf5-4bbb-4e57-a5b7-aa1c57148e1c", Plain ")"]
+primaryKeyCondition :: forall record. (HasField "id" record (Id record), Table record) => record -> PG.Action
+primaryKeyCondition record = primaryKeyConditionForId @record record.id
 
 logQuery :: (?modelContext :: ModelContext, PG.ToRow parameters) => Query -> parameters -> NominalDiffTime -> IO ()
 logQuery query parameters time = do
@@ -610,7 +651,8 @@ logQuery query parameters time = do
 -- DELETE FROM projects WHERE id = '..'
 --
 -- Use 'deleteRecords' if you want to delete multiple records.
-deleteRecord :: forall record table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, HasField "id" record (Id' table), ToField (PrimaryKey table), GetModelByTableName table ~ record, Show (PrimaryKey table), ToField (PrimaryKey table)) => record -> IO ()
+--
+deleteRecord :: forall record table. (?modelContext :: ModelContext, Table record, Show (PrimaryKey table), HasField "id" record (Id record), GetTableName record ~ table, record ~ GetModelByTableName table) => record -> IO ()
 deleteRecord record =
     deleteRecordById @record record.id
 {-# INLINABLE deleteRecord #-}
@@ -621,11 +663,11 @@ deleteRecord record =
 -- >>> delete projectId
 -- DELETE FROM projects WHERE id = '..'
 --
-deleteRecordById :: forall record table. (?modelContext :: ModelContext, Table record, ToField (PrimaryKey table), Show (PrimaryKey table), record ~ GetModelByTableName table) => Id' table -> IO ()
+deleteRecordById :: forall record table. (?modelContext :: ModelContext, Table record, Show (PrimaryKey table), GetTableName record ~ table, record ~ GetModelByTableName table) => Id' table -> IO ()
 deleteRecordById id = do
-    let theQuery = "DELETE FROM " <> tableName @record <> " WHERE id = ?"
-    let theParameters = PG.Only id
-    sqlExec (PG.Query . cs $! theQuery) theParameters
+    let theQuery = "DELETE FROM " <> tableNameByteString @record <> " WHERE " <> (primaryKeyConditionColumnSelector @record) <> " = ?"
+    let theParameters = PG.Only $ primaryKeyConditionForId @record id
+    sqlExec (PG.Query $! theQuery) theParameters
     pure ()
 {-# INLINABLE deleteRecordById #-}
 
@@ -634,7 +676,7 @@ deleteRecordById id = do
 -- >>> let projects :: [Project] = ...
 -- >>> deleteRecords projects
 -- DELETE FROM projects WHERE id IN (..)
-deleteRecords :: forall record table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, HasField "id" record (Id' table), ToField (PrimaryKey table), record ~ GetModelByTableName table) => [record] -> IO ()
+deleteRecords :: forall record table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, HasField "id" record (Id' table), GetTableName record ~ table, record ~ GetModelByTableName table) => [record] -> IO ()
 deleteRecords records =
     deleteRecordByIds @record (ids records)
 {-# INLINABLE deleteRecords #-}
@@ -645,11 +687,11 @@ deleteRecords records =
 -- >>> delete projectIds
 -- DELETE FROM projects WHERE id IN ('..')
 --
-deleteRecordByIds :: forall record table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, ToField (PrimaryKey table), record ~ GetModelByTableName table) => [Id' table] -> IO ()
+deleteRecordByIds :: forall record table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, GetTableName record ~ table, record ~ GetModelByTableName table) => [Id' table] -> IO ()
 deleteRecordByIds ids = do
-    let theQuery = "DELETE FROM " <> tableName @record <> " WHERE id IN ?"
-    let theParameters = (PG.Only (PG.In ids))
-    sqlExec (PG.Query . cs $! theQuery) theParameters
+    let theQuery = "DELETE FROM " <> tableNameByteString @record <> " WHERE " <> (primaryKeyConditionColumnSelector @record) <> " IN ?"
+    let theParameters = PG.Only $ PG.In $ map (primaryKeyConditionForId @record) ids
+    sqlExec (PG.Query $! theQuery) theParameters
     pure ()
 {-# INLINABLE deleteRecordByIds #-}
 

IHP/QueryBuilder.hs

@@ -24,6 +24,7 @@ module IHP.QueryBuilder
 , filterWhereCaseInsensitive
 , filterWhereNot
 , filterWhereIn
+, filterWhereIdIn
 , filterWhereNotIn
 , filterWhereLike
 , filterWhereILike
@@ -61,6 +62,9 @@ module IHP.QueryBuilder
 , Condition (..)
 , Join (..)
 , OrderByDirection (..)
+, injectQueryBuilder
+, FilterOperator (..)
+, toEqOrIsOperator
 )
 where
 import IHP.Prelude
@@ -826,6 +830,21 @@ filterWhereCaseInsensitive (name, value) queryBuilderProvider = injectQueryBuild
         queryBuilder = getQueryBuilder queryBuilderProvider
 {-# INLINE filterWhereCaseInsensitive #-}
 
+
+filterWhereIdIn :: forall table model queryBuilderProvider (joinRegister :: *). (KnownSymbol table, Table model, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister) => [Id model] -> queryBuilderProvider table -> queryBuilderProvider table
+filterWhereIdIn values queryBuilderProvider =
+    -- We don't need to treat null values differently here, because primary keys imply not-null
+    let
+        pkConditions = map (primaryKeyConditionForId @model) values
+
+        queryBuilder = getQueryBuilder queryBuilderProvider
+
+        whereInQuery = FilterByQueryBuilder {queryBuilder, queryFilter = (primaryKeyConditionColumnSelector @model, InOp, toField (In pkConditions)), applyLeft = Nothing, applyRight = Nothing}
+     in
+        injectQueryBuilder whereInQuery
+{-# INLINE filterWhereIdIn #-}
+
+
 -- | Joins a table to an existing QueryBuilder (or something holding a QueryBuilder) on the specified columns. Example:
 -- >    query @Posts 
 -- > |> innerJoin @Users (#author, #id)

IHP/SchemaCompiler.hs

@@ -581,11 +581,21 @@ compileUpdate table@(CreateTable { name, columns }) =
         columnNames = writableColumns
                 |> map (.name)
                 |> intercalate ", "
+
+        primaryKeyPattern = case primaryKeyColumns table of
+                                [] -> error $ "Impossible happened in compileUpdate. No primary keys found for table " <> cs name <> ". At least one primary key is required."
+                                [col] -> col.name
+                                cols -> "(" <> commaSep (map (\col -> col.name) cols) <> ")"
+
+        primaryKeyParameters = case primaryKeyColumns table of
+                                [] -> error $ "Impossible happened in compileUpdate. No primary keys found for table " <> cs name <> ". At least one primary key is required."
+                                [col] -> "?"
+                                cols -> "(" <> commaSep (map (const "?") (primaryKeyColumns table)) <> ")"
     in
         "instance CanUpdate " <> modelName <> " where\n"
         <> indent ("updateRecord model = do\n"
                 <> indent (
-                    "List.head <$> sqlQuery \"UPDATE " <> name <> " SET " <> updates <> " WHERE id = ? RETURNING " <> columnNames <> "\" (" <> bindings <> ")\n"
+                    "List.head <$> sqlQuery \"UPDATE " <> name <> " SET " <> updates <> " WHERE " <> primaryKeyPattern <> " = "<> primaryKeyParameters <> " RETURNING " <> columnNames <> "\" (" <> bindings <> ")\n"
                 )
             )
 
@@ -607,19 +617,25 @@ instance FromRow #{modelName} where
 
         compileField (fieldName, _)
             | isColumn fieldName = fieldName
-            | isManyToManyField fieldName = let (Just ref) = find (\(n, _) -> columnNameToFieldName n == fieldName) referencing in compileSetQueryBuilder ref
+            | isOneToManyField fieldName = let (Just ref) = find (\(n, _) -> columnNameToFieldName n == fieldName) referencing in compileSetQueryBuilder ref
             | fieldName == "meta" = "def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }"
             | otherwise = "def"
 
         isPrimaryKey name = name `elem` primaryKeyColumnNames table.primaryKeyConstraint
         isColumn name = name `elem` columnNames
-        isManyToManyField fieldName = fieldName `elem` (referencing |> map (columnNameToFieldName . fst))
+        isOneToManyField fieldName = fieldName `elem` (referencing |> map (columnNameToFieldName . fst))
 
         compileSetQueryBuilder (refTableName, refFieldName) = "(QueryBuilder.filterWhere (#" <> columnNameToFieldName refFieldName <> ", " <> primaryKeyField <> ") (QueryBuilder.query @" <> tableNameToModelName refTableName <> "))"
             where
                 -- | When the referenced column is nullable, we have to wrap the @Id@ in @Just@
                 primaryKeyField :: Text
-                primaryKeyField = if refColumn.notNull then "id" else "Just id"
+                primaryKeyField = if refColumn.notNull then actualPrimaryKeyField else "Just " <> actualPrimaryKeyField
+                actualPrimaryKeyField :: Text
+                actualPrimaryKeyField = case primaryKeyColumns table of
+                        [] -> error $ "Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " <> cs name <> ". At least one primary key is required."
+                        [pk] -> columnNameToFieldName pk.name
+                        pks -> error $ "No support yet for composite foreign keys. Tables cannot have foreign keys to table '" <> cs name <> "' which has more than one column as its primary key."
+
 
                 (Just refTable) = let (Schema statements) = ?schema in
                         statements
@@ -754,8 +770,9 @@ instance #{instanceHead} where
     tableName = \"#{name}\"
     tableNameByteString = Data.Text.Encoding.encodeUtf8 \"#{name}\"
     columnNames = #{columnNames}
-    primaryKeyCondition #{pattern} = #{condition}
-    {-# INLINABLE primaryKeyCondition #-}
+    primaryKeyColumnNames = #{primaryKeyColumnNames}
+    primaryKeyConditionForId (#{pattern}) = #{condition}
+    {-# INLINABLE primaryKeyConditionForId #-}
 |]
     where
         instanceHead :: Text
@@ -772,22 +789,22 @@ instance #{instanceHead} where
                     |> \inner -> "(" <> inner <> ")"
 
         primaryKeyColumnNames :: [Text]
-        primaryKeyColumnNames = (primaryKeyColumns table) |> map (.name)
+        primaryKeyColumnNames = primaryKeyColumns table |> map (.name)
 
         primaryKeyFieldNames :: [Text]
         primaryKeyFieldNames = primaryKeyColumnNames |> map columnNameToFieldName
 
         pattern :: Text
-        pattern = tableNameToModelName name <> " { " <> intercalate ", " primaryKeyFieldNames <> " }"
+        pattern = "Id (" <> intercalate ", " primaryKeyFieldNames <> ")"
 
         condition :: Text
-        condition = primaryKeyColumns table
-                |> map primaryKeyToCondition
-                |> intercalate ", "
-                |> \listInner -> "[" <> listInner <> "]"
+        condition = case primaryKeyColumns table of
+                            [] -> error $ "Impossible happened in compileUpdate. No primary keys found for table " <> cs name <> ". At least one primary key is required."
+                            [column] -> primaryKeyToCondition column
+                            cols -> "Many [Plain \"(\", " <> intercalate ", Plain \",\", " (map primaryKeyToCondition cols)<> ", Plain \")\"]"
 
         primaryKeyToCondition :: Column -> Text
-        primaryKeyToCondition column = "(\"" <> column.name <> "\", toField " <> columnNameToFieldName column.name <> ")"
+        primaryKeyToCondition column = "toField " <> columnNameToFieldName column.name
 
         columnNames = columns
                 |> map (.name)