Err embedding when multiple relationships found

When having one-to-many relationships like:

person        -< message[sender]
person        -< message[recipient]
person_detail -< message[sender]
person_detail -< message[recipient]

Where person_detail is a view of person.

This request:

GET "/message?select=*,sender(*)"

Is ambiguous. Both person or person_detail could be embedded.

Until now we have returned the first detected relationship but
now we return a 300 Multiple Choices error with a
descriptive error message asking the user to disambiguate.

This is more helpful for the user and also aids in cases of more
complex relationships.

src/PostgREST/DbRequestBuilder.hs

@@ -23,7 +23,7 @@ import qualified Data.Set              as S
 import Control.Arrow           ((***))
 import Data.Either.Combinators (mapLeft)
 import Data.Foldable           (foldr1)
-import Data.List               (delete)
+import Data.List               (delete, head, (!!))
 import Data.Maybe              (fromJust)
 import Data.Text               (isInfixOf)
 import Text.Regex.TDFA         ((=~))
@@ -38,7 +38,7 @@ import PostgREST.Error      (ApiRequestError (..), errorResponseFor)
 import PostgREST.Parsers
 import PostgREST.RangeQuery (NonnegRange, allRange, restrictRange)
 import PostgREST.Types
-import Protolude            hiding (from)
+import Protolude            hiding (from, head)
 
 readRequest :: Schema -> TableName -> Maybe Integer -> [Relation] -> ApiRequest -> Either Response ReadRequest
 readRequest schema rootTableName maxRows allRels apiRequest  =
