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