diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index c4b972e4c..42c06a831 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -21,168 +21,170 @@ import qualified Hasql.Backend as B findColumn :: [Column] -> Text -> Text -> Text -> Either Text Column findColumn allColumns s t c = note ("no such column: "<>t<>"."<>c) $ - find (\ col -> colSchema col == s && colTable col == t && colName col == c ) allColumns + find (\ col -> colSchema col == s && colTable col == t && colName col == c ) allColumns findTable :: [Table] -> Text -> Text -> Either Text Table findTable allTables s t = note ("no such table: "<>t) $ - find (\tb-> s == tableSchema tb && t == tableName tb ) allTables + find (\tb-> s == tableSchema tb && t == tableName tb ) allTables findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation findRelation allRelations s t1 t2 = - find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations + find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations filterToCondition :: Text -> [Column] -> Text -> Filter -> Either Text Condition filterToCondition schema allColumns table (Filter fld op val) = - Condition <$> c <*> pure op <*> pure (VText (pack val)) - where - c = (,) <$> column <*> pure (snd fld) - column = findColumn allColumns schema table $ pack $ fst fld + Condition <$> c <*> pure op <*> pure (VText (pack val)) + where + c = (,) <$> column <*> pure (snd fld) + column = findColumn allColumns schema table $ pack $ fst fld requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs ord) = - Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel <*> pure ord - where - tblName = pack tblNameS - mainTable = findTable allTables schema tblName - select = mapM toDbSelectItem flds --besides specific columns, we allow * here also - where - -- it's ok not to check that the table exists here, mainTable will do the checking - toDbSelectItem :: SelectItem -> Either Text DbSelectItem - toDbSelectItem (("*", Nothing), Nothing) = Right ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) - toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast - where - col = findColumn allColumns schema tblName $ pack c - dbFld = (,) <$> col <*> pure jp + Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel <*> pure ord + where + tblName = pack tblNameS + mainTable = findTable allTables schema tblName + select = mapM toDbSelectItem flds --besides specific columns, we allow * here also + where + -- it's ok not to check that the table exists here, mainTable will do the checking + toDbSelectItem :: SelectItem -> Either Text DbSelectItem + toDbSelectItem (("*", Nothing), Nothing) = Right ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) + toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast + where + col = findColumn allColumns schema tblName $ pack c + dbFld = (,) <$> col <*> pure jp - qwhere = mapM (filterToCondition schema allColumns tblName) fltrs - joinTables = pure [] - rel = pure Nothing + qwhere = mapM (filterToCondition schema allColumns tblName) fltrs + joinTables = pure [] + rel = pure Nothing addRelations :: [Relation] -> Maybe DbRequest -> DbRequest -> Either Text DbRequest addRelations allRelations parentNode node@(Node query@(Select {qMainTable=table}) forest) = - case parentNode of - Nothing -> Node query{qRelation=Nothing} <$> updatedForest - (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest - where - rel = note ("no relation between " <> tableName table <> " and " <> tableName parentTable) $ - findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable) - addRel :: Query -> Relation -> Query - addRel q r = q{qRelation = Just r} - where - updatedForest = mapM (addRelations allRelations (Just node)) forest + case parentNode of + Nothing -> Node query{qRelation=Nothing} <$> updatedForest + (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest + where + rel = note ("no relation between " <> tableName table <> " and " <> tableName parentTable) $ + findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable) + addRel :: Query -> Relation -> Query + addRel q r = q{qRelation = Just r} + where + updatedForest = mapM (addRelations allRelations (Just node)) forest addJoinConditions :: [Column] -> Tree Query -> Either Text DbRequest addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = - case relation of - Nothing -> Node <$> updatedQuery <*> updatedForest -- this is the root node - Just rel@(Relation{relType="child"}) -> Node <$> (addCond <$> updatedQuery <*> getJoinCondition rel) <*> updatedForest - Just (Relation{relType="parent"}) -> Node <$> updatedQuery <*> updatedForest - -- Just (Many relationColumn1 relationColumn2) -> Node <$> pure updatedQuery{qJoinTables=linkTable:qJoinTables updatedQuery, qWhere=cond1:cond2:qWhere updatedQuery} <*> updatedForest - -- where - -- cond1 = getJoinCondition relationColumn1 - -- cond2 = getJoinCondition relationColumn2 - -- linkTable = Table "public" (colTable relationColumn1) True - _ -> Left "unknow relation" - where - -- add parentTable and parentJoinConditions to the query - updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ qJoinTables query}) <$> parentJoinConditions - where - parentJoinConditions = mapM (getJoinCondition.snd) parents - parentTables = map fst parents - parents = mapMaybe (getParents.rootLabel) forest - getParents qq@(Select{qRelation=(Just rel@(Relation{relType="parent"}))}) = Just (qMainTable qq, rel) - getParents _ = Nothing - updatedForest = mapM (addJoinConditions allColumns) forest - getJoinCondition rel@(Relation s t c _ _ _) = Condition <$> cc <*> pure "=" <*> pure (VForeignKey rel) - where - col = findColumn allColumns s t c - cc = (,) <$> col <*> pure Nothing - addCond q con = q{qWhere=con:qWhere q} + case relation of + Nothing -> Node <$> updatedQuery <*> updatedForest -- this is the root node + Just rel@(Relation{relType="child"}) -> Node <$> (addCond <$> updatedQuery <*> getJoinCondition rel) <*> updatedForest + Just (Relation{relType="parent"}) -> Node <$> updatedQuery <*> updatedForest + -- Just (Many relationColumn1 relationColumn2) -> Node <$> pure updatedQuery{qJoinTables=linkTable:qJoinTables updatedQuery, qWhere=cond1:cond2:qWhere updatedQuery} <*> updatedForest + -- where + -- cond1 = getJoinCondition relationColumn1 + -- cond2 = getJoinCondition relationColumn2 + -- linkTable = Table "public" (colTable relationColumn1) True + _ -> Left "unknow relation" + where + -- add parentTable and parentJoinConditions to the query + updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ qJoinTables query}) <$> parentJoinConditions + where + parentJoinConditions = mapM (getJoinCondition.snd) parents + parentTables = map fst parents + parents = mapMaybe (getParents.rootLabel) forest + getParents qq@(Select{qRelation=(Just rel@(Relation{relType="parent"}))}) = Just (qMainTable qq, rel) + getParents _ = Nothing + updatedForest = mapM (addJoinConditions allColumns) forest + getJoinCondition rel@(Relation s t c _ _ _) = Condition <$> cc <*> pure "=" <*> pure (VForeignKey rel) + where + col = findColumn allColumns s t c + cc = (,) <$> col <*> pure Nothing + addCond q con = q{qWhere=con:qWhere q} dbRequestToCountQuery :: DbRequest -> PStmt dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) = - B.Stmt query V.empty True - where - query = Data.Text.unwords [ - "SELECT pg_catalog.count(1)", - "FROM ", pgFmtTable mainTable, - ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions - ] - emptyOnNull val x = if null x then "" else val + B.Stmt query V.empty True + where + query = Data.Text.unwords [ + "SELECT pg_catalog.count(1)", + "FROM ", pgFmtTable mainTable, + ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + ] + emptyOnNull val x = if null x then "" else val dbRequestToQuery :: DbRequest -> PStmt dbRequestToQuery (Node (Select mainTable colSelects tbls conditions _ ord) forest) = - orderT (fromMaybe [] ord) query - -- case relation of - -- Nothing ->B.Stmt ("SELECT " - -- <> "(" - -- <> dbRequestToCountQuery r - -- <> ")," - -- <> "pg_catalog.count(t)," - -- <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " - -- <> "FROM (" - -- <> query - -- <> ") t;" - -- ) V.empty True - -- - -- _ -> B.Stmt query V.empty True - where + orderT (fromMaybe [] ord) query + -- case relation of + -- Nothing ->B.Stmt ("SELECT " + -- <> "(" + -- <> dbRequestToCountQuery r + -- <> ")," + -- <> "pg_catalog.count(t)," + -- <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " + -- <> "FROM (" + -- <> query + -- <> ") t;" + -- ) V.empty True + -- + -- _ -> B.Stmt query V.empty True + where - query = B.Stmt qStr V.empty True - qStr = Data.Text.unwords [ - ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, - "SELECT ", intercalate ", " (map selectItemToStr colSelects ++ selects), - "FROM ", intercalate ", " (map pgFmtTable (mainTable:tbls)), - ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions - ] - emptyOnNull val x = if null x then "" else val - (withs, selects) = foldr getQueryParts ([],[]) forest - --getQueryParts is not total but dbRequestToQuery is called only after addJoinConditions which ensures the only - --posible relations are Child Parent Many - getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text]) - getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s) - where name = tableName table - sel = "(" - <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " - <> "FROM (" <> subquery <> ") " <> name - <> ") AS " <> name - where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) + query = B.Stmt qStr V.empty True + qStr = Data.Text.unwords [ + ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, + "SELECT ", intercalate ", " (map selectItemToStr colSelects ++ selects), + "FROM ", intercalate ", " (map pgFmtTable (mainTable:tbls)), + ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + ] + emptyOnNull val x = if null x then "" else val + (withs, selects) = foldr getQueryParts ([],[]) forest + --getQueryParts is not total but dbRequestToQuery is called only after addJoinConditions which ensures the only + --posible relations are Child Parent Many + getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text]) + getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s) + where + name = tableName table + sel = "(" + <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " + <> "FROM (" <> subquery <> ") " <> name + <> ") AS " <> name + where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) - getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) - where name = tableName table - sel = "row_to_json(" <> name <> ".*) AS "<>name --TODO must be singular - wit = name <> " AS ( " <> subquery <> " )" - where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) - -- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s) - -- where name = tableName table - -- sel = "(" - -- <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " - -- <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name - -- <> ") AS " <> name - -- the following is just to remove the warning, maybe relType should not be String? - getQueryParts (Node (Select{qRelation=Nothing}) _) _ = undefined - getQueryParts (Node (Select{qRelation=(Just (Relation {relType=_}))}) _) _ = undefined + getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) + where + name = tableName table + sel = "row_to_json(" <> name <> ".*) AS "<>name --TODO must be singular + wit = name <> " AS ( " <> subquery <> " )" + where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) + -- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s) + -- where name = tableName table + -- sel = "(" + -- <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " + -- <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name + -- <> ") AS " <> name + -- the following is just to remove the warning, maybe relType should not be String? + getQueryParts (Node (Select{qRelation=Nothing}) _) _ = undefined + getQueryParts (Node (Select{qRelation=(Just (Relation {relType=_}))}) _) _ = undefined pgFmtCondition :: Condition -> Text pgFmtCondition (Condition (col,jp) ops val) = - notOp <> " " <> pgFmtColumn col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> - if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue - where - headPredicate:rest = split (=='.') $ pack ops - hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse - opCode = hasNot (head rest) headPredicate - notOp = hasNot headPredicate "" - sqlValue = valToStr val - getInner v = case v of - VText s -> s - _ -> "" - valToStr v = case v of - VText s -> pgFmtValue opCode s - VForeignKey (Relation{relFTable=table, relFColumn=column}) -> table <> "." <> column + notOp <> " " <> pgFmtColumn col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> + if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue + where + headPredicate:rest = split (=='.') $ pack ops + hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse + opCode = hasNot (head rest) headPredicate + notOp = hasNot headPredicate "" + sqlValue = valToStr val + getInner v = case v of + VText s -> s + _ -> "" + valToStr v = case v of + VText s -> pgFmtValue opCode s + VForeignKey (Relation{relFTable=table, relFColumn=column}) -> table <> "." <> column pgFmtColumn :: Column -> Text pgFmtColumn Column {colSchema=s, colTable=t, colName=c} = pgFmtIdent s <> "." <> pgFmtIdent t <> "." <> pgFmtIdent c diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 889fb2920..b80b0cba4 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -15,53 +15,53 @@ import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>)) parseGetRequest :: Request -> Either ParseError ApiRequest parseGetRequest httpRequest = - foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts - where - apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr - addOrder (Node r f) o = Node r{order=o} f - flts = mapM pRequestFilter whereFilters - rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head - qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] - orderStr = join $ lookup "order" qString - ord = traverse (parse pOrder ("failed to parse order ("++fromMaybe "" orderStr++")")) orderStr - selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * - whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] + foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts + where + apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr + addOrder (Node r f) o = Node r{order=o} f + flts = mapM pRequestFilter whereFilters + rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head + qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] + orderStr = join $ lookup "order" qString + ord = traverse (parse pOrder ("failed to parse order ("++fromMaybe "" orderStr++")")) orderStr + selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * + whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] pRequestSelect :: String -> Parser ApiRequest pRequestSelect rootNodeName = do - fieldTree <- pFieldForest - return $ foldr treeEntry (Node (RequestNode rootNodeName [] [] Nothing) []) fieldTree - where - treeEntry :: Tree SelectItem -> Tree RequestNode -> Tree RequestNode - treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = - case fldForest of - [] -> Node (rNode {fields=fld:fields rNode}) rForest - _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] [] Nothing) []) fldForest:rForest) + fieldTree <- pFieldForest + return $ foldr treeEntry (Node (RequestNode rootNodeName [] [] Nothing) []) fieldTree + where + treeEntry :: Tree SelectItem -> Tree RequestNode -> Tree RequestNode + treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = + case fldForest of + [] -> Node (rNode {fields=fld:fields rNode}) rForest + _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] [] Nothing) []) fldForest:rForest) pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) - where - treePath = parse pTreePath ("failed to parser tree path ("++k++")") k - opVal = parse pOpValueExp ("failed to parse filter ("++v++")") v - path = fst <$> treePath - fld = snd <$> treePath - op = fst <$> opVal - val = snd <$> opVal + where + treePath = parse pTreePath ("failed to parser tree path ("++k++")") k + opVal = parse pOpValueExp ("failed to parse filter ("++v++")") v + path = fst <$> treePath + fld = snd <$> treePath + op = fst <$> opVal + val = snd <$> opVal addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest addFilter ([], flt) (Node rn@(RequestNode {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest addFilter (path, flt) (Node rn forest) = - case targetNode of - Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path - Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest) - where - targetNodeName:remainingPath = path - (targetNode,restForest) = splitForest targetNodeName forest - splitForest name forst = - case maybeNode of - Nothing -> (Nothing,forest) - Just node -> (Just node, delete node forest) - where maybeNode = find ((name==).nodeName.rootLabel) forst + case targetNode of + Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path + Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest) + where + targetNodeName:remainingPath = path + (targetNode,restForest) = splitForest targetNodeName forest + splitForest name forst = + case maybeNode of + Nothing -> (Nothing,forest) + Just node -> (Just node, delete node forest) + where maybeNode = find ((name==).nodeName.rootLabel) forst ws :: Parser String ws = many (oneOf " \t") @@ -71,9 +71,9 @@ lexeme p = ws *> p <* ws pTreePath :: Parser (Path,Field) pTreePath = do - p <- pFieldName `sepBy1` pDelimiter - jp <- optionMaybe ( string "->" >> pJsonPath) - return (init p, (last p, jp)) + p <- pFieldName `sepBy1` pDelimiter + jp <- optionMaybe ( string "->" >> pJsonPath) + return (init p, (last p, jp)) pFieldForest :: Parser [Tree SelectItem] @@ -81,14 +81,14 @@ pFieldForest = pFieldTree `sepBy1` lexeme (char ',') pFieldTree :: Parser (Tree SelectItem) pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')')) - <|> Node <$> pSelect <*> pure [] + <|> Node <$> pSelect <*> pure [] pStar :: Parser String pStar = string "*" *> pure "*" pFieldName :: Parser String pFieldName = many1 (letter <|> digit <|> oneOf "_") - "field name (* or [a..z0..9_])" + "field name (* or [a..z0..9_])" pJsonPathDelimiter :: Parser String pJsonPathDelimiter = try (string "->>") <|> string "->" @@ -101,34 +101,34 @@ pField = lexeme $ (,) <$> pFieldName <*> optionMaybe ( pJsonPathDelimiter *> pJ pSelect :: Parser SelectItem pSelect = lexeme $ - try ((,) <$> pField <*> optionMaybe (string "::" *> many letter)) - <|> do - s <- pStar - return ((s, Nothing), Nothing) + try ((,) <$> pField <*> optionMaybe (string "::" *> many letter)) + <|> do + s <- pStar + return ((s, Nothing), Nothing) pOperator :: Parser Operator pOperator = try (string "lte") -- has to be before lt - <|> try (string "lt") - <|> try (string "eq") - <|> try (string "gte") -- has to be before gh - <|> try (string "gt") - <|> try (string "lt") - <|> try (string "neq") - <|> try (string "like") - <|> try (string "ilike") - <|> try (string "in") - <|> try (string "notin") - <|> try (string "is" ) - <|> try (string "isnot") - <|> try (string "@@") - "operator (eq, gt, ...)" + <|> try (string "lt") + <|> try (string "eq") + <|> try (string "gte") -- has to be before gh + <|> try (string "gt") + <|> try (string "lt") + <|> try (string "neq") + <|> try (string "like") + <|> try (string "ilike") + <|> try (string "in") + <|> try (string "notin") + <|> try (string "is" ) + <|> try (string "isnot") + <|> try (string "@@") + "operator (eq, gt, ...)" -- pInt :: Parser Int -- pInt = try (liftA read (many1 digit)) "integer" --pValue :: Parser Value --pValue = (VInt <$> try (pInt <* eof)) --- <|>(VString <$> many anyChar) +-- <|>(VString <$> many anyChar) pValue :: Parser FValue pValue = many anyChar