From 1f80b806bdbcc2f8d61abecd294cdb953e3cd4eb Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 16 Oct 2015 15:21:31 +0300 Subject: [PATCH] data types refactoring --- src/PostgREST/App.hs | 20 ++++++------- src/PostgREST/Parsers.hs | 14 ++++----- src/PostgREST/QueryBuilder.hs | 53 ++++++++++++++++++----------------- src/PostgREST/Types.hs | 12 ++++---- 4 files changed, 51 insertions(+), 48 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 297883d71..201a75aa0 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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" diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 235962811..5a59163d2 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -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") diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 346786bcd..96ce5079f 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -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) = diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index fbe36d937..51f219cf4 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -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