Refactor QueryBuilder and DbRequestBuilder

- Refactor ORDER BY and LIMIT query fragments
- Move ReadRequest building to DbRequestBuilder
- Clarify Relation link table attributes
- Change Join Operation to JoinCond

src/PostgREST/DbRequestBuilder.hs

@@ -31,7 +31,7 @@ import           PostgREST.ApiRequest   ( ApiRequest(..)
                                         )
 import           PostgREST.Error           (apiRequestError)
 import           PostgREST.Parsers
-import           PostgREST.RangeQuery      (NonnegRange, restrictRange)
+import           PostgREST.RangeQuery      (NonnegRange, restrictRange, allRange)
 import           PostgREST.Types
 
 import           Protolude                hiding (from, dropWhile, drop)
@@ -43,8 +43,10 @@ readRequest maxRows allRels proc apiRequest  =
   mapLeft apiRequestError $
   treeRestrictRange maxRows =<<
   augumentRequestWithJoin schema relations =<<
-  parseReadRequest
+  addFiltersOrdersRanges apiRequest <*>
+  (buildReadRequest <$> pRequestSelect (iSelect apiRequest))
   where
+    action = iAction apiRequest
     (schema, rootTableName) = fromJust $ -- Make it safe
       let target = iTarget apiRequest in
       case target of
@@ -58,17 +60,17 @@ readRequest maxRows allRels proc apiRequest  =
 
         _ -> Nothing
 
-    action :: Action
+    buildReadRequest :: [Tree SelectItem] -> ReadRequest
-    action = iAction apiRequest
+    buildReadRequest fieldTree =
-
+      let rootNodeName = if action == ActionRead then rootTableName else sourceCTEName in
-    parseReadRequest :: Either ApiRequestError ReadRequest
+      foldr treeEntry (Node (Select [] [rootNodeName] [] [] [] allRange, (rootNodeName, Nothing, Nothing, Nothing)) []) fieldTree
-    parseReadRequest = addFiltersOrdersRanges apiRequest <*>
-      pRequestSelect rootName selStr
       where
-        selStr = iSelect apiRequest
+        treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
-        rootName = if action == ActionRead
+        treeEntry (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) =
-          then rootTableName
+          case fldForest of
-          else sourceCTEName
+            [] -> Node (q {select=fld:select q}, i) rForest
+            _  -> Node (q, i) $
+                  foldr treeEntry (Node (Select [] [fn] [] [] [] allRange, (fn, Nothing, alias, relationDetail)) []) fldForest:rForest
 
     relations :: [Relation]
     relations = case action of
@@ -77,7 +79,19 @@ readRequest maxRows allRels proc apiRequest  =
       ActionDelete   -> fakeSourceRelations ++ allRels
       ActionInvoke _ -> fakeSourceRelations ++ allRels
       _       -> allRels
-      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
+      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels
+
+-- in a relation where one of the tables matches "TableName"
+-- replace the name to that table with pg_source
+-- this "fake" relations is needed so that in a mutate query
+-- we can look a the "returning *" part which is wrapped with a "with"
+-- as just another table that has relations with other tables
+toSourceRelation :: TableName -> Relation -> Maybe Relation
+toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
+  | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}
+  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}
+  | Just mt == (tableName <$> rt) = Just $ r {relLinkTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}
+  | otherwise = Nothing
 
 treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest
 treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request
