refactor: PKcols in table, ViewKeyDependency type

* Get PKcols inside tables - done with SQL for tables and
  with an additional step in Haskell for views.

  This fixes an fk column being considered as a pk column on views
  and corrects the test added on
  https://github.com/PostgREST/postgrest/pull/1875/files/1d549768580310e18aac4ffa6dbd01c5b77934a7#r853674126

* classify view key dependencies in SQL

* remove Column from Relationship

* Merge cols/fcols in Relationship and
  ensure allM2ORels and allViewsKeyDependencies fk columns
  are ordered - done by attnum in SQL

* Cardinality now contains relColumns instead of Relationship -
  this simplifies getJoinConditions.

src/PostgREST/App.hs

@@ -63,7 +63,7 @@ import PostgREST.Config                  (AppConfig (..),
 import PostgREST.Config.PgVersion        (PgVersion (..))
 import PostgREST.ContentType             (ContentType (..))
 import PostgREST.DbStructure             (DbStructure (..),
-                                          findIfView, tablePKCols)
+                                          findIfView)
 import PostgREST.DbStructure.Identifiers (FieldName,
                                           QualifiedIdentifier (..),
                                           Schema)
@@ -313,7 +313,7 @@ handleCreate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
 handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
   let
     ApiRequest{..} = ctxApiRequest
-    pkCols = tablePKCols ctxDbStructure qiSchema qiName
+    pkCols = maybe mempty tablePKCols $ M.lookup identifier $ dbTables ctxDbStructure
 
   WriteQueryResult{..} <- writeQuery MutationCreate identifier True pkCols context
 
@@ -433,7 +433,7 @@ handleInfo identifier RequestContext{..} =
           ++ ["DELETE" | tableDeletable table]
       )
     hasPK =
-      not $ null $ tablePKCols ctxDbStructure (qiSchema identifier) (qiName identifier)
+      not $ null $ maybe mempty tablePKCols $ M.lookup identifier (dbTables ctxDbStructure)
 
 handleInvoke :: InvokeMethod -> ProcDescription -> RequestContext -> DbHandler Wai.Response
 handleInvoke invMethod proc context@RequestContext{..} = do
@@ -537,7 +537,7 @@ writeQuery mutation identifier@QualifiedIdentifier{..} isInsert pkCols context@R
   mutateReq <-
     liftEither $
       ReqBuilder.mutateRequest mutation qiSchema qiName ctxApiRequest
-        (tablePKCols ctxDbStructure qiSchema qiName)
+        (maybe mempty tablePKCols $ M.lookup identifier $ dbTables ctxDbStructure)
         readReq
 
   (_, queryTotal, fields, body, gucHeaders, gucStatus) <-

src/PostgREST/DbStructure/Relationship.hs

@@ -3,42 +3,37 @@
 
 module PostgREST.DbStructure.Relationship
   ( Cardinality(..)
-  , PrimaryKey(..)
   , Relationship(..)
   , Junction(..)
   , isSelfReference
   ) where
 
 import qualified Data.Aeson as JSON
 
-import PostgREST.DbStructure.Identifiers (QualifiedIdentifier)
-import PostgREST.DbStructure.Table       (Column (..), Table)
+import PostgREST.DbStructure.Identifiers (FieldName,
+                                          QualifiedIdentifier)
 
 import Protolude
 
 
 -- | Relationship between two tables.
---
--- The order of the relColumns and relForeignColumns should be maintained to get the
--- join conditions right.
---
--- TODO merge relColumns and relForeignColumns to a tuple or Data.Bimap
 data Relationship = Relationship
