From 8e2a0e05ea6720e7f6031745ccec49fb47341b49 Mon Sep 17 00:00:00 2001 From: steve-chavez Date: Sat, 27 Jan 2018 20:26:39 -0500 Subject: [PATCH] Refactor QueryBuilder and DbRequestBuilder - Refactor ORDER BY and LIMIT query fragments - Move ReadRequest building to DbRequestBuilder - Clarify Relation link table attributes - Change Join Operation to JoinCond --- src/PostgREST/DbRequestBuilder.hs | 86 ++++++++++++++++--------------- src/PostgREST/Parsers.hs | 34 ++++-------- src/PostgREST/QueryBuilder.hs | 59 ++++++++------------- src/PostgREST/Types.hs | 13 ++--- 4 files changed, 81 insertions(+), 111 deletions(-) diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs index d566316e1..c0cecedec 100644 --- a/src/PostgREST/DbRequestBuilder.hs +++ b/src/PostgREST/DbRequestBuilder.hs @@ -31,7 +31,7 @@ import PostgREST.ApiRequest ( ApiRequest(..) ) import PostgREST.Error (apiRequestError) import PostgREST.Parsers -import PostgREST.RangeQuery (NonnegRange, restrictRange) +import PostgREST.RangeQuery (NonnegRange, restrictRange, allRange) import PostgREST.Types import Protolude hiding (from, dropWhile, drop) @@ -43,8 +43,10 @@ readRequest maxRows allRels proc apiRequest = mapLeft apiRequestError $ treeRestrictRange maxRows =<< augumentRequestWithJoin schema relations =<< - parseReadRequest + addFiltersOrdersRanges apiRequest <*> + (buildReadRequest <$> pRequestSelect (iSelect apiRequest)) where + action = iAction apiRequest (schema, rootTableName) = fromJust $ -- Make it safe let target = iTarget apiRequest in case target of @@ -58,17 +60,17 @@ readRequest maxRows allRels proc apiRequest = _ -> Nothing - action :: Action - action = iAction apiRequest - - parseReadRequest :: Either ApiRequestError ReadRequest - parseReadRequest = addFiltersOrdersRanges apiRequest <*> - pRequestSelect rootName selStr + buildReadRequest :: [Tree SelectItem] -> ReadRequest + buildReadRequest fieldTree = + let rootNodeName = if action == ActionRead then rootTableName else sourceCTEName in + foldr treeEntry (Node (Select [] [rootNodeName] [] [] [] allRange, (rootNodeName, Nothing, Nothing, Nothing)) []) fieldTree where - selStr = iSelect apiRequest - rootName = if action == ActionRead - then rootTableName - else sourceCTEName + treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest + treeEntry (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) = + case fldForest of + [] -> Node (q {select=fld:select q}, i) rForest + _ -> Node (q, i) $ + foldr treeEntry (Node (Select [] [fn] [] [] [] allRange, (fn, Nothing, alias, relationDetail)) []) fldForest:rForest relations :: [Relation] relations = case action of @@ -77,7 +79,19 @@ readRequest maxRows allRels proc apiRequest = ActionDelete -> fakeSourceRelations ++ allRels ActionInvoke _ -> fakeSourceRelations ++ allRels _ -> allRels - where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation + where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels + +-- in a relation where one of the tables matches "TableName" +-- replace the name to that table with pg_source +-- this "fake" relations is needed so that in a mutate query +-- we can look a the "returning *" part which is wrapped with a "with" +-- as just another table that has relations with other tables +toSourceRelation :: TableName -> Relation -> Maybe Relation +toSourceRelation mt r@(Relation t _ ft _ _ rt _ _) + | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}} + | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}} + | Just mt == (tableName <$> rt) = Just $ r {relLinkTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt} + | otherwise = Nothing treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request @@ -88,7 +102,7 @@ treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` re augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest augumentRequestWithJoin schema allRels request = addRelations schema allRels Nothing request - >>= addJoinFilters schema + >>= addJoinConditions schema addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias, relationDetail)) forest) = @@ -171,7 +185,7 @@ addRelations schema allRelations parentNode (Node readNode@(query, (name, _, ali relType r == Many && nodeTableName == tableName (relTable r) && -- match relation table name parentNodeTableName == tableName (relFTable r) && -- match relation foreign table name - rd == tableName (fromJust (relLTable r)) + rd == tableName (fromJust (relLinkTable r)) ) ) ) allRelations @@ -189,35 +203,35 @@ addRelations schema allRelations parentNode (Node readNode@(query, (name, _, ali updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest] updateForest n = mapM (addRelations schema allRelations n) forest -addJoinFilters :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest -addJoinFilters schema (Node node@(query, nodeProps@(_, relation, _, _)) forest) = +addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest +addJoinConditions schema (Node node@(query, nodeProps@(_, relation, _, _)) forest) = case relation of Just Relation{relType=Root} -> Node node <$> updatedForest -- this is the root node Just rel@Relation{relType=Parent} -> Node (augmentQuery rel, nodeProps) <$> updatedForest Just rel@Relation{relType=Child} -> Node (augmentQuery rel, nodeProps) <$> updatedForest - Just rel@Relation{relType=Many, relLTable=(Just linkTable)} -> + Just rel@Relation{relType=Many, relLinkTable=(Just linkTable)} -> let rq = augmentQuery rel in Node (rq{from=tableName linkTable:from rq}, nodeProps) <$> updatedForest _ -> Left UnknownRelation where - updatedForest = mapM (addJoinFilters schema) forest - augmentQuery rel = foldr addFilterToReadQuery query (getJoinFilters rel) - addFilterToReadQuery flt rq@Select{where_=lf} = rq{where_=addFilterToLogicForest flt lf}::ReadQuery + updatedForest = mapM (addJoinConditions schema) forest + augmentQuery rel = foldr addJoinCondToReadQuery query (getJoinConds rel) + addJoinCondToReadQuery jc rq@Select{joinConds=jcs} = rq{joinConds=jc:jcs}::ReadQuery -getJoinFilters :: Relation -> [Filter] -getJoinFilters (Relation t cols ft fcs typ lt lc1 lc2) = +getJoinConds :: Relation -> [JoinCond] +getJoinConds (Relation t cols ft fcs typ lt lc1 lc2) = case typ of - Child -> zipWith (toFilter tN ftN) cols fcs - Parent -> zipWith (toFilter tN ftN) cols fcs - Many -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2) - Root -> undefined --error "undefined getJoinFilters" + Child -> zipWith (toJoinCond tN ftN) cols fcs + Parent -> zipWith (toJoinCond tN ftN) cols fcs + Many -> zipWith (toJoinCond tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toJoinCond ftN ltN) fcs (fromMaybe [] lc2) + Root -> undefined where s = if typ == Parent then "" else tableSchema t tN = tableName t ftN = tableName ft ltN = fromMaybe "" (tableName <$> lt) - toFilter :: Text -> Text -> Column -> Column -> Filter - toFilter tb ftb c fc = Filter (colName c, Nothing) (OpExpr False (Join (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}}))) + toJoinCond :: Text -> Text -> Column -> Column -> JoinCond + toJoinCond tb ftb c fc = JoinCond (QualifiedIdentifier s tb, colName c) (QualifiedIdentifier s ftb, colName fc) addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest) addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [ @@ -254,7 +268,7 @@ addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest addFilter = addProperty addFilterToNode addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest -addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f +addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest addOrder = addProperty addOrderToNode @@ -292,18 +306,6 @@ addProperty f (path, a) (Node rn forest) = fnd :: ReadRequest -> Bool fnd (Node (_,(n,_,_,_)) _) = n == name --- in a relation where one of the tables mathces "TableName" --- replace the name to that table with pg_source --- this "fake" relations is needed so that in a mutate query --- we can look a the "returning *" part which is wrapped with a "with" --- as just another table that has relations with other tables -toSourceRelation :: TableName -> Relation -> Maybe Relation -toSourceRelation mt r@(Relation t _ ft _ _ rt _ _) - | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}} - | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}} - | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt} - | otherwise = Nothing - mutateRequest :: ApiRequest -> TableName -> [Text] -> [FieldName] -> Either Response MutateRequest mutateRequest apiRequest tName pkCols fldNames = mapLeft apiRequestError $ case action of diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 769b0eaa7..afcd24b62 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -8,14 +8,14 @@ import Data.Text (intercalate, replace, strip) import Data.List (init, last) import Data.Tree import Data.Either.Combinators (mapLeft) -import PostgREST.RangeQuery (NonnegRange,allRange) +import PostgREST.RangeQuery (NonnegRange) import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>)) import Text.Parsec.Error -pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest -pRequestSelect rootName selStr = - mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) +pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem] +pRequestSelect selStr = + mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter) pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper) @@ -53,21 +53,6 @@ ws = toS <$> many (oneOf " \t") lexeme :: Parser a -> Parser a lexeme p = ws *> p <* ws -pReadRequest :: Text -> Parser ReadRequest -pReadRequest rootNodeName = do - fieldTree <- pFieldForest - return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing, Nothing)) []) fieldTree - where - readQuery = Select [] [rootNodeName] [] Nothing allRange - treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest - treeEntry (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) = - case fldForest of - [] -> Node (q {select=fld:select q}, i) rForest - _ -> Node (q, i) newForest - where - newForest = - foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias, relationDetail)) []) fldForest:rForest - pTreePath :: Parser (EmbedPath, Field) pTreePath = do p <- pFieldName `sepBy1` pDelimiter @@ -76,16 +61,15 @@ pTreePath = do pFieldForest :: Parser [Tree SelectItem] pFieldForest = pFieldTree `sepBy1` lexeme (char ',') - -pFieldTree :: Parser (Tree SelectItem) -pFieldTree = try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest) -- TODO: "{}" deprecated - <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) - <|> Node <$> pFieldSelect <*> pure [] + where + pFieldTree :: Parser (Tree SelectItem) + pFieldTree = try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest) -- TODO: "{}" deprecated + <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) + <|> Node <$> pFieldSelect <*> pure [] pStar :: Parser Text pStar = toS <$> (string "*" *> pure ("*"::ByteString)) - pFieldName :: Parser Text pFieldName = do matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) "field name (* or [a..z0..9_])" diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 69fd5c980..01551856d 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -30,7 +30,7 @@ import qualified Hasql.Decoders as HD import qualified Data.Aeson as JSON import PostgREST.Config (pgVersion96) -import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset, allRange) +import PostgREST.RangeQuery (rangeLimit, rangeOffset, allRange) import qualified Data.HashMap.Strict as HM import Data.Maybe import qualified Data.Set as S @@ -206,47 +206,31 @@ pgFmtLit x = requestToCountQuery :: Schema -> DbRequest -> SqlQuery requestToCountQuery _ (DbMutate _) = undefined -requestToCountQuery schema (DbRead (Node (Select _ _ logicForest _ _, (mainTbl, _, _, _)) _)) = +requestToCountQuery schema (DbRead (Node (Select _ _ logicForest _ _ _, (mainTbl, _, _, _)) _)) = unwords [ "SELECT pg_catalog.count(*)", "FROM ", fromQi qi, - ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) filteredLogic)) `emptyOnFalse` null filteredLogic + ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest ] where qi = removeSourceCTESchema schema mainTbl - -- all foreing key filters are root nodes(see addFilterToLogicForest), only those are filtered - nonFKRoot :: LogicTree -> Bool - nonFKRoot (Stmnt (Filter _ (OpExpr _ (Join _ _)))) = False - nonFKRoot (Stmnt _) = True - nonFKRoot Expr{} = True - filteredLogic = filter nonFKRoot logicForest requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery -requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest ord range, (nodeName, maybeRelation, _, _)) forest)) = +requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest joinConds_ ordts range, (nodeName, maybeRelation, _, _)) forest)) = query where mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation) qi = removeSourceCTESchema schema mainTbl toQi = removeSourceCTESchema schema query = unwords [ - "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), - "FROM ", intercalate ", " (map (fromQi . toQi) tbls), + "SELECT " <> intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), + "FROM " <> intercalate ", " (map (fromQi . toQi) tbls), unwords joins, - ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest, - orderF (fromMaybe [] ord), - if isParent then "" else limitF range - ] - orderF ts = - if null ts - then "" - else "ORDER BY " <> clause - where - clause = intercalate "," (map queryTerm ts) - queryTerm :: OrderTerm -> Text - queryTerm t = " " - <> toS (pgFmtField qi $ otTerm t) <> " " - <> maybe "" show (otDirection t) <> " " - <> maybe "" show (otNullOrder t) <> " " + ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCond joinConds_)) + `emptyOnFalse` (null logicForest && null joinConds_), + ("ORDER BY " <> intercalate ", " (map (pgFmtOrderTerm qi) ordts)) `emptyOnFalse` null ordts, + ("LIMIT " <> maybe "ALL" show (rangeLimit range) <> " OFFSET " <> show (rangeOffset range)) `emptyOnFalse` (isParent || range == allRange) ] + (joins, selects) = foldr getQueryParts ([],[]) forest getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment]) @@ -376,14 +360,6 @@ locationF pKeys = [qc|( {("WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')") `emptyOnFalse` null pKeys} )|] -limitF :: NonnegRange -> SqlFragment -limitF r = if r == allRange - then "" - else "LIMIT " <> limit <> " OFFSET " <> offset - where - limit = maybe "ALL" show $ rangeLimit r - offset = show $ rangeOffset r - fromQi :: QualifiedIdentifier -> SqlFragment fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n where @@ -407,6 +383,12 @@ pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment pgFmtSelectItem table (f@(_, jp), Nothing, alias, _) = pgFmtField table f <> pgFmtAs jp alias pgFmtSelectItem table (f@(_, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs jp alias +pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SqlFragment +pgFmtOrderTerm qi ot = unwords [ + toS . pgFmtField qi $ otTerm ot, + maybe "" show $ otDirection ot, + maybe "" show $ otNullOrder ot] + pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of Op op val -> pgFmtFieldOp op <> " " <> case op of @@ -428,9 +410,6 @@ pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper <> maybe "" ((<> ", ") . pgFmtLit) lang <> unknownLiteral val <> ") " - - Join fQi (ForeignKey Column{colTable=Table{tableName=fTableName}, colName=fColName}) -> - pgFmtField fQi fld <> " = " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) fTableName) fColName where pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op sqlOperator o = HM.lookupDefault "=" o operators @@ -442,6 +421,10 @@ pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper (toS (pgFmtLit v) <> "::unknown ") (find ((==) . toLower $ v) ["null","true","false"]) +pgFmtJoinCond :: JoinCond -> SqlFragment +pgFmtJoinCond (JoinCond (qi, cName) (fQi, fcName)) = + pgFmtColumn (removeSourceCTESchema (qiSchema qi) (qiName qi)) cName <> " = " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) (qiName fQi)) fcName + pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment pgFmtLogicTree qi (Expr hasNot op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")" where notOp = if hasNot then "NOT" else "" diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 00ec9610a..efb063c8b 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -149,9 +149,10 @@ data Relation = Relation { , relFTable :: Table , relFColumns :: [Column] , relType :: RelationType -, relLTable :: Maybe Table -, relLCols1 :: Maybe [Column] -, relLCols2 :: Maybe [Column] +-- The Link attrs are used when RelationType == Many +, relLinkTable :: Maybe Table +, relLinkCols1 :: Maybe [Column] +, relLinkCols2 :: Maybe [Column] } deriving (Show, Eq) -- | Cached attributes of a JSON payload @@ -215,8 +216,7 @@ ftsOperators = M.fromList [ data OpExpr = OpExpr Bool Operation deriving (Eq, Show) data Operation = Op Operator SingleVal | In ListVal | - Fts Operator (Maybe Language) SingleVal | - Join QualifiedIdentifier ForeignKey deriving (Eq, Show) + Fts Operator (Maybe Language) SingleVal deriving (Eq, Show) type Language = Text -- | Represents a single value in a filter, e.g. id=eq.singleval @@ -274,8 +274,9 @@ type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe RelationDetail) -- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"] type EmbedPath = [Text] data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq) +data JoinCond = JoinCond (QualifiedIdentifier, FieldName) (QualifiedIdentifier, FieldName) deriving (Show, Eq) -data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq) +data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], joinConds::[JoinCond], order::[OrderTerm], range_::NonnegRange } deriving (Show, Eq) data MutateQuery = Insert { in_::TableName, insPkCols::[Text], qPayload::PayloadJSON, onConflict:: Maybe PreferResolution, where_::[LogicTree], returning::[FieldName] } | Delete { in_::TableName, where_::[LogicTree], returning::[FieldName] } | Update { in_::TableName, qPayload::PayloadJSON, where_::[LogicTree], returning::[FieldName] } deriving (Show, Eq)