diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs index 28eb2a635..020d06c46 100644 --- a/src/PostgREST/DbRequestBuilder.hs +++ b/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 - hint == (tableName . junTable <$> relJunction) -- users_tasks + relType == M2M && -- many-to-many between users and 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=M2O} -> Node (augmentQuery r, nodeProps) <$> updatedForest - Just r@Relation{relType=M2M, relJunction=junction} -> - case junction of - Just Junction{junTable} -> - let rq = augmentQuery r in - Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest - Nothing -> - Left UnknownRelation + Just r@Relation{relType=M2M, relLink=Junction{junTable}} -> + let rq = augmentQuery r in + Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest + Just r -> Node (augmentQuery r, nodeProps) <$> updatedForest 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) = - case typ of - O2M -> - zipWith (toJoinCondition tN ftN) cols fCols - M2O -> - 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 -> [] +getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols _ lnk) = + case lnk of + Junction Table{tableName=jtn} _ jc1 _ jc2 -> + zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2 + Constraint _ -> + zipWith (toJoinCondition tN ftN) cols fCols where toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition toJoinCondition tb ftb c fc = diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 7a7b1b1af..8e02d030f 100644 --- a/src/PostgREST/DbStructure.hs +++ b/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) - relConstraint relFTable relFColumns - M2O Nothing + [ Relation + (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns) + relFTable relFColumns + relType relLink | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns ] tableViewM2O = - [ Relation relTable relColumns - relConstraint - (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns) - M2O Nothing + [ Relation + relTable relColumns + (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns) + relType relLink | fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relFColumns ] viewViewM2O = - [ Relation (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns) - relConstraint - (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns) - M2O Nothing + [ Relation + (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns) + (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns) + 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 - | Relation t c con ft fc typ _ <- rels +addO2MRels rels = rels ++ [ Relation ft fc t c O2M lnk + | 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) - | Relation jt1 jc1 con1 t c _ _ <- rels - , Relation jt2 jc2 con2 ft fc _ _ <- rels +addM2MRels rels = rels ++ [ Relation t c ft fc M2M (Junction jt1 lnk1 jc1 lnk2 jc2) + | Relation jt1 jc1 t c _ lnk1 <- 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 diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index c016c0112..608d19ebe 100644 --- a/src/PostgREST/Error.hs +++ b/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) - , "target" .= fmtTbl (relFTable rel) - , "cardinality" .= (show $ relType rel :: Text) + "origin" .= fmtTbl relTable + , "target" .= fmtTbl relFTable + , "cardinality" .= (show relType :: Text) ] ++ - case (relType rel, relJunction rel, relConstraint rel) of - (M2M, Just (Junction jt (Just const1) _ (Just const2) _), _) -> [ - "relationship" .= (fmtTbl jt <> fmtEls [const1] <> fmtEls [const2]) + case relLink of + Junction{..} -> [ + "relationship" .= (fmtTbl junTable <> fmtEls [constName junLink1] <> fmtEls [constName junLink2]) ] - (_, _, Just relCon) -> [ - "relationship" .= (relCon <> fmtEls (colName <$> relColumns rel) <> fmtEls (colName <$> relFColumns rel)) + Constraint{..} -> [ + "relationship" .= (constName <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relFColumns)) ] - (_, _, _) -> - mempty data PgError = PgError Authenticated P.UsageError deriving Show type Authenticated = Bool diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 1b2bafd71..37ddd9cfb 100644 --- a/src/PostgREST/Types.hs +++ b/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 -, relColumns :: [Column] -, relConstraint :: Maybe ConstraintName -- ^ Just on O2M/M2O, Nothing on M2M -, relFTable :: Table -, relFColumns :: [Column] -, relType :: Cardinality -, relJunction :: Maybe Junction -- ^ Junction for M2M Cardinality + relTable :: Table +, relColumns :: [Column] +, relFTable :: Table +, relFColumns :: [Column] +, relType :: Cardinality +, relLink :: Link -- ^ Constraint on O2M/M2O, Junction for M2M Cardinality } deriving (Show, Eq, Generic, JSON.ToJSON) +type ConstraintName = Text + -- | Junction table on an M2M relationship -data Junction = Junction { - junTable :: Table -, junConstraint1 :: Maybe ConstraintName -, junCols1 :: [Column] -, junConstraint2 :: Maybe ConstraintName -, junCols2 :: [Column] -} deriving (Show, Eq, Generic, JSON.ToJSON) +data Link + = Constraint { constName :: ConstraintName } + | Junction { + junTable :: Table + , junLink1 :: Link + , junCols1 :: [Column] + , junLink2 :: Link + , junCols2 :: [Column] + } + deriving (Show, Eq, Generic, JSON.ToJSON) isSelfReference :: Relation -> Bool isSelfReference r = relTable r == relFTable r