removide duplication from data types (all tests passing)

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
+            apiRequest = first formatParserError (parseGetRequest req)
-            dbRequest = first formatParserError apiRequest
+                     >>= addRelations schema allRelations Nothing
-                >>= traverse (requestNodeToQuery schema allTables allColumns)
+                     >>= addJoinConditions schema allColumns
-                >>= addRelations allRelations Nothing
-                >>= addJoinConditions allColumns
                      where formatParserError = pack.show
-            query = dbRequestToQuery <$> dbRequest
+            query = requestToQuery schema <$> apiRequest
-            countQuery = dbRequestToCountQuery <$> dbRequest
+            countQuery = requestToCountQuery schema <$> apiRequest
             queries = (,) <$> query <*> countQuery
 
 

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
+addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
-filterToCondition schema allColumns table (Filter fld op val) =
+addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) =
-  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) =
   case parentNode of
-    Nothing -> Node query{qRelation=Nothing} <$> updatedForest
+    Nothing -> Node query{relation=Nothing} <$> updatedForest
-    (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest
+    (Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest
       where
-        rel = note ("no relation between " <> tableName table <> " and " <> tableName parentTable) $
+        rel = note ("no relation between " <> table <> " and " <> parentTable) $
-          findRelation allRelations (tableSchema table) (tableName table) (tableName 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 :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest
-addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) =
+addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) =
-  case relation of
+  case r 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
       -- 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
+    updatedForest = mapM (addJoinConditions schema allColumns) forest
-    getJoinCondition rel@(Relation s t c _ _ _) = Condition <$> cc <*> pure "=" <*> pure (VForeignKey rel)
+    getJoinCondition rel@(Relation _ _ c _ _ _) = Filter (c, Nothing) "=" (VForeignKey rel)
-      where
+    addCond q con = q{filters=con:filters q}
-        col = findColumn allColumns s t c
-        cc = (,) <$> col <*> pure Nothing
-    addCond q con = q{qWhere=con:qWhere q}
 
 
-dbRequestToCountQuery :: DbRequest -> PStmt
+requestToCountQuery :: Text -> ApiRequest -> PStmt
-dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) =
+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,
+      "FROM ", fromQi $ QualifiedIdentifier schema mainTbl,
-      ("WHERE " <> intercalate " AND " ( map pgFmtCondition localConditions )) `emptyOnNull` localConditions
+      ("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  (Filter{value=VText _}) = True
-        fn  (Condition{conValue=VForeignKey _}) = False
+        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),
+      "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
-      "FROM ", intercalate ", " (map pgFmtTable (mainTable:tbls)),
+      "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)),
-      ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions
+      ("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<>"))) "
+           <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
-           <> "FROM (" <> subquery <> ") " <> name
+           <> "FROM (" <> subquery <> ") " <> table
-           <> ") AS " <> name
+           <> ") AS " <> table
-           where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst)
+           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(" <> table <> ".*) AS "<>table --TODO must be singular
-        sel = "row_to_json(" <> name <> ".*) AS "<>name --TODO must be singular
+        wit = table <> " AS ( " <> subquery <> " )"
-        wit = name <> " AS ( " <> subquery <> " )"
+          where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
-          where (B.Stmt subquery _ _) = dbRequestToQuery (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{relation=Nothing}) _) _ = undefined
-    getQueryParts (Node (Select{qRelation=(Just (Relation {relType=_}))}) _) _ = undefined
+    getQueryParts (Node (Select{relation=(Just (Relation {relType=_}))}) _) _ = undefined
 
-pgFmtCondition :: Condition -> Text
+pgFmtCondition :: QualifiedIdentifier -> Filter -> Text
-pgFmtCondition (Condition (col,jp) ops val) =
+pgFmtCondition table (Filter (col,jp) ops val) =
-  notOp <> " " <> pgFmtColumn col <> pgFmtJsonPath jp  <> " " <> pgFmtOperator opCode <> " " <>
+  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 :: QualifiedIdentifier -> Text -> Text
-pgFmtColumn Column {colSchema=s, colTable=t, colName=c} = pgFmtIdent s <> "." <> pgFmtIdent t <> "." <> pgFmtIdent c
+pgFmtColumn table "*" = fromQi table <> ".*"
-pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*"
+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
+pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text
-selectItemToStr ((c, jp), Nothing) = pgFmtColumn c <> pgFmtJsonPath jp <> asJsonPath jp
+pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp
-selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp
+pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp
 
 asJsonPath :: Maybe JsonPath -> Text
 asJsonPath Nothing = ""

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 (.)"

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
+data FValue = VText Text | VForeignKey Relation deriving (Show, Eq)
-type ApiRequest = Tree RequestNode
 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 {
+data Query = Select {
-  nodeName::Text
+  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 [