data types refactoring

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
+                to = frm+queryTotal-1
-                contentRange = contentRangeH from to tableTotal
+                contentRange = contentRangeH frm to tableTotal
-                status = rangeStatus from 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)
+rangeStatus frm to (Just total)
-  | from > total            = status416
+  | frm > total            = status416
-  | (1 + to - from) < total = status206
+  | (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

@@ -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 (q {select=fld:select q}, i) rForest
-        _  -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest: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

@@ -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
+    Nothing -> Node (query, (table, Nothing)) <$> updatedForest
-    (Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> 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 :: (Query, (NodeName, Maybe Relation)) -> Relation -> (Query, (NodeName, Maybe Relation))
-        addRel q r = q{relation = Just r}
+        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
+    Nothing -> Node (updatedQuery, (t, r))  <$> updatedForest -- this is the root node
-    Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest
+    Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel),(t,r)) <$> updatedForest
-    Just (Relation{relType=Parent}) -> Node updatedQuery <$> 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 :: Tree ApiNode -> ([Text], [Text]) -> ([Text], [Text])
-    getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s)
+    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

@@ -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
+  select::[SelectItem]
-, fields::[SelectItem]
+, from::[Text]
-, joinTables::[Text]
+, where_::[Filter]
-, 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
+type ApiNode = (Query, (NodeName, Maybe Relation))
+type ApiRequest = Tree ApiNode
 
 
 instance ToJSON Column where