-  { relTable          :: QualifiedIdentifier
-  , relColumns        :: [Column]
-  , relForeignTable   :: QualifiedIdentifier
-  , relForeignColumns :: [Column]
-  , relCardinality    :: Cardinality
+  { relTable        :: QualifiedIdentifier
+  , relForeignTable :: QualifiedIdentifier
+  , relCardinality  :: Cardinality
   }
   deriving (Eq, Generic, JSON.ToJSON)
 
 -- | The relationship cardinality
 -- | https://en.wikipedia.org/wiki/Cardinality_(data_modeling)
 -- TODO: missing one-to-one
 data Cardinality
-  = O2M FKConstraint -- ^ one-to-many cardinality
-  | M2O FKConstraint -- ^ many-to-one cardinality
-  | M2M Junction     -- ^ many-to-many cardinality
+  = O2M {relCons :: FKConstraint, relColumns :: [(FieldName, FieldName)]}
+  -- ^ one-to-many
+  | M2O {relCons :: FKConstraint, relColumns :: [(FieldName, FieldName)]}
+  -- ^ many-to-one
+  | M2M Junction
+  -- ^ many-to-many
   deriving (Eq, Generic, JSON.ToJSON)
 
 type FKConstraint = Text
@@ -47,17 +42,11 @@ type FKConstraint = Text
 data Junction = Junction
   { junTable       :: QualifiedIdentifier
   , junConstraint1 :: FKConstraint
-  , junColumns1    :: [Column]
   , junConstraint2 :: FKConstraint
-  , junColumns2    :: [Column]
+  , junColumns1    :: [(FieldName, FieldName)]
+  , junColumns2    :: [(FieldName, FieldName)]
   }
   deriving (Eq, Generic, JSON.ToJSON)
 
 isSelfReference :: Relationship -> Bool
 isSelfReference r = relTable r == relForeignTable r
-
-data PrimaryKey = PrimaryKey
-  { pkTable :: Table
-  , pkName  :: Text
-  }
-  deriving (Generic, JSON.ToJSON)

src/PostgREST/DbStructure/Table.hs

@@ -27,6 +27,7 @@ data Table = Table
   , tableInsertable  :: Bool
   , tableUpdatable   :: Bool
   , tableDeletable   :: Bool
+  , tablePKCols      :: [FieldName]
   }
   deriving (Show, Ord, Generic, JSON.ToJSON)
 

src/PostgREST/Error.hs

@@ -40,8 +40,6 @@ import PostgREST.DbStructure.Proc         (ProcDescription (..),
 import PostgREST.DbStructure.Relationship (Cardinality (..),
                                            Junction (..),
                                            Relationship (..))
-import PostgREST.DbStructure.Table        (Column (..))
-
 import Protolude
 
 
@@ -158,15 +156,15 @@ compressedRel Relationship{..} =
     : case relCardinality of
         M2M Junction{..} -> [
             "cardinality" .= ("many-to-many" :: Text)
-          , "relationship" .= (qiName junTable <> " using " <> junConstraint1 <> fmtEls (colName <$> junColumns1) <> " and " <> junConstraint2 <> fmtEls (colName <$> junColumns2))
+          , "relationship" .= (qiName junTable <> " using " <> junConstraint1 <> fmtEls (snd <$> junColumns1) <> " and " <> junConstraint2 <> fmtEls (snd <$> junColumns2))
           ]
-        M2O cons -> [
+        M2O cons relColumns -> [
             "cardinality" .= ("many-to-one" :: Text)
-          , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (colName <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (colName <$> relForeignColumns))
+          , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns))
           ]
-        O2M cons -> [
+        O2M cons relColumns -> [
             "cardinality" .= ("one-to-many" :: Text)
-          , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (colName <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (colName <$> relForeignColumns))
+          , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns))
           ]
 
 relHint :: [Relationship] -> Text
@@ -176,8 +174,8 @@ relHint rels = T.intercalate ", " (hintList <$> rels)
       let buildHint rel = "'" <> qiName relForeignTable <> "!" <> rel <> "'" in
       case relCardinality of
         M2M Junction{..} -> buildHint (qiName junTable)
-        M2O cons         -> buildHint cons
-        O2M cons         -> buildHint cons
+        M2O cons _       -> buildHint cons
+        O2M cons _       -> buildHint cons
 
 data PgError = PgError Authenticated SQL.UsageError
 type Authenticated = Bool

src/PostgREST/OpenAPI.hs