@@ -105,9 +105,20 @@ addRelations schema allRelations parentNode (Node (query@Select{from=tbl}, (node
       let newFrom r = if qiName tbl == nodeName then tableQi (relTable r) else tbl
           newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel
           parentNodeTable = qiName parentNodeQi
+          results = findRelation schema allRelations nodeName parentNodeTable relationDetail
           rel :: Either ApiRequestError Relation
-          rel = note (NoRelationBetween parentNodeTable nodeName) $
-                findRelation schema allRelations nodeName parentNodeTable relationDetail in
+          rel = case results of
+            []  -> Left $ NoRelBetween parentNodeTable nodeName
+            [r] -> Right r
+            rs  ->
+              -- Temporary hack for handling a self reference relationship. In this case we get a parent and child rel with the same relTable/relFtable.
+              -- We output the child rel, the parent can be obtained by using the fk column as an embed hint.
+              let rel0 = head rs
+                  rel1 = rs !! 1 in
+              if length rs == 2 && relTable rel0 == relTable rel1 && relFTable rel0 == relFTable rel1
+                then note (NoRelBetween parentNodeTable nodeName) (find (\r -> relType r == Child) rs)
+                else Left $ AmbiguousRelBetween parentNodeTable nodeName rs
+      in
       Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest)
     _ ->
       let rn = (query, (nodeName, Nothing, alias, Nothing, depth)) in
@@ -116,9 +127,9 @@ addRelations schema allRelations parentNode (Node (query@Select{from=tbl}, (node
     updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
     updateForest rq = mapM (addRelations schema allRelations rq) forest
 
-findRelation :: Schema -> [Relation] -> NodeName -> TableName -> Maybe RelationDetail -> Maybe Relation
+findRelation :: Schema -> [Relation] -> NodeName -> TableName -> Maybe RelationDetail -> [Relation]
 findRelation schema allRelations nodeTableName parentNodeTableName relationDetail =
-  find (\Relation{relTable, relColumns, relFTable, relFColumns, relType, relLinkTable} ->
+  filter (\Relation{relTable, relColumns, relFTable, relFColumns, relType, relLinkTable} ->
     -- Both relation ends need to be on the exposed schema
     schema == tableSchema relTable && schema == tableSchema relFTable &&
     case relationDetail of
@@ -210,7 +221,7 @@ addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_
           Left UnknownRelation
     Nothing -> Node node <$> updatedForest
   where
-    newAlias = case isSelfJoin <$> relation of
+    newAlias = case isSelfReference <$> relation of
       Just True
         | depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased
         | otherwise  -> Nothing

src/PostgREST/Error.hs

@@ -16,12 +16,12 @@ module PostgREST.Error (
 ) where
 
 import qualified Data.Aeson                as JSON
+import qualified Data.Text                 as T
 import qualified Hasql.Pool                as P
 import qualified Hasql.Session             as H
 import qualified Network.HTTP.Types.Status as HT
 
 import Data.Aeson  ((.=))
-import Data.Text   (unwords)
 import Network.Wai (Response, responseLBS)
 import Text.Read   (readMaybe)
 
@@ -48,7 +48,8 @@ data ApiRequestError
   | InvalidRange
   | InvalidBody ByteString
   | ParseRequestError Text Text
-  | NoRelationBetween Text Text
+  | NoRelBetween Text Text
+  | AmbiguousRelBetween Text Text [Relation]
   | InvalidFilters
   | UnknownRelation                -- Unreachable?
   | UnsupportedVerb                -- Unreachable?
@@ -62,7 +63,8 @@ instance PgrstError ApiRequestError where
   status UnknownRelation         = HT.status404
   status ActionInappropriate     = HT.status405
   status (ParseRequestError _ _) = HT.status400
-  status (NoRelationBetween _ _) = HT.status400
+  status (NoRelBetween _ _)      = HT.status400
+  status AmbiguousRelBetween{}   = HT.status300
 
   headers _ = [toHeader CTApplicationJSON]
 
@@ -77,13 +79,41 @@ instance JSON.ToJSON ApiRequestError where
     "message" .= ("HTTP Range error" :: Text)]
   toJSON UnknownRelation = JSON.object [
     "message" .= ("Unknown relation" :: Text)]
-  toJSON (NoRelationBetween parent child) = JSON.object [
+  toJSON (NoRelBetween parent child) = JSON.object [
     "message" .= ("Could not find foreign keys between these entities, No relation found between " <> parent <> " and " <> child :: Text)]
+  toJSON (AmbiguousRelBetween parent child rels) = JSON.object [
+    "hint"    .= ("Disambiguate by choosing a relationship from the `details` key" :: Text),
+    "message" .= ("More than one relationship was found for " <> parent <> " and " <> child :: Text),
+    "details" .= (compressedRel <$> rels) ]
   toJSON UnsupportedVerb = JSON.object [
     "message" .= ("Unsupported HTTP verb" :: Text)]
   toJSON InvalidFilters = JSON.object [
     "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)]
 
+compressedRel :: Relation -> JSON.Value
+compressedRel rel =
+  let
+    -- | Format like "test.orders[billing_address_id]". For easier debugging the format is compressed instead of structured.
+    fmt sch tbl cols = schTbl sch tbl <> joinCols cols
+    fmtMany sch tbl cols1 cols2 = schTbl sch tbl <> joinCols cols1 <> joinCols cols2
+    schTbl sch tbl = sch <> "." <> tbl
+    joinCols cols  = "[" <> T.intercalate ", " cols <> "]"
+
+    tab = relTable rel
+    fTab = relFTable rel
+  in
+  JSON.object $ [
+    "source"      .= fmt (tableSchema tab) (tableName tab) (colName <$> relColumns rel)
+  , "target"      .= fmt (tableSchema fTab) (tableName fTab) (colName <$> relFColumns rel)
+  , "cardinality" .= (show $ relType rel :: Text)
+  ] ++
+  if relType rel == Many
+    then [
+     "junction" .= case (relLinkTable rel, relLinkCols1 rel, relLinkCols2 rel) of
+        (Just lt, Just lc1, Just lc2) -> fmtMany (tableSchema lt) (tableName lt) (colName <$> lc1) (colName <$> lc2)
+        _                             -> toS $ JSON.encode JSON.Null
+      ]
+    else mempty
 
 data PgError = PgError Authenticated P.UsageError
 type Authenticated = Bool
@@ -241,7 +271,7 @@ instance JSON.ToJSON SimpleError where
     "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)]
   toJSON (SingularityError n)      = JSON.object [
     "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),
-    "details" .= unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]]
+    "details" .= T.unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]]
 
   toJSON JwtTokenMissing           = JSON.object [
     "message" .= ("Server lacks JWT secret" :: Text)]

src/PostgREST/Types.hs

@@ -284,8 +284,8 @@ data Relation = Relation {
 , relLinkCols2 :: Maybe [Column]
 } deriving (Show, Eq)
 
-isSelfJoin :: Relation -> Bool
-isSelfJoin r = relTable r == relFTable r
+isSelfReference :: Relation -> Bool
+isSelfReference r = relTable r == relFTable r
 
 data PayloadJSON =
   -- | Cached attributes of a JSON payload