jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

data types refactoring

Browse Source
This commit is contained in:
Ruslan Talpa
2015-10-16 15:21:31 +03:00
parent 609f1aabca
commit 1f80b806bd
4 changed files with 51 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+10 -10
View File
@@ -91,9 +91,9 @@ app dbstructure conf authenticator reqBody dbrole req =
)
row <- H.maybeEx q
let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row
to = from+queryTotal-1
contentRange = contentRangeH from to tableTotal
status = rangeStatus from to tableTotal
to = frm+queryTotal-1
contentRange = contentRangeH frm to tableTotal
status = rangeStatus frm to tableTotal
canonical = urlEncodeVars
. sortBy (comparing fst)
. map (join (***) cs)
@@ -108,7 +108,7 @@ app dbstructure conf authenticator reqBody dbrole req =
] (fromMaybe "[]" body)
where
from = fromMaybe 0 $ rangeOffset <$> range
frm = fromMaybe 0 $ rangeOffset <$> range
apiRequest = first formatParserError (parseGetRequest req)
>>= first formatRelationError . addRelations schema allRels Nothing
>>= addJoinConditions schema allCols
@@ -309,22 +309,22 @@ isSqlError = undefined
rangeStatus :: Int -> Int -> Maybe Int -> Status
rangeStatus _ _ Nothing = status200
rangeStatus from to (Just total)
| from > total = status416
| (1 + to - from) < total = status206
rangeStatus frm to (Just total)
| frm > total = status416
| (1 + to - frm) < total = status206
| otherwise = status200
contentRangeH :: Int -> Int -> Maybe Int -> Header
contentRangeH from to total =
contentRangeH frm to total =
("Content-Range", cs headerValue)
where
headerValue = rangeString <> "/" <> totalString
rangeString
| totalNotZero && fromInRange = show from <> "-" <> cs (show to)
| totalNotZero && fromInRange = show frm <> "-" <> cs (show to)
| otherwise = "*"
totalString = fromMaybe "*" (show <$> total)
totalNotZero = fromMaybe True ((/=) 0 <$> total)
fromInRange = from <= to
fromInRange = frm <= to
jsonMT :: BS.ByteString
jsonMT = "application/json"
src/PostgREST/Parsers.hs
+7 -7
View File
@@ -23,7 +23,7 @@ parseGetRequest httpRequest =
foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
where
apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
addOrder (Node r f) o = Node r{order=o} f
addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
flts = mapM pRequestFilter whereFilters
rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
@@ -35,13 +35,13 @@ parseGetRequest httpRequest =
pRequestSelect :: Text -> Parser ApiRequest
pRequestSelect rootNodeName = do
fieldTree <- pFieldForest
return $ foldr treeEntry (Node (Select rootNodeName [] [] [] Nothing Nothing) []) fieldTree
return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree
where
treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest
treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) =
treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) =
case fldForest of
[] -> Node (rNode {fields=fld:fields rNode}) rForest
_ -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest:rForest)
[] -> Node (q {select=fld:select q}, i) rForest
_ -> Node (q, i) (foldr treeEntry (Node (Select [] [fn] [] Nothing, (fn, Nothing)) []) fldForest:rForest)
pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
@@ -54,7 +54,7 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
val = snd <$> opVal
addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
addFilter ([], flt) (Node rn@(Select {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest
addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) 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
@@ -66,7 +66,7 @@ addFilter (path, flt) (Node rn forest) =
case maybeNode of
Nothing -> (Nothing,forest)
Just node -> (Just node, delete node forest)
where maybeNode = find ((name==).mainTable.rootLabel) forst
where maybeNode = find ((name==).fst.snd.rootLabel) forst
ws :: Parser Text
ws = cs <$> many (oneOf " \t")
src/PostgREST/QueryBuilder.hs
+28 -25
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module PostgREST.QueryBuilder
where
@@ -20,17 +21,19 @@ findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation
findRelation allRelations s t1 t2 =
find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations
addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) =
addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =
case parentNode of
Nothing -> Node query{relation=Nothing} <$> updatedForest
(Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest
Nothing -> Node (query, (table, Nothing)) <$> updatedForest
(Just (Node (_, (parentTable, _)) _)) -> Node <$> (addRel n <$> rel) <*> updatedForest
where
rel = note ("no relation between " <> table <> " and " <> parentTable)
$ findRelation allRelations schema table parentTable
<|> findRelation allRelations schema parentTable table
addRel :: Query -> Relation -> Query
addRel q r = q{relation = Just r}
addRel :: (Query, (NodeName, Maybe Relation)) -> Relation -> (Query, (NodeName, Maybe Relation))
addRel (q, (t, _)) r = (q, (t, Just r))
where
updatedForest = mapM (addRelations schema allRelations (Just node)) forest
@@ -45,31 +48,31 @@ getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) =
toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc))
addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest
addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) =
addJoinConditions schema allColumns (Node (query, (t, r)) forest) =
case r of
Nothing -> Node updatedQuery <$> updatedForest -- this is the root node
Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest
Just (Relation{relType=Parent}) -> Node updatedQuery <$> updatedForest
Nothing -> Node (updatedQuery, (t, r)) <$> updatedForest -- this is the root node
Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel),(t,r)) <$> updatedForest
Just (Relation{relType=Parent}) -> Node (updatedQuery, (t,r)) <$> updatedForest
Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) ->
Node <$> pure qq <*> updatedForest
Node (qq, (t, r)) <$> updatedForest
where
q = addCond updatedQuery (getJoinConditions rel)
qq = q{joinTables=linkTable:joinTables q}
qq = q{from=linkTable:from q}
_ -> Left "unknow relation"
where
-- add parentTable and parentJoinConditions to the query
updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions
updatedQuery = foldr (flip addCond) (query{from = parentTables ++ from query}) parentJoinConditions
where
parentJoinConditions = map (getJoinConditions.snd) parents
parentTables = map fst parents
parents = mapMaybe (getParents.rootLabel) forest
getParents qq@(Select{relation=(Just rel@(Relation{relType=Parent}))}) = Just (mainTable qq, rel)
getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel)
getParents _ = Nothing
updatedForest = mapM (addJoinConditions schema allColumns) forest
addCond q con = q{filters=con ++ filters q}
addCond q con = q{where_=con ++ where_ q}
requestToCountQuery :: Text -> ApiRequest -> PStmt
requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) =
requestToCountQuery schema (Node (Select _ _ conditions _, (mainTbl, _)) _) =
B.Stmt query V.empty True
where
query = Data.Text.unwords [
@@ -84,45 +87,45 @@ requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) =
fn (Filter{value=VForeignKey _ _}) = False
requestToQuery :: Text -> ApiRequest -> PStmt
requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) =
requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) 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 (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
"FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)),
"FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) 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 :: Tree Query -> ([Text], [Text]) -> ([Text], [Text])
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s)
getQueryParts :: Tree ApiNode -> ([Text], [Text]) -> ([Text], [Text])
getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
where
sel = "("
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType=Parent}))}) forst) (w,s) = (wit:w,sel:s)
getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)
where
sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
wit = table <> " AS ( " <> subquery <> " )"
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Many}))}) forst) (w,s) = (w,sel:s)
getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
where
sel = "("
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
-- the following is just to remove the warning
--getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
--posible relations are Child Parent Many
getQueryParts (Node (Select{relation=Nothing}) _) _ = undefined
getQueryParts (Node (_,(_,Nothing)) _) _ = undefined
pgFmtCondition :: QualifiedIdentifier -> Filter -> Text
pgFmtCondition table (Filter (col,jp) ops val) =
src/PostgREST/Types.hs
+6 -6
View File
@@ -75,18 +75,18 @@ type FieldName = Text
type JsonPath = [Text]
type Field = (FieldName, Maybe JsonPath)
type Cast = Text
type NodeName = Text
type SelectItem = (Field, Maybe Cast)
type Path = [Text]
data Query = Select {
mainTable::Text
, fields::[SelectItem]
, joinTables::[Text]
, filters::[Filter]
select::[SelectItem]
, from::[Text]
, where_::[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
type ApiNode = (Query, (NodeName, Maybe Relation))
type ApiRequest = Tree ApiNode
instance ToJSON Column where