@@ -88,7 +102,7 @@ treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` re
 augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either ApiRequestError ReadRequest
 augumentRequestWithJoin schema allRels request =
   addRelations schema allRels Nothing request
-  >>= addJoinFilters schema
+  >>= addJoinConditions schema
 
 addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
 addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias, relationDetail)) forest) =
@@ -171,7 +185,7 @@ addRelations schema allRelations parentNode (Node readNode@(query, (name, _, ali
                       relType r == Many &&
                       nodeTableName == tableName (relTable r) && -- match relation table name
                       parentNodeTableName == tableName (relFTable r) && -- match relation foreign table name
-                      rd == tableName (fromJust (relLTable r))
+                      rd == tableName (fromJust (relLinkTable r))
                     ) 
                   )
                 ) allRelations
@@ -189,35 +203,35 @@ addRelations schema allRelations parentNode (Node readNode@(query, (name, _, ali
     updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
     updateForest n = mapM (addRelations schema allRelations n) forest
 
-addJoinFilters :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest
+addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest
-addJoinFilters schema (Node node@(query, nodeProps@(_, relation, _, _)) forest) =
+addJoinConditions schema (Node node@(query, nodeProps@(_, relation, _, _)) forest) =
   case relation of
     Just Relation{relType=Root} -> Node node  <$> updatedForest -- this is the root node
     Just rel@Relation{relType=Parent} -> Node (augmentQuery rel, nodeProps) <$> updatedForest
     Just rel@Relation{relType=Child} -> Node (augmentQuery rel, nodeProps) <$> updatedForest
-    Just rel@Relation{relType=Many, relLTable=(Just linkTable)} ->
+    Just rel@Relation{relType=Many, relLinkTable=(Just linkTable)} ->
       let rq = augmentQuery rel in
       Node (rq{from=tableName linkTable:from rq}, nodeProps) <$> updatedForest
     _ -> Left UnknownRelation
   where
-    updatedForest = mapM (addJoinFilters schema) forest
+    updatedForest = mapM (addJoinConditions schema) forest
-    augmentQuery rel = foldr addFilterToReadQuery query (getJoinFilters rel)
+    augmentQuery rel = foldr addJoinCondToReadQuery query (getJoinConds rel)
-    addFilterToReadQuery flt rq@Select{where_=lf} = rq{where_=addFilterToLogicForest flt lf}::ReadQuery
+    addJoinCondToReadQuery jc rq@Select{joinConds=jcs} = rq{joinConds=jc:jcs}::ReadQuery
 
-getJoinFilters :: Relation -> [Filter]
+getJoinConds :: Relation -> [JoinCond]
-getJoinFilters (Relation t cols ft fcs typ lt lc1 lc2) =
+getJoinConds (Relation t cols ft fcs typ lt lc1 lc2) =
   case typ of
-    Child  -> zipWith (toFilter tN ftN) cols fcs
+    Child  -> zipWith (toJoinCond tN ftN) cols fcs
-    Parent -> zipWith (toFilter tN ftN) cols fcs
+    Parent -> zipWith (toJoinCond tN ftN) cols fcs
-    Many   -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2)
+    Many   -> zipWith (toJoinCond tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toJoinCond ftN ltN) fcs (fromMaybe [] lc2)
-    Root   -> undefined --error "undefined getJoinFilters"
+    Root   -> undefined
   where
     s = if typ == Parent then "" else tableSchema t
     tN = tableName t
     ftN = tableName ft
     ltN = fromMaybe "" (tableName <$> lt)
-    toFilter :: Text -> Text -> Column -> Column -> Filter
+    toJoinCond :: Text -> Text -> Column -> Column -> JoinCond
-    toFilter tb ftb c fc = Filter (colName c, Nothing) (OpExpr False (Join (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})))
+    toJoinCond tb ftb c fc = JoinCond (QualifiedIdentifier s tb, colName c) (QualifiedIdentifier s ftb, colName fc)
 
 addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest)
 addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
@@ -254,7 +268,7 @@ addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest
 addFilter = addProperty addFilterToNode
 
 addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest
-addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f
+addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f
 
 addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest
 addOrder = addProperty addOrderToNode
@@ -292,18 +306,6 @@ addProperty f (path, a) (Node rn forest) =
             fnd :: ReadRequest -> Bool
             fnd (Node (_,(n,_,_,_)) _) = n == name
 
--- in a relation where one of the tables mathces "TableName"
--- replace the name to that table with pg_source
--- this "fake" relations is needed so that in a mutate query
--- we can look a the "returning *" part which is wrapped with a "with"
--- as just another table that has relations with other tables
-toSourceRelation :: TableName -> Relation -> Maybe Relation
-toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
-  | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}
-  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}
-  | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}
-  | otherwise = Nothing
-
 mutateRequest :: ApiRequest -> TableName -> [Text] -> [FieldName] -> Either Response MutateRequest
 mutateRequest apiRequest tName pkCols fldNames = mapLeft apiRequestError $
   case action of

src/PostgREST/Parsers.hs

@@ -8,14 +8,14 @@ import           Data.Text                     (intercalate, replace, strip)
 import           Data.List                     (init, last)
 import           Data.Tree
 import           Data.Either.Combinators       (mapLeft)
-import           PostgREST.RangeQuery          (NonnegRange,allRange)
+import           PostgREST.RangeQuery          (NonnegRange)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
 import           Text.Parsec.Error
 
-pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest
+pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]
-pRequestSelect rootName selStr =
+pRequestSelect selStr =
-  mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
+  mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
 
 pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter)
 pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)
@@ -53,21 +53,6 @@ ws = toS <$> many (oneOf " \t")
 lexeme :: Parser a -> Parser a
 lexeme p = ws *> p <* ws
 
-pReadRequest :: Text -> Parser ReadRequest
-pReadRequest rootNodeName = do
-  fieldTree <- pFieldForest
-  return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing, Nothing)) []) fieldTree
-  where
-    readQuery = Select [] [rootNodeName] [] Nothing allRange
-    treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
-    treeEntry (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) =
-      case fldForest of
-        [] -> Node (q {select=fld:select q}, i) rForest
-        _  -> Node (q, i) newForest
-          where
-            newForest =
-              foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias, relationDetail)) []) fldForest:rForest
-
 pTreePath :: Parser (EmbedPath, Field)
 pTreePath = do
   p <- pFieldName `sepBy1` pDelimiter
@@ -76,16 +61,15 @@ pTreePath = do
 
 pFieldForest :: Parser [Tree SelectItem]
 pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
-
+  where
-pFieldTree :: Parser (Tree SelectItem)
+    pFieldTree :: Parser (Tree SelectItem)
-pFieldTree =  try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest) -- TODO: "{}" deprecated
+    pFieldTree =  try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest) -- TODO: "{}" deprecated
-          <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest)
+              <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest)
-          <|> Node <$> pFieldSelect <*> pure []
+              <|> Node <$> pFieldSelect <*> pure []
 
 pStar :: Parser Text
 pStar = toS <$> (string "*" *> pure ("*"::ByteString))
 
-
 pFieldName :: Parser Text
 pFieldName = do
   matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])"

src/PostgREST/QueryBuilder.hs

@@ -30,7 +30,7 @@ import qualified Hasql.Decoders          as HD
 import qualified Data.Aeson              as JSON
 
 import           PostgREST.Config        (pgVersion96)
-import           PostgREST.RangeQuery    (NonnegRange, rangeLimit, rangeOffset, allRange)
+import           PostgREST.RangeQuery    (rangeLimit, rangeOffset, allRange)
 import qualified Data.HashMap.Strict     as HM
 import           Data.Maybe
 import qualified Data.Set                as S
@@ -206,47 +206,31 @@ pgFmtLit x =
 
 requestToCountQuery :: Schema -> DbRequest -> SqlQuery
 requestToCountQuery _ (DbMutate _) = undefined
-requestToCountQuery schema (DbRead (Node (Select _ _ logicForest _ _, (mainTbl, _, _, _)) _)) =
+requestToCountQuery schema (DbRead (Node (Select _ _ logicForest _ _ _, (mainTbl, _, _, _)) _)) =
  unwords [
    "SELECT pg_catalog.count(*)",
    "FROM ", fromQi qi,
-    ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) filteredLogic)) `emptyOnFalse` null filteredLogic
+    ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest
    ]
  where
    qi = removeSourceCTESchema schema mainTbl
-   -- all foreing key filters are root nodes(see addFilterToLogicForest), only those are filtered
-   nonFKRoot :: LogicTree -> Bool
-   nonFKRoot (Stmnt (Filter _ (OpExpr _ (Join _ _)))) = False
-   nonFKRoot (Stmnt _) = True
-   nonFKRoot Expr{} = True
-   filteredLogic = filter nonFKRoot logicForest
 
 requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery
-requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest ord range, (nodeName, maybeRelation, _, _)) forest)) =
+requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest joinConds_ ordts range, (nodeName, maybeRelation, _, _)) forest)) =
   query
   where
     mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation)
     qi = removeSourceCTESchema schema mainTbl
     toQi = removeSourceCTESchema schema
     query = unwords [
-      "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
+      "SELECT " <> intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
-      "FROM ", intercalate ", " (map (fromQi . toQi) tbls),
+      "FROM " <> intercalate ", " (map (fromQi . toQi) tbls),
       unwords joins,
-      ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,
+      ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCond joinConds_))
-      orderF (fromMaybe [] ord),
+        `emptyOnFalse` (null logicForest && null joinConds_),
-      if isParent then "" else limitF range
+      ("ORDER BY " <> intercalate ", " (map (pgFmtOrderTerm qi) ordts)) `emptyOnFalse` null ordts,
-      ]
+      ("LIMIT " <> maybe "ALL" show (rangeLimit range) <> " OFFSET " <> show (rangeOffset range)) `emptyOnFalse` (isParent || range == allRange) ]
-    orderF ts =
+
-        if null ts
-            then ""
-            else "ORDER BY " <> clause
-        where
-            clause = intercalate "," (map queryTerm ts)
-            queryTerm :: OrderTerm -> Text
-            queryTerm t = " "
-                <> toS (pgFmtField qi $ otTerm t) <> " "
-                <> maybe "" show (otDirection t) <> " "
-                <> maybe "" show (otNullOrder t) <> " "
     (joins, selects) = foldr getQueryParts ([],[]) forest
 
     getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
@@ -376,14 +360,6 @@ locationF pKeys = [qc|(
   {("WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')") `emptyOnFalse` null pKeys}
 )|]
 
-limitF :: NonnegRange -> SqlFragment
-limitF r  = if r == allRange
-  then ""
-  else "LIMIT " <> limit <> " OFFSET " <> offset
-  where
-    limit  = maybe "ALL" show $ rangeLimit r
-    offset = show $ rangeOffset r
-
 fromQi :: QualifiedIdentifier -> SqlFragment
 fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
   where
@@ -407,6 +383,12 @@ pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment
 pgFmtSelectItem table (f@(_, jp), Nothing, alias, _) = pgFmtField table f <> pgFmtAs jp alias
 pgFmtSelectItem table (f@(_, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs jp alias
 
+pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SqlFragment
+pgFmtOrderTerm qi ot = unwords [
+  toS . pgFmtField qi $ otTerm ot,
+  maybe "" show $ otDirection ot,
+  maybe "" show $ otNullOrder ot]
+
 pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment
 pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of
    Op op val  -> pgFmtFieldOp op <> " " <> case op of
@@ -428,9 +410,6 @@ pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper
        <> maybe "" ((<> ", ") . pgFmtLit) lang
        <> unknownLiteral val
        <> ") "
-
-   Join fQi (ForeignKey Column{colTable=Table{tableName=fTableName}, colName=fColName}) ->
-     pgFmtField fQi fld <> " = " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) fTableName) fColName
  where
    pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
    sqlOperator o = HM.lookupDefault "=" o operators
@@ -442,6 +421,10 @@ pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper
      (toS (pgFmtLit v) <> "::unknown ")
      (find ((==) . toLower $ v) ["null","true","false"])
 
+pgFmtJoinCond :: JoinCond -> SqlFragment
+pgFmtJoinCond (JoinCond (qi, cName) (fQi, fcName)) =
+  pgFmtColumn (removeSourceCTESchema (qiSchema qi) (qiName qi)) cName <> " = " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) (qiName fQi)) fcName
+
 pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment
 pgFmtLogicTree qi (Expr hasNot op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")"
   where notOp =  if hasNot then "NOT" else ""

src/PostgREST/Types.hs

@@ -149,9 +149,10 @@ data Relation = Relation {
 , relFTable   :: Table
 , relFColumns :: [Column]
 , relType     :: RelationType
-, relLTable   :: Maybe Table
+-- The Link attrs are used when RelationType == Many
-, relLCols1   :: Maybe [Column]
+, relLinkTable   :: Maybe Table
-, relLCols2   :: Maybe [Column]
+, relLinkCols1   :: Maybe [Column]
+, relLinkCols2   :: Maybe [Column]
 } deriving (Show, Eq)
 
 -- | Cached attributes of a JSON payload
@@ -215,8 +216,7 @@ ftsOperators = M.fromList [
 data OpExpr = OpExpr Bool Operation deriving (Eq, Show)
 data Operation = Op Operator SingleVal |
                  In ListVal |
-                 Fts Operator (Maybe Language) SingleVal |
+                 Fts Operator (Maybe Language) SingleVal deriving (Eq, Show)
-                 Join QualifiedIdentifier ForeignKey deriving (Eq, Show)
 type Language = Text
 
 -- | Represents a single value in a filter, e.g. id=eq.singleval
@@ -274,8 +274,9 @@ type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe RelationDetail)
 -- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"]
 type EmbedPath = [Text]
 data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq)
+data JoinCond = JoinCond (QualifiedIdentifier, FieldName) (QualifiedIdentifier, FieldName) deriving (Show, Eq)
 
-data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
+data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], joinConds::[JoinCond], order::[OrderTerm], range_::NonnegRange } deriving (Show, Eq)
 data MutateQuery = Insert { in_::TableName, insPkCols::[Text], qPayload::PayloadJSON, onConflict:: Maybe PreferResolution, where_::[LogicTree], returning::[FieldName] }
                  | Delete { in_::TableName, where_::[LogicTree], returning::[FieldName] }
                  | Update { in_::TableName, qPayload::PayloadJSON, where_::[LogicTree], returning::[FieldName] } deriving (Show, Eq)