From 9342cc8c8a56ba53b34e916b9a332815d35fe848 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 28 Sep 2015 12:06:49 +0300 Subject: [PATCH] removide duplication from data types (all tests passing) --- src/PostgREST/App.hs | 15 ++-- src/PostgREST/Functions.hs | 144 +++++++++++++++---------------------- src/PostgREST/Parsers.hs | 23 ++++-- src/PostgREST/Types.hs | 26 ++----- 4 files changed, 88 insertions(+), 120 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index d3e414350..afee8f239 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -76,6 +76,7 @@ app dbstructure conf reqBody dbrole req = if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else + -- return $ responseLBS status416 [] $ cs $ show queries case queries of Left e -> return $ responseLBS status200 [("Content-Type", "text/plain")] $ cs e Right (qs, cqs) -> do @@ -114,14 +115,12 @@ app dbstructure conf reqBody dbrole req = where from = fromMaybe 0 $ rangeOffset <$> range - apiRequest = parseGetRequest req - dbRequest = first formatParserError apiRequest - >>= traverse (requestNodeToQuery schema allTables allColumns) - >>= addRelations allRelations Nothing - >>= addJoinConditions allColumns - where formatParserError = pack.show - query = dbRequestToQuery <$> dbRequest - countQuery = dbRequestToCountQuery <$> dbRequest + apiRequest = first formatParserError (parseGetRequest req) + >>= addRelations schema allRelations Nothing + >>= addJoinConditions schema allColumns + where formatParserError = pack.show + query = requestToQuery schema <$> apiRequest + countQuery = requestToCountQuery schema <$> apiRequest queries = (,) <$> query <*> countQuery diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index afa915950..e73a103e2 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -34,53 +34,26 @@ 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 val) - where - c = (,) <$> column <*> pure (snd fld) - column = findColumn allColumns schema table $ fst fld - - -requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query -requestNodeToQuery schema allTables allColumns (RequestNode tblName flds fltrs ord) = - Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel <*> pure ord - where - 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 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) = +addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest +addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) = case parentNode of - Nothing -> Node query{qRelation=Nothing} <$> updatedForest - (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest + Nothing -> Node query{relation=Nothing} <$> updatedForest + (Just (Node (Select{mainTable=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) + rel = note ("no relation between " <> table <> " and " <> parentTable) $ + findRelation allRelations schema table parentTable addRel :: Query -> Relation -> Query - addRel q r = q{qRelation = Just r} + addRel q r = q{relation = Just r} where - updatedForest = mapM (addRelations allRelations (Just node)) forest + updatedForest = mapM (addRelations schema 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 +addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest +addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) = + case r 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 @@ -89,81 +62,77 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = _ -> Left "unknow relation" where -- add parentTable and parentJoinConditions to the query - updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ qJoinTables query}) <$> parentJoinConditions + updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions where - parentJoinConditions = mapM (getJoinCondition.snd) parents + parentJoinConditions = map (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 qq@(Select{relation=(Just rel@(Relation{relType="parent"}))}) = Just (mainTable 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} + updatedForest = mapM (addJoinConditions schema allColumns) forest + getJoinCondition rel@(Relation _ _ c _ _ _) = Filter (c, Nothing) "=" (VForeignKey rel) + addCond q con = q{filters=con:filters q} -dbRequestToCountQuery :: DbRequest -> PStmt -dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) = +requestToCountQuery :: Text -> ApiRequest -> PStmt +requestToCountQuery schema (Node (Select mainTbl _ _ 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 localConditions )) `emptyOnNull` localConditions + "FROM ", fromQi $ QualifiedIdentifier schema mainTbl, + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions ] emptyOnNull val x = if null x then "" else val localConditions = filter fn conditions where - fn (Condition{conValue=VText _}) = True - fn (Condition{conValue=VForeignKey _}) = False + fn (Filter{value=VText _}) = True + fn (Filter{value=VForeignKey _}) = False -dbRequestToQuery :: DbRequest -> PStmt -dbRequestToQuery (Node (Select mainTable colSelects tbls conditions _ ord) forest) = + +-- main field join filters order rela +requestToQuery :: Text -> ApiRequest -> PStmt +requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) = orderT (fromMaybe [] ord) query 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 + "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects), + "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)), + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) 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 + --getQueryParts is not total but requestToQuery 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) + getQueryParts (Node q@(Select{mainTable=table, relation=(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) + <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " + <> "FROM (" <> subquery <> ") " <> table + <> ") AS " <> table + where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) - getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) + getQueryParts (Node q@(Select{mainTable=table, relation=(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) + sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular + wit = table <> " AS ( " <> subquery <> " )" + where (B.Stmt subquery _ _) = requestToQuery schema (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 + -- <> "FROM (" <> requestToQuery (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 (Select{relation=Nothing}) _) _ = undefined + getQueryParts (Node (Select{relation=(Just (Relation {relType=_}))}) _) _ = undefined -pgFmtCondition :: Condition -> Text -pgFmtCondition (Condition (col,jp) ops val) = - notOp <> " " <> pgFmtColumn col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> +pgFmtCondition :: QualifiedIdentifier -> Filter -> Text +pgFmtCondition table (Filter (col,jp) ops val) = + notOp <> " " <> pgFmtColumn table col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue where headPredicate:rest = split (=='.') ops @@ -176,11 +145,12 @@ pgFmtCondition (Condition (col,jp) ops val) = _ -> "" valToStr v = case v of VText s -> pgFmtValue opCode s - VForeignKey (Relation{relFTable=table, relFColumn=column}) -> table <> "." <> column + VForeignKey (Relation{relSchema=s, relFTable=ft, relFColumn=fc}) -> pgFmtColumn (QualifiedIdentifier s ft) fc -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 <> ".*" +pgFmtColumn :: QualifiedIdentifier -> Text -> Text +pgFmtColumn table "*" = fromQi table <> ".*" +pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c +--pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*" pgFmtJsonPath :: Maybe JsonPath -> Text pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x @@ -190,9 +160,9 @@ 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 " <> cast <> " )" <> asJsonPath jp +pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text +pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp +pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp asJsonPath :: Maybe JsonPath -> Text asJsonPath Nothing = "" diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 6ad2e59e5..de88c4a79 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -29,16 +29,27 @@ parseGetRequest 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", "order"], isJust v ] +{-- +data Query = Select { + mainTable::Text +, fields::[SelectItem] +, joinTables::[Text] +, filters::[Filter] +, order::Maybe [OrderTerm] +, relation::Maybe Relation +} deriving (Show) + +--} pRequestSelect :: Text -> Parser ApiRequest pRequestSelect rootNodeName = do fieldTree <- pFieldForest - return $ foldr treeEntry (Node (RequestNode rootNodeName [] [] Nothing) []) fieldTree + return $ foldr treeEntry (Node (Select rootNodeName [] [] [] Nothing Nothing) []) fieldTree where - treeEntry :: Tree SelectItem -> Tree RequestNode -> Tree RequestNode + treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest 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) + _ -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest:rForest) pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) @@ -51,7 +62,7 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) val = snd <$> opVal addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest -addFilter ([], flt) (Node rn@(RequestNode {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest +addFilter ([], flt) (Node rn@(Select {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 @@ -63,7 +74,7 @@ addFilter (path, flt) (Node rn forest) = case maybeNode of Nothing -> (Nothing,forest) Just node -> (Just node, delete node forest) - where maybeNode = find ((name==).nodeName.rootLabel) forst + where maybeNode = find ((name==).mainTable.rootLabel) forst ws :: Parser Text ws = cs <$> many (oneOf " \t") @@ -136,7 +147,7 @@ pOperator = cs <$> ( try (string "lte") -- has to be before lt --pValue = (VInt <$> try (pInt <* eof)) -- <|>(VString <$> many anyChar) pValue :: Parser FValue -pValue = cs <$> many anyChar +pValue = VText <$> (cs <$> many anyChar) pDelimiter :: Parser Char pDelimiter = char '.' "delimiter (.)" diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 901766a58..76304002d 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -22,7 +22,7 @@ data Table = Table { data ForeignKey = ForeignKey { fkTable::Text, fkCol::Text -} deriving (Eq, Show) +} deriving (Show) data Column = Column { @@ -64,36 +64,24 @@ data Relation = Relation { -------- -- Request Types type Operator = Text -type FValue = Text -type ApiRequest = Tree RequestNode +data FValue = VText Text | VForeignKey Relation deriving (Show, Eq) type FieldName = Text type JsonPath = [Text] type Field = (FieldName, Maybe JsonPath) type Cast = Text type SelectItem = (Field, Maybe Cast) type Path = [Text] -data RequestNode = RequestNode { - nodeName::Text +data Query = Select { + mainTable::Text , fields::[SelectItem] +, joinTables::[Text] , filters::[Filter] , order::Maybe [OrderTerm] +, relation::Maybe Relation } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) +type ApiRequest = Tree Query --- 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 -, qOrder::Maybe [OrderTerm] -} deriving (Show) -type DbRequest = Tree Query instance ToJSON Column where toJSON c = object [