refactor: Combine relConstraint and relJunction in relLink

src/PostgREST/DbRequestBuilder.hs

@@ -10,6 +10,7 @@ A query tree is built in case of resource embedding. By inferring the relationsh
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE RecordWildCards       #-}
 
 module PostgREST.DbRequestBuilder (
   readRequest
@@ -135,13 +136,13 @@ findRel schema allRels origin target hint =
       -- In a self reference we get two relationships with the same foreign key and relTable/relFtable but with different cardinalities(m2o/o2m)
       -- We output the O2M rel, the M2O rel can be obtained by using the origin column as an embed hint.
       let [rel0, rel1] = take 2 rs in
-      if length rs == 2 && relConstraint rel0 == relConstraint rel1 && relTable rel0 == relTable rel1 && relFTable rel0 == relFTable rel1
+      if length rs == 2 && relLink rel0 == relLink rel1 && relTable rel0 == relTable rel1 && relFTable rel0 == relFTable rel1
         then note (NoRelBetween origin target) (find (\r -> relType r == O2M) rs)
         else Left $ AmbiguousRelBetween origin target rs
   where
     matchFKSingleCol hint_ cols = length cols == 1 && hint_ == (colName <$> head cols)
     rel = filter (
-      \Relation{relTable, relColumns, relConstraint, relFTable, relFColumns, relType, relJunction} ->
+      \Relation{..} ->
         -- Both relationship ends need to be on the exposed schema
         schema == tableSchema relTable && schema == tableSchema relFTable &&
         (
@@ -152,7 +153,7 @@ findRel schema allRels origin target hint =
           -- /projects?select=projects_client_id_fkey(*)
           (
             origin == tableName relTable && -- projects
-            Just target == relConstraint    -- projects_client_id_fkey
+            Constraint target == relLink    -- projects_client_id_fkey
           ) ||
           -- /projects?select=client_id(*)
           (
@@ -163,7 +164,10 @@ findRel schema allRels origin target hint =
           isNothing hint || -- hint is optional
 
           -- /projects?select=clients!projects_client_id_fkey(*)
-          hint == relConstraint             || -- projects_client_id_fkey
+          (
+            relType /= M2M &&
+            hint == Just (constName relLink) -- projects_client_id_fkey
+          ) ||
 
           -- /projects?select=clients!client_id(*) or /projects?select=clients!id(*)
           matchFKSingleCol hint relColumns  || -- client_id
@@ -171,8 +175,8 @@ findRel schema allRels origin target hint =
 
           -- /users?select=tasks!users_tasks(*)
           (
-            relType == M2M &&                              -- many-to-many between users and tasks
+            relType == M2M &&                           -- many-to-many between users and tasks
-            hint == (tableName . junTable <$> relJunction) -- users_tasks
+            hint == Just (tableName $ junTable relLink) -- users_tasks
           )
         )
       ) allRels
@@ -181,15 +185,10 @@ findRel schema allRels origin target hint =
 addJoinConditions :: Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest
 addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, rel, _, _, depth)) forest) =
   case rel of
-    Just r@Relation{relType=O2M} -> Node (augmentQuery r, nodeProps) <$> updatedForest
+    Just r@Relation{relType=M2M, relLink=Junction{junTable}} ->
-    Just r@Relation{relType=M2O} -> Node (augmentQuery r, nodeProps) <$> updatedForest
+      let rq = augmentQuery r in
-    Just r@Relation{relType=M2M, relJunction=junction} ->
+      Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest
-      case junction of
+    Just r -> Node (augmentQuery r, nodeProps) <$> updatedForest
-        Just Junction{junTable} ->
-          let rq = augmentQuery r in
-          Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest
-        Nothing ->
-          Left UnknownRelation
     Nothing -> Node node <$> updatedForest
   where
     newAlias = case isSelfReference <$> rel of
@@ -206,17 +205,12 @@ addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_
 
 -- previousAlias and newAlias are used in the case of self joins
 getJoinConditions :: Maybe Alias -> Maybe Alias -> Relation -> [JoinCondition]
-getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, tableName=tN} cols _ Table{tableName=ftN} fCols typ jun) =
+getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols _ lnk) =
-  case typ of
+  case lnk of
-    O2M ->
+    Junction Table{tableName=jtn} _ jc1 _ jc2 ->
-        zipWith (toJoinCondition tN ftN) cols fCols
+      zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2
-    M2O ->
+    Constraint _ ->
-        zipWith (toJoinCondition tN ftN) cols fCols
+      zipWith (toJoinCondition tN ftN) cols fCols
-    M2M -> case jun of
-        Just (Junction jt _ jc1 _ jc2) ->
-          let jtn = tableName jt in
-          zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2
-        Nothing -> []
   where
     toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition
     toJoinCondition tb ftb c fc =

src/PostgREST/DbStructure.hs

@@ -357,39 +357,40 @@ addViewM2ORels allSrcCols = concatMap (\rel@Relation{..} -> rel :
     srcCols `sortAccordingTo` cols = sortOn (\(k, _) -> L.lookup k $ zip cols [0::Int ..]) srcCols
 
     viewTableM2O =
-      [ Relation (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)
+      [ Relation
-             relConstraint relFTable relFColumns
+          (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)
-             M2O Nothing
+          relFTable relFColumns
+          relType relLink
       | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns ]
 
     tableViewM2O =
-      [ Relation relTable relColumns
+      [ Relation
-             relConstraint
+          relTable relColumns
-             (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns)
+          (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns)
-             M2O Nothing
+          relType relLink
       | fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relFColumns ]
 
     viewViewM2O =
-      [ Relation (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)
+      [ Relation
-             relConstraint
+          (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)
-             (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns)
+          (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns)
-             M2O Nothing
+          relType relLink
       | srcCols  <- relSrcCols, srcCols `allSrcColsOf` relColumns
       , fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relFColumns ]
 
   in viewTableM2O ++ tableViewM2O ++ viewViewM2O)
 
 addO2MRels :: [Relation] -> [Relation]
-addO2MRels rels = rels ++ [ Relation ft fc con t c O2M Nothing
+addO2MRels rels = rels ++ [ Relation ft fc t c O2M lnk
-                          | Relation t c con ft fc typ _ <- rels
+                          | Relation t c ft fc typ lnk <- rels
                           , typ == M2O]
 
 addM2MRels :: [Relation] -> [Relation]
-addM2MRels rels = rels ++ [ Relation t c Nothing ft fc M2M (Just $ Junction jt1 con1 jc1 con2 jc2)
+addM2MRels rels = rels ++ [ Relation t c ft fc M2M (Junction jt1 lnk1 jc1 lnk2 jc2)
-                          | Relation jt1 jc1 con1 t c _ _ <- rels
+                          | Relation jt1 jc1 t c _ lnk1 <- rels
-                          , Relation jt2 jc2 con2 ft fc _ _ <- rels
+                          , Relation jt2 jc2 ft fc _ lnk2 <- rels
                           , jt1 == jt2
-                          , con1 /= con2]
+                          , lnk1 /= lnk2]
 
 addViewPrimaryKeys :: [SourceColumn] -> [PrimaryKey] -> [PrimaryKey]
 addViewPrimaryKeys srcCols = concatMap (\pk ->
@@ -586,7 +587,7 @@ allM2ORels tabs cols =
 
 relFromRow :: [Table] -> [Column] -> (Text, Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation
 relFromRow allTabs allCols (rs, rt, cn, rcs, frs, frt, frcs) =
-  Relation <$> table <*> cols <*> pure (Just cn) <*> tableF <*> colsF <*> pure M2O <*> pure Nothing
+  Relation <$> table <*> cols <*> tableF <*> colsF <*> pure M2O <*> pure (Constraint cn)
   where
     findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs
     findCol s t c = find (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col == c) allCols

src/PostgREST/Error.hs

@@ -4,6 +4,7 @@ Description : PostgREST error HTTP responses
 -}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards   #-}
 
 module PostgREST.Error (
   errorResponseFor
@@ -95,25 +96,23 @@ instance JSON.ToJSON ApiRequestError where
     "message" .= ("The schema must be one of the following: " <> T.intercalate ", " schemas)]
 
 compressedRel :: Relation -> JSON.Value
-compressedRel rel =
+compressedRel Relation{..} =
   let
-    fmtTbl tbl = tableSchema tbl <> "." <> tableName tbl
+    fmtTbl Table{..} = tableSchema <> "." <> tableName
     fmtEls els = "[" <> T.intercalate ", " els <> "]"
   in
   JSON.object $ [
-    "origin"      .= fmtTbl (relTable rel)
+    "origin"      .= fmtTbl relTable
-  , "target"      .= fmtTbl (relFTable rel)
+  , "target"      .= fmtTbl relFTable
-  , "cardinality" .= (show $ relType rel :: Text)
+  , "cardinality" .= (show relType :: Text)
   ] ++
-  case (relType rel, relJunction rel, relConstraint rel) of
+  case relLink of
-    (M2M, Just (Junction jt (Just const1) _ (Just const2) _), _) -> [
+    Junction{..} -> [
-      "relationship" .= (fmtTbl jt <> fmtEls [const1] <> fmtEls [const2])
+      "relationship" .= (fmtTbl junTable <> fmtEls [constName junLink1] <> fmtEls [constName junLink2])
       ]
-    (_, _, Just relCon) -> [
+    Constraint{..} -> [
-      "relationship" .= (relCon <> fmtEls (colName <$> relColumns rel) <> fmtEls (colName <$> relFColumns rel))
+      "relationship" .= (constName <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relFColumns))
       ]
-    (_, _, _) ->
-      mempty
 
 data PgError = PgError Authenticated P.UsageError deriving Show
 type Authenticated = Bool

src/PostgREST/Types.hs

@@ -298,31 +298,33 @@ instance Show Cardinality where
   show M2O = "m2o"
   show M2M = "m2m"
 
-type ConstraintName = Text
-
 {-|
   "Relation"ship between two tables.
   The order of the relColumns and relFColumns should be maintained to get the join conditions right.
   TODO merge relColumns and relFColumns to a tuple or Data.Bimap
 -}
 data Relation = Relation {
-  relTable      :: Table
+  relTable    :: Table
-, relColumns    :: [Column]
+, relColumns  :: [Column]
-, relConstraint :: Maybe ConstraintName -- ^ Just on O2M/M2O, Nothing on M2M
+, relFTable   :: Table
-, relFTable     :: Table
+, relFColumns :: [Column]
-, relFColumns   :: [Column]
+, relType     :: Cardinality
-, relType       :: Cardinality
+, relLink     :: Link -- ^ Constraint on O2M/M2O, Junction for M2M Cardinality
-, relJunction   :: Maybe Junction -- ^ Junction for M2M Cardinality
 } deriving (Show, Eq, Generic, JSON.ToJSON)
 
+type ConstraintName = Text
+
 -- | Junction table on an M2M relationship
-data Junction = Junction {
+data Link
-  junTable       :: Table
+  = Constraint { constName :: ConstraintName }
-, junConstraint1 :: Maybe ConstraintName
+  | Junction {
-, junCols1       :: [Column]
+    junTable :: Table
-, junConstraint2 :: Maybe ConstraintName
+  , junLink1 :: Link
-, junCols2       :: [Column]
+  , junCols1 :: [Column]
-} deriving (Show, Eq, Generic, JSON.ToJSON)
+  , junLink2 :: Link
+  , junCols2 :: [Column]
+  }
+  deriving (Show, Eq, Generic, JSON.ToJSON)
 
 isSelfReference :: Relation -> Bool
 isSelfReference r = relTable r == relFTable r