From fb92b76a1a0f73b1a41ed883b86b438f06ac7b02 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Wed, 23 Sep 2015 14:31:24 +0300 Subject: [PATCH] integrated skin code gor generating Sql Query (only left to execute it) --- postgrest.cabal | 10 +++ src/PostgREST/App.hs | 20 ++++- src/PostgREST/Functions.hs | 168 +++++++++++++++++++++++++++++++++++++ src/PostgREST/Parsers.hs | 154 ++++++++++++++++++++++++++++++++++ src/PostgREST/PgQuery.hs | 61 ++++++++------ src/PostgREST/Types.hs | 26 +++++- 6 files changed, 410 insertions(+), 29 deletions(-) create mode 100644 src/PostgREST/Functions.hs create mode 100644 src/PostgREST/Parsers.hs diff --git a/postgrest.cabal b/postgrest.cabal index 8aeb74145..dc2ceba5b 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -52,6 +52,8 @@ executable postgrest , mtl , cassava , jwt + , parsec + , errors hs-source-dirs: src library @@ -88,8 +90,12 @@ library , mtl , cassava , jwt + , parsec + , errors Exposed-Modules: PostgREST.App , PostgREST.Types + , PostgREST.Parsers + , PostgREST.Functions , PostgREST.Auth , PostgREST.Config , PostgREST.Error @@ -111,6 +117,8 @@ Test-Suite spec Main-Is: Main.hs Other-Modules: PostgREST.App , PostgREST.Types + , PostgREST.Parsers + , PostgREST.Functions , PostgREST.Auth , PostgREST.Config , PostgREST.Error @@ -150,3 +158,5 @@ Test-Suite spec , process , heredoc , jwt + , parsec + , errors diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 748db75ba..2646b2fca 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -9,7 +9,7 @@ module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept import Control.Monad (join) import Control.Arrow ((***), second) import Control.Applicative - +import Data.Bifunctor (first) import Data.Text hiding (map, find, filter) import Data.Maybe (fromMaybe, mapMaybe, isJust, isNothing) import Text.Regex.TDFA ((=~)) @@ -47,6 +47,8 @@ import PostgREST.Auth import PostgREST.PgQuery import PostgREST.RangeQuery import PostgREST.PgStructure +import PostgREST.Parsers +import PostgREST.Functions import Prelude @@ -66,20 +68,31 @@ app dbstructure conf reqBody role req = ([], _) -> do let body = encode $ filter (filterTableAcl role) $ filter (((cs schema)==).tableSchema) allTables - return $ responseLBS status200 [jsonH, ("Custom", "header")] $ cs body + return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do let qt = Table schema table let cols = filter (filterCol schema table) allColumns let pkey = map pkName $ filter (filterPk schema table) allPrimaryKeys let body = encode (TableOptions cols pkey) - return $ responseLBS status200 [jsonH, allOrigins, ("Custom", "header2")] $ cs body + return $ responseLBS status200 [jsonH, allOrigins] $ cs body ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else do + let apiRequest = parseGetRequest req + dbRequest = first formatParserError apiRequest + >>= traverse (requestNodeToQuery schema allTables allColumns) + >>= addRelations allRelations Nothing + >>= addJoinConditions allColumns + where formatParserError = pack.show + query = dbRequestToQuery <$> dbRequest + body = show query + return $ responseLBS status200 [] $ cs body + + {-- let qt = qualify table from = fromMaybe 0 $ rangeOffset <$> range query = B.Stmt "select " V.empty True <> @@ -110,6 +123,7 @@ app dbstructure conf reqBody role req = if Prelude.null canonical then "" else "?" <> cs canonical ) ] (cs $ fromMaybe "[]" body) + --} (["postgrest", "users"], "POST") -> do let user = decode reqBody :: Maybe AuthUser diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs new file mode 100644 index 000000000..77c7e6661 --- /dev/null +++ b/src/PostgREST/Functions.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +module PostgREST.Functions +where + +import PostgREST.Types +import Control.Error +import Data.List (find) +import Data.Tree +import Data.Text hiding (find, foldr, map, null, last) +import Data.Monoid +import PostgREST.PgQuery (pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, QualifiedIdentifier(..)) + + +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 + +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 + +findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation +findRelation allRelations s t1 t2 = + 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 + + +requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query +requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs) = + Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel + 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 + +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 + + +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} + + +dbRequestToQuery :: DbRequest -> Text +dbRequestToQuery (Node (Select mainTable columns tables conditions relation) forest) = + case relation of + Nothing -> "SELECT " + <> "pg_catalog.count(t)," + <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " + <> "FROM (" + <> query + <> ") t;" + + _ -> query + where + query = Data.Text.unwords [ + ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, + "SELECT ", intercalate ", " (map selectItemToStr columns ++ selects), + "FROM ", intercalate ", " (map pgFmtTable (mainTable:tables)), + ("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 (" <> dbRequestToQuery (Node q forst) <> ") " <> name + <> ") AS " <> name + 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 ( " <> 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) = pgFmtColumn col <> pgFmtJsonPath jp <> opToStr op <> valToStr val + where + op = pack ops + opToStr o = pgFmtOperator o + valToStr v = case v of + VText s -> pgFmtValue op 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 +pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*" + +pgFmtJsonPath :: Maybe JsonPath -> Text +pgFmtJsonPath (Just [x]) = "->>" <> (pgFmtLit $ pack x) +pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit (pack x) <> pgFmtJsonPath ( Just xs ) +pgFmtJsonPath _ = "" + +pgFmtTable :: Table -> Text +pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n + +selectItemToStr :: DbSelectItem -> Text +selectItemToStr ((c, jp), Nothing) = pgFmtColumn c <> pgFmtJsonPath jp <> asJsonPath jp +selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPath jp <> " AS " <> pack cast <> " )" <> asJsonPath jp + +asJsonPath :: Maybe JsonPath -> Text +asJsonPath Nothing = "" +asJsonPath (Just xx) = " AS " <> (pack $ last xx) diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs new file mode 100644 index 000000000..071a6b7fa --- /dev/null +++ b/src/PostgREST/Parsers.hs @@ -0,0 +1,154 @@ +--{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-} +module PostgREST.Parsers +-- ( parseGetRequest +-- , pSelect +-- , pField +-- , pRequestSelect +-- ) + +where +import Text.ParserCombinators.Parsec hiding (many, (<|>)) +--import Text.Parsec.Text +--import Text.Parsec hiding (many, (<|>)) +--import Text.Parsec.Prim hiding (many, (<|>)) +import Control.Applicative +--import Control.Monad +--import qualified Data.Text as T +import Data.Tree +import Network.Wai (Request, pathInfo, queryString) +import PostgREST.Types +--import qualified Data.ByteString.Char8 as C +--import Control.Monad +--import Data.Foldable (foldrM) +import Data.List (delete, find) +import Data.Maybe +import Data.String.Conversions (cs) +--import qualified Data.ByteString.Char8 as C + +--buildRequest :: String -> String -> [(String, String)] -> Either P.ParseError Request +parseGetRequest :: Request -> Either ParseError ApiRequest +parseGetRequest httpRequest = + foldr addFilter <$> apiRequest <*> flts + where + apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr + flts = mapM pRequestFilter whereFilters + rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head + qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] + 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"], isJust v ] + +pRequestSelect :: String -> Parser ApiRequest +pRequestSelect rootNodeName = do + fieldTree <- pFieldForest + return $ foldr treeEntry (Node (RequestNode rootNodeName [] []) []) 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 [] []) []) 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 + +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 + +ws :: Parser String +ws = many (oneOf " \t") + +--lexeme :: Parser String -> Parser String +--lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a +--lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char +lexeme p = ws *> p <* ws + +pTreePath :: Parser (Path,Field) +pTreePath = do + p <- (pFieldName `sepBy1` pDelimiter) + --f <- pField + jp <- optionMaybe ( string "->" >> pJsonPath) + return (init p, (last p, jp)) + + +pFieldForest :: Parser [Tree SelectItem] +pFieldForest = pFieldTree `sepBy1` lexeme (char ',') + +pFieldTree :: Parser (Tree SelectItem) +pFieldTree = + try ( do + fld <- pSelect + char '(' + subforest <- pFieldForest + char ')' + return (Node fld subforest) + ) + <|> do + fld <- pSelect + return (Node fld []) + +pStar :: Parser String +pStar = string "*" *> pure "*" + +pFieldName :: Parser String +pFieldName = many1 (letter <|> digit <|> oneOf "_") + "field name (* or [a..z0..9_])" + +pJsonPath :: Parser [String] +pJsonPath = pFieldName `sepBy1` (try (string "->>") <|> string "->") + +pField :: Parser Field +pField = lexeme $ do + f <- pFieldName + jp <- optionMaybe ( (try (string "->>") <|> string "->") >> pJsonPath) + return (f, jp) + +pSelect :: Parser SelectItem +pSelect = lexeme $ + try (do + n <- pField + v <- optionMaybe (string "::" >> many letter) + return (n, v) + ) + <|> do + s <- pStar + return ((s, Nothing), Nothing) + +pOperator :: Parser Operator +pOperator = try (string "eq") + <|> try (string "gt") + <|> try (string "lt") + "operator (eq, gt, ...)" + +pInt :: Parser Int +pInt = try (liftA read (many1 digit)) "integer" + +--pValue :: Parser Value +--pValue = (VInt <$> try (pInt <* eof)) +-- <|>(VString <$> many anyChar) +pValue :: Parser FValue +pValue = many anyChar + +pDelimiter :: Parser Char +pDelimiter = char '.' "delimiter (.)" + +pOpValueExp :: Parser (Operator, FValue) +pOpValueExp = liftA2 (,) pOperator (pDelimiter *> pValue) diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index 9e6c8f25b..9e7955780 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -222,35 +222,46 @@ wherePred table (col, predicate) = opCode = hasNot (head rest) headPredicate notOp = hasNot headPredicate "" value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest) - whiteList val = fromMaybe - (cs (pgFmtLit val) <> "::unknown ") - (L.find ((==) . T.toLower $ val) ["null","true","false"]) + sqlValue = pgFmtValue opCode value + op = pgFmtOperator opCode + + +whiteList :: T.Text -> T.Text +whiteList val = fromMaybe + (cs (pgFmtLit val) <> "::unknown ") + (L.find ((==) . T.toLower $ val) ["null","true","false"]) + +pgFmtValue :: T.Text -> T.Text -> T.Text +pgFmtValue opCode value = + case opCode of + "like" -> unknownLiteral $ T.map star value + "ilike" -> unknownLiteral $ T.map star value + "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " + "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " + "@@" -> "to_tsquery(" <> unknownLiteral value <> ") " + _ -> unknownLiteral value + where star c = if c == '*' then '%' else c unknownLiteral = (<> "::unknown ") . pgFmtLit - sqlValue = case opCode of - "like" -> unknownLiteral $ T.map star value - "ilike" -> unknownLiteral $ T.map star value - "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " - "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " - "@@" -> "to_tsquery(" <> unknownLiteral value <> ") " - _ -> unknownLiteral value +pgFmtOperator :: T.Text -> T.Text +pgFmtOperator opCode = + case opCode of + "eq" -> "=" + "gt" -> ">" + "lt" -> "<" + "gte" -> ">=" + "lte" -> "<=" + "neq" -> "<>" + "like"-> "like" + "ilike"-> "ilike" + "in" -> "in" + "notin" -> "not in" + "is" -> "is" + "isnot" -> "is not" + "@@" -> "@@" + _ -> "=" - op = case opCode of - "eq" -> "=" - "gt" -> ">" - "lt" -> "<" - "gte" -> ">=" - "lte" -> "<=" - "neq" -> "<>" - "like"-> "like" - "ilike"-> "ilike" - "in" -> "in" - "notin" -> "not in" - "is" -> "is" - "isnot" -> "is not" - "@@" -> "@@" - _ -> "=" orderParse :: Net.Query -> [OrderTerm] orderParse q = diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index d9cf4e55d..2568e3439 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -1,5 +1,6 @@ module PostgREST.Types where import Data.Text +import Data.Tree data DbStructure = DbStructure { tables :: [Table] @@ -34,7 +35,7 @@ data Column = Column { , colDefault :: Maybe Text , colEnum :: [Text] , colFK :: Maybe ForeignKey -} deriving (Show) +} | Star {colSchema :: Text, colTable :: Text } deriving (Show) data PrimaryKey = PrimaryKey { pkSchema::Text, pkTable::Text, pkName::Text @@ -48,3 +49,26 @@ data Relation = Relation { , relFColumn :: Text , relType :: Text } deriving (Show, Eq) + + +-------- +-- Request Types +type Operator = String +type FValue = String +type ApiRequest = Tree RequestNode +type FieldName = String +type JsonPath = [String] +type Field = (FieldName, Maybe JsonPath) +type Cast = String +type SelectItem = (Field, Maybe Cast) +type Path = [String] +data RequestNode = RequestNode {nodeName::String, fields::[SelectItem], filters::[Filter]} deriving (Show, Eq) +data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) + +-- Db Request Types +type DbField = (Column, Maybe JsonPath) +type DbSelectItem = (DbField, Maybe Cast) +data DbValue = VText Text | VForeignKey Relation deriving (Show) +data Condition = Condition {conColumn::DbField, conOperator::Operator, conValue::DbValue} deriving (Show) +data Query = Select {qMainTable::Table, qSelect::[DbSelectItem], qJoinTables::[Table], qWhere::[Condition], qRelation::Maybe Relation} deriving (Show) +type DbRequest = Tree Query