@@ -3,7 +3,6 @@ Module      : PostgREST.OpenAPI
 Description : Generates the OpenAPI output
 -}
 {-# LANGUAGE LambdaCase      #-}
-{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
 module PostgREST.OpenAPI (encode) where
 
@@ -28,12 +27,11 @@ import Data.Swagger
 import PostgREST.Config                   (AppConfig (..), Proxy (..),
                                            isMalformedProxyUri, toURI)
 import PostgREST.DbStructure              (DbStructure (..),
-                                           tableCols, tablePKCols)
+                                           tableCols)
 import PostgREST.DbStructure.Identifiers  (QualifiedIdentifier (..))
 import PostgREST.DbStructure.Proc         (ProcDescription (..),
                                            ProcParam (..))
 import PostgREST.DbStructure.Relationship (Cardinality (..),
-                                           PrimaryKey (..),
                                            Relationship (..))
 import PostgREST.DbStructure.Table        (Column (..), Table (..),
                                            TablesMap)
@@ -52,7 +50,6 @@ encode conf dbStructure tables procs schemaDescription =
       (openApiTableInfo dbStructure <$> (snd <$> M.toList tables))
       (proxyUri conf)
       schemaDescription
-      (dbPrimaryKeys dbStructure)
 
 makeMimeList :: [ContentType] -> MimeList
 makeMimeList cs = MimeList $ fmap (fromString . BS.unpack . toMime) cs
@@ -83,52 +80,52 @@ parseDefault colType colDefault =
   where
     wrapInQuotations text = "\"" <> text <> "\""
 
-makeTableDef :: [Relationship] -> [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)
-makeTableDef rels pks (t, cs, _) =
+makeTableDef :: [Relationship] -> (Table, [Column]) -> (Text, Schema)
+makeTableDef rels (t, cs) =
   let tn = tableName t in
       (tn, (mempty :: Schema)
         & description .~ tableDescription t
         & type_ ?~ SwaggerObject
-        & properties .~ fromList (fmap (makeProperty rels pks) cs)
+        & properties .~ fromList (fmap (makeProperty rels) cs)
         & required .~ fmap colName (filter (not . colNullable) cs))
 
-makeProperty :: [Relationship] -> [PrimaryKey] -> Column -> (Text, Referenced Schema)
-makeProperty rels pks c = (colName c, Inline s)
+makeProperty :: [Relationship] -> Column -> (Text, Referenced Schema)
+makeProperty rels col = (colName col, Inline s)
   where
-    e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c
+    e = if null $ colEnum col then Nothing else JSON.decode $ JSON.encode $ colEnum col
     fk :: Maybe Text
     fk =
       let
         -- Finds the relationship that has a single column foreign key
         rel = find (\case
-          Relationship{relColumns, relCardinality=M2O _} -> [c] == relColumns
-          _                                                 -> False
+          Relationship{relCardinality=(M2O _ relColumns)} -> [colName col] == (fst <$> relColumns)
+          _                                               -> False
           ) rels
-        fCol = colName <$> (headMay . relForeignColumns =<< rel)
+        fCol = (headMay . (\r -> snd <$> relColumns (relCardinality r)) =<< rel)
         fTbl = qiName . relForeignTable <$> rel
         fTblCol = (,) <$> fTbl <*> fCol
       in
         (\(a, b) -> T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]) <$> fTblCol
     pk :: Bool
-    pk = any (\p -> pkTable p == colTable c && pkName p == colName c) pks
+    pk = colName col `elem` tablePKCols (colTable col)
     n = catMaybes
       [ Just "Note:"
       , if pk then Just "This is a Primary Key.<pk/>" else Nothing
       , fk
       ]
     d =
       if length n > 1 then
-        Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription c) (T.intercalate "\n" n)
+        Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription col) (T.intercalate "\n" n)
       else
-        colDescription c
+        colDescription col
     s =
       (mempty :: Schema)
-        & default_ .~ (JSON.decode . toUtf8Lazy . parseDefault (colType c) =<< colDefault c)
+        & default_ .~ (JSON.decode . toUtf8Lazy . parseDefault (colType col) =<< colDefault col)
         & description .~ d
         & enum_ .~ e
-        & format ?~ colType c
-        & maxLength .~ (fromIntegral <$> colMaxLen c)
-        & type_ .~ toSwaggerType (colType c)
+        & format ?~ colType col
+        & maxLength .~ (fromIntegral <$> colMaxLen col)
+        & type_ .~ toSwaggerType (colType col)
 
 makeProcSchema :: ProcDescription -> Schema
 makeProcSchema pd =
