refactor: remove colFK from Column

src/PostgREST/DbStructure.hs

@@ -51,7 +51,6 @@ import PostgREST.DbStructure.Proc         (PgArg (..), PgType (..),
                                            ProcVolatility (..),
                                            ProcsMap, RetType (..))
 import PostgREST.DbStructure.Relationship (Cardinality (..),
-                                           ForeignKey (..),
                                            Junction (..),
                                            PrimaryKey (..),
                                            Relationship (..))
@@ -98,12 +97,11 @@ getDbStructure schemas extraSearchPath pgVer prepared = do
   procs   <- HT.statement schemas $ allProcs prepared
 
   let rels = addO2MRels . addM2MRels $ addViewM2ORels srcCols m2oRels
-      cols' = addForeignKeys rels cols
       keys' = addViewPrimaryKeys srcCols keys
 
   return $ removeInternal schemas $ DbStructure {
       dbTables = tabs
-    , dbColumns = cols'
+    , dbColumns = cols
     , dbRelationships = rels
     , dbPrimaryKeys = keys'
     , dbProcs = procs
@@ -379,20 +377,6 @@ accessibleTables =
       )
     order by relname |]
 
-addForeignKeys :: [Relationship] -> [Column] -> [Column]
-addForeignKeys rels = map addFk
-  where
-    addFk col = col { colFK = fk col }
-    fk col = find (lookupFn col) rels >>= relToFk col
-    lookupFn :: Column -> Relationship -> Bool
-    lookupFn c rel = case rel of
-      Relationship{relColumns=cs, relCardinality=M2O _} -> c `elem` cs
-      _                                                 -> False
-    relToFk col Relationship{relColumns=cols, relForeignColumns=colsF} = do
-      pos <- L.elemIndex col cols
-      colF <- atMay colsF pos
-      return $ ForeignKey colF
-
 {-
 Adds Views M2O Relationships based on SourceColumns found, the logic is as follows:
 
@@ -675,7 +659,7 @@ columnFromRow :: [Table] ->
                  -> Maybe Column
 columnFromRow tabs (s, t, n, desc, nul, typ, l, d, e) = buildColumn <$> table
   where
-    buildColumn tbl = Column tbl n desc nul typ l d (parseEnum e) Nothing
+    buildColumn tbl = Column tbl n desc nul typ l d (parseEnum e)
     table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs
     parseEnum :: Maybe Text -> [Text]
     parseEnum = maybe [] (split (==','))

src/PostgREST/DbStructure/Relationship.hs

@@ -3,7 +3,6 @@
 
 module PostgREST.DbStructure.Relationship
   ( Cardinality(..)
-  , ForeignKey(..)
   , PrimaryKey(..)
   , Relationship(..)
   , Junction(..)
@@ -12,8 +11,7 @@ module PostgREST.DbStructure.Relationship
 
 import qualified Data.Aeson as JSON
 
-import PostgREST.DbStructure.Table (Column (..), ForeignKey (..),
+import PostgREST.DbStructure.Table (Column (..), Table (..))
-                                    Table (..))
 
 import Protolude
 

src/PostgREST/DbStructure/Table.hs

@@ -3,7 +3,6 @@
 
 module PostgREST.DbStructure.Table
   ( Column(..)
-  , ForeignKey(..)
   , Table(..)
   , tableQi
   ) where
@@ -34,10 +33,6 @@ instance Eq Table where
 tableQi :: Table -> QualifiedIdentifier
 tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n
 
-newtype ForeignKey = ForeignKey
-  { fkCol :: Column }
-  deriving (Eq, Ord, Generic, JSON.ToJSON)
-
 data Column = Column
   { colTable       :: Table
   , colName        :: FieldName
@@ -47,7 +42,6 @@ data Column = Column
   , colMaxLen      :: Maybe Int32
   , colDefault     :: Maybe Text
   , colEnum        :: [Text]
-  , colFK          :: Maybe ForeignKey
   }
   deriving (Ord, Generic, JSON.ToJSON)
 

src/PostgREST/OpenAPI.hs

@@ -2,6 +2,8 @@
 Module      : PostgREST.OpenAPI
 Description : Generates the OpenAPI output
 -}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
 module PostgREST.OpenAPI (encode) where
 
@@ -27,10 +29,10 @@ import PostgREST.DbStructure              (DbStructure (..),
                                            tableCols, tablePKCols)
 import PostgREST.DbStructure.Proc         (PgArg (..),
                                            ProcDescription (..))
-import PostgREST.DbStructure.Relationship (PrimaryKey (..))
+import PostgREST.DbStructure.Relationship (Cardinality (..),
-import PostgREST.DbStructure.Table        (Column (..),
+                                           PrimaryKey (..),
-                                           ForeignKey (..),
+                                           Relationship (..))
-                                           Table (..))
+import PostgREST.DbStructure.Table        (Column (..), Table (..))
 import PostgREST.Version                  (docsVersion, prettyVersion)
 
 import PostgREST.ContentType
@@ -42,6 +44,7 @@ encode :: AppConfig -> DbStructure -> [Table] -> Maybe Text -> HashMap.HashMap k
 encode conf dbStructure tables schemaDescription procs =
   JSON.encode $
     postgrestSpec
+      (dbRelationships dbStructure)
       (concat $ HashMap.elems procs)
       (openApiTableInfo dbStructure <$> tables)
       (proxyUri conf)
@@ -64,27 +67,38 @@ toSwaggerType "real"              = SwaggerNumber
 toSwaggerType "double precision"  = SwaggerNumber
 toSwaggerType _                   = SwaggerString
 
-makeTableDef :: [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)
+makeTableDef :: [Relationship] -> [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)
-makeTableDef pks (t, cs, _) =
+makeTableDef rels pks (t, cs, _) =
   let tn = tableName t in
       (tn, (mempty :: Schema)
         & description .~ tableDescription t
         & type_ ?~ SwaggerObject
-        & properties .~ fromList (fmap (makeProperty pks) cs)
+        & properties .~ fromList (fmap (makeProperty rels pks) cs)
         & required .~ fmap colName (filter (not . colNullable) cs))
 
-makeProperty :: [PrimaryKey] -> Column -> (Text, Referenced Schema)
+makeProperty :: [Relationship] -> [PrimaryKey] -> Column -> (Text, Referenced Schema)
-makeProperty pks c = (colName c, Inline s)
+makeProperty rels pks c = (colName c, Inline s)
   where
     e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c
-    fk ForeignKey{fkCol=Column{colTable=Table{tableName=a}, colName=b}} =
+    fk :: Maybe Text
-      T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]
+    fk =
+      let
+        -- Finds the relationship that has a single column foreign key
+        rel = find (\case
+          Relationship{relColumns, relCardinality=M2O _} -> [c] == relColumns
+          _                                                 -> False
+          ) rels
+        fCol = colName <$> (headMay =<< (relForeignColumns <$> rel))
+        fTbl = tableName . 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
     n = catMaybes
       [ Just "Note:"
       , if pk then Just "This is a Primary Key.<pk/>" else Nothing
-      , fk <$> colFK c
+      , fk
       ]
     d =
       if length n > 1 then
@@ -294,8 +308,8 @@ escapeHostName "*6" = "0.0.0.0"
 escapeHostName "!6" = "0.0.0.0"
 escapeHostName h    = h
 
-postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger
+postgrestSpec :: [Relationship] -> [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger
-postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
+postgrestSpec rels pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
   & basePath ?~ T.unpack b
   & schemes ?~ [s']
   & info .~ ((mempty :: Info)
@@ -306,7 +320,7 @@ postgrestSpec 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 pks <$> ti)
+  & definitions .~ fromList (makeTableDef rels pks <$> ti)
   & parameters .~ fromList (makeParamDefs ti)
   & paths .~ makePathItems pds ti
   & produces .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]