@@ -165,7 +162,7 @@ makeProcParam pd =
   , Ref $ Reference "preferParams"
   ]
 
-makeParamDefs :: [(Table, [Column], [Text])] -> [(Text, Param)]
+makeParamDefs :: [(Table, [Column])] -> [(Text, Param)]
 makeParamDefs ti =
   [ ("preferParams", makePreferParam ["params=single-object"])
   , ("preferReturn", makePreferParam ["return=representation", "return=minimal", "return=none"])
@@ -222,7 +219,7 @@ makeParamDefs ti =
         & type_ ?~ SwaggerString))
   ]
   <> concat [ makeObjectBody (tableName t) : makeRowFilters (tableName t) cs
-            | (t, cs, _) <- ti
+            | (t, cs) <- ti
             ]
 
 makeObjectBody :: Text -> (Text, Param)
@@ -247,8 +244,8 @@ makeRowFilter tn c =
 makeRowFilters :: Text -> [Column] -> [(Text, Param)]
 makeRowFilters tn = fmap (makeRowFilter tn)
 
-makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
-makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpdatable t || tableDeletable t)
+makePathItem :: (Table, [Column]) -> (FilePath, PathItem)
+makePathItem (t, cs) = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpdatable t || tableDeletable t)
   where
     -- Use first line of table description as summary; rest as description (if present)
     -- We strip leading newlines from description so that users can include a blank line between summary and description
@@ -312,7 +309,7 @@ makeRootPathItem = ("/", p)
     pr = (mempty :: PathItem) & get ?~ getOp
     p = pr
 
-makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
+makePathItems :: [ProcDescription] -> [(Table, [Column])] -> InsOrdHashMap FilePath PathItem
 makePathItems pds ti = fromList $ makeRootPathItem :
   fmap makePathItem ti ++ fmap makeProcPathItem pds
 
@@ -324,8 +321,8 @@ escapeHostName "*6" = "0.0.0.0"
 escapeHostName "!6" = "0.0.0.0"
 escapeHostName h    = h
 
-postgrestSpec :: [Relationship] -> [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger
-postgrestSpec rels pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
+postgrestSpec :: [Relationship] -> [ProcDescription] -> [(Table, [Column])] -> (Text, Text, Integer, Text) -> Maybe Text -> Swagger
+postgrestSpec rels pds ti (s, h, p, b) sd = (mempty :: Swagger)
   & basePath ?~ T.unpack b
   & schemes ?~ [s']
   & info .~ ((mempty :: Info)
@@ -336,7 +333,7 @@ postgrestSpec rels pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
     & description ?~ "PostgREST Documentation"
     & url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))
   & host .~ h'
-  & definitions .~ fromList (makeTableDef rels pks <$> ti)
+  & definitions .~ fromList (makeTableDef rels <$> ti)
   & parameters .~ fromList (makeParamDefs ti)
   & paths .~ makePathItems pds ti
   & produces .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
@@ -383,9 +380,8 @@ proxyUri AppConfig{..} =
     Nothing ->
       ("http", configServerHost, toInteger configServerPort, "/")
 
-openApiTableInfo :: DbStructure -> Table -> (Table, [Column], [Text])
+openApiTableInfo :: DbStructure -> Table -> (Table, [Column])
 openApiTableInfo dbStructure table =
   ( table
   , tableCols dbStructure (tableSchema table) (tableName table)
-  , tablePKCols dbStructure (tableSchema table) (tableName table)
   )

src/PostgREST/Query/QueryBuilder.hs

@@ -53,7 +53,7 @@ getJoinsSelects :: ReadRequest -> ([SQL.Snippet], [SQL.Snippet]) -> ([SQL.Snippe
 getJoinsSelects rr@(Node (_, (name, Just Relationship{relCardinality=card,relTable=QualifiedIdentifier{qiName=table}}, alias, _, joinType, _)) _) (joins,selects) =
   let subquery = readRequestToQuery rr in
   case card of
-    M2O _ ->
+    M2O _ _ ->
       let aliasOrName = fromMaybe name alias
           localTableName = pgFmtIdent $ table <> "_" <> aliasOrName
           sel = SQL.sql ("row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName)