using query fragments instead of query transformers o generate queries

src/PostgREST/App.hs

@@ -88,17 +88,32 @@ app dbstructure conf authenticator reqBody dbrole req =
         case queries of
           Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
           Right (qs, cqs) -> do
-            let qt = qualify table
+            -- let qt = qualify table
-                count = if hasPrefer "count=none"
+            --     count = if hasPrefer "count=none"
-                      then countNone
+            --           then countNone
-                      else cqs
+            --           else cqs
-                q = B.Stmt "select " V.empty True <>
+            --     q = B.Stmt "select " V.empty True <>
-                    parentheticT count
+            --         parentheticT count
-                    <> commaq <> (
+            --         <> commaq <> (
-                    bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables
+            --         bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables
-                    . limitT range
+            --         . limitT range
-                    $ qs
+            --         $ qs
-                  )
+            --       )
+
+            let q = B.Stmt
+                    (withSourceF qs <>
+                    " SELECT " <>
+                      (if hasPrefer "count=none" then countNoneF else countAllF) <>
+                      "," <>
+                      countF <>
+                      "," <>
+                      (case contentType of
+                        "text/csv" -> asCsvF
+                        _     -> asJsonF
+                      ) <>
+                    " " <>
+                    fromF ( limitF range ))
+                    V.empty True
             row <- H.maybeEx q
             let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row
                 to = frm+queryTotal-1
@@ -163,15 +178,37 @@ app dbstructure conf authenticator reqBody dbrole req =
                   encode . object $ [("message", String "Failed authentication.")]
 
     ([table], "POST") -> do
-      let echoRequested = hasPrefer "return=representation"
+      let echoRequested = hasPrefer "return=representation" --TODO!! do not request content at all in query if not echoRequested
-      case query of
+      case insertQuery of
         Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
         Right q -> do
-          row <- H.maybeEx q
+          let isSingle = either (const False) id returnSingle
-          let (queryTotal, body) = fromMaybe (Just (0::Int), Just "" :: Maybe BL.ByteString) row
+              pKeys = map pkName $ filter (filterPk schema table) allPrKeys
+              qq = B.Stmt
+                   (withSourceF q <>
+                   " SELECT " <>
+                     (if isSingle then (locationF pKeys) else "null") <>
+                     "," <>
+                     countF <>
+                     "," <>
+                     (case contentType of
+                        "text/csv" -> asCsvF
+                        _     -> (if isSingle then asJsonSingleF else asJsonF)
+                     ) <>
+                   " " <>
+                   fromF ( limitF Nothing ))
+                   V.empty True
+
+          row <- H.maybeEx qq
+          let (locationRaw, queryTotal, bodyRaw) = fromMaybe (Just "" :: Maybe BL.ByteString, Just (0::Int), Just "" :: Maybe BL.ByteString) row
+              body = fromMaybe "[]" bodyRaw
+              locationH = fromMaybe "" locationRaw
           return $ responseLBS status201
-            [jsonH]
+            [
-            $ if echoRequested then (fromMaybe "[]" body) else ""
+              jsonH,
+              (hLocation, "/" <> cs table <> "?" <> cs locationH)
+            ]
+            $ if echoRequested then body else ""
         -- let qt = qualify table
       --     echoRequested = hasPrefer "return=representation"
       --     parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
@@ -207,12 +244,24 @@ app dbstructure conf authenticator reqBody dbrole req =
       --     return $ multipart status201 responses
 
       where
-        apiRequest = parsePostRequest req reqBody
+        res = parsePostRequest req reqBody
+        apiRequest = snd <$> res
+        returnSingle = fst <$> res
         insertQuery = requestToQuery schema <$> apiRequest
-        query = withT
+
-            <$> insertQuery
+        -- localWithT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =
-            <*> pure "t"
+        --   B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq)
-            <*> pure (B.Stmt "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying" V.empty True)
+        --     (ep <> wp)
+        --     (epre && wpre)
+        --
+        -- query = localWithT
+        --     <$> insertQuery
+        --     <*> pure "k"
+        --     <*> pure (
+        --       B.Stmt "SELECT " V.empty True <>
+        --       bodyForAccept contentType (QualifiedIdentifier "" "k") (B.Stmt "SELECT * FROM k" V.empty True)
+        --       )
+        --       -- TODO! csv does not work because k is not a real table
 
 
     (["rpc", proc], "POST") -> do
@@ -420,12 +469,13 @@ formatParserError e = cs $ encode $ object [
      details = strip $ replace "\n" " " $ cs
        $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
 --parsePostRequest :: Request -> BL.ByteString -> Either String (V.Vector Text, V.Vector (V.Vector Value))
-parsePostRequest :: Request -> BL.ByteString -> Either Text ApiRequest
+parsePostRequest :: Request -> BL.ByteString -> Either Text (Bool, ApiRequest)
 parsePostRequest httpRequest reqBody =
-  Node <$> apiNode <*> pure []
+  (,) <$> returnSingle <*> node
   where
+    node = Node <$> apiNode <*> pure []
     apiNode = (,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)
-    flds =  join $ first formatParserError . (mapM (parseField . cs)) <$> (fst <$> parsed)
+    flds =  join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsed)
     vals = snd <$> parsed
     parseField f = parse pField ("failed to parse field <<"++f++">>") f
     parsed :: Either Text ([Text],[[Value]])
@@ -440,10 +490,16 @@ parsePostRequest httpRequest reqBody =
       ) =<<
       if isCsv
       then do
-        rows <- (map (V.toList) . V.toList) <$> CSV.decode CSV.NoHeader reqBody
+        rows <- (map V.toList . V.toList) <$> CSV.decode CSV.NoHeader reqBody
         if null rows then Left "CSV requires header"
           else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows))
-      else eitherDecode reqBody >>= \val -> convertJson val
+      else jsn >>= \val -> convertJson val
+    jsn = eitherDecode reqBody
+    returnSingle = first cs $ jsn >>= (\v->
+      case v of
+        Object _  -> Right True
+        _         -> Right False
+      )
     hdrs          = requestHeaders httpRequest
     lookupHeader  = flip lookup hdrs
     rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head

src/PostgREST/PgQuery.hs

@@ -101,6 +101,27 @@ countNone = B.Stmt "select null" empty True
 asCsvWithCount :: QualifiedIdentifier -> StatementT
 asCsvWithCount table = withCount . asCsv table
 
+{--
+WITH source AS (
+	SELECT * FROM projects
+)
+SELECT
+  (
+  	SELECT string_agg(k.kk, ',')
+  	FROM (
+  		SELECT json_object_keys(j)::TEXT as kk
+  		FROM (
+  			SELECT row_to_json(source) as j from source limit 1
+  		) l
+  	) k
+  )
+  || '\r' ||
+  coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '')
+FROM (
+	SELECT * FROM source
+) t;
+--}
+
 asCsv :: QualifiedIdentifier -> StatementT
 asCsv table s = s {
   B.stmtTemplate =
@@ -285,7 +306,10 @@ trimNullChars :: T.Text -> T.Text
 trimNullChars = T.takeWhile (/= '\x0')
 
 fromQi :: QualifiedIdentifier -> T.Text
-fromQi t = pgFmtIdent (qiSchema t) <> "." <> pgFmtIdent (qiName t)
+fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
+  where
+    n = qiName t
+    s = qiSchema t
 
 unquoted :: JSON.Value -> T.Text
 unquoted (JSON.String t) = t
@@ -304,3 +328,74 @@ insertableValue v = insertableText $ unquoted v
 paramFilter :: JSON.Value -> T.Text
 paramFilter JSON.Null = "is.null"
 paramFilter v = "eq." <> unquoted v
+
+
+withSourceF :: T.Text -> T.Text
+withSourceF s = "WITH source AS (" <> s <>")"
+
+countF :: T.Text
+countF = "pg_catalog.count(t)"
+
+countAllF :: T.Text
+countAllF = "(SELECT pg_catalog.count(a) FROM (SELECT * FROM source) a )"
+
+countNoneF :: T.Text
+countNoneF = "null"
+
+asJsonF :: T.Text
+asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying"
+
+asJsonSingleF :: T.Text --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
+asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying "
+
+asCsvF :: T.Text
+asCsvF = asCsvHeaderF <> " || '\r' || " <> asCsvBodyF
+
+asCsvHeaderF :: T.Text
+asCsvHeaderF =
+  "(SELECT string_agg(a.k, ',')" <>
+  "  FROM (" <>
+  "    SELECT json_object_keys(r)::TEXT as k" <>
+  "    FROM ( " <>
+  "      SELECT row_to_json(source) as r from source limit 1" <>
+  "    ) s" <>
+  "  ) a" <>
+  ")"
+
+asCsvBodyF :: T.Text
+asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '')"
+
+fromF :: T.Text -> T.Text
+fromF limit = "FROM (SELECT * FROM source " <> limit <> ") t"
+
+limitF :: Maybe NonnegRange -> T.Text
+limitF r  = "LIMIT " <> limit <> " OFFSET " <> offset
+  where
+    limit  = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
+    offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
+
+locationF :: [T.Text] -> T.Text
+locationF pKeys =
+    "(" <>
+    " WITH s AS (SELECT row_to_json(source) as r from source limit 1)" <>
+    " SELECT string_agg(json_data.key || '=eq.' || json_data.value, '&')" <>
+    " FROM s, json_each_text(s.r) AS json_data" <>
+    (
+      if null pKeys
+      then ""
+      else " WHERE json_data.key IN ('" <> T.intercalate "','" pKeys <> "')"
+    ) <>
+    ")"
+
+orderF :: [OrderTerm] -> T.Text
+orderF ts =
+  if L.null ts
+    then ""
+    else "ORDER BY " <> clause
+  where
+    clause = T.intercalate "," (map queryTerm ts)
+    queryTerm :: OrderTerm -> T.Text
+    queryTerm t = " "
+           <> cs (pgFmtIdent $ otTerm t) <> " "
+           <> cs (otDirection t)         <> " "
+           <> maybe "" cs (otNullOrder t) <> " "

src/PostgREST/QueryBuilder.hs

@@ -12,7 +12,7 @@ import           Control.Applicative
 import           Data.Tree
 import           PostgREST.PgQuery (PStmt, fromQi,
                                     orderT, pgFmtIdent, pgFmtLit, pgFmtOperator,
-                                    pgFmtValue, whiteList, insertableValue)
+                                    pgFmtValue, whiteList, insertableValue, orderF)
 import           PostgREST.Types
 import qualified Data.Vector       as V (empty)
 import qualified Hasql.Backend     as B
@@ -86,16 +86,20 @@ requestToCountQuery schema (Node (Select _ _ conditions _, (mainTbl, _)) _) =
         fn  (Filter{value=VText _}) = True
         fn  (Filter{value=VForeignKey _ _}) = False
 
-requestToQuery :: Text -> ApiRequest -> PStmt
+--requestToQuery :: Text -> ApiRequest -> PStmt
+requestToQuery :: Text -> ApiRequest -> Text
 requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) =
-  orderT (fromMaybe [] ord)  query
+  --orderT (fromMaybe [] ord)  query
+  query
   where
-    query = B.Stmt qStr V.empty True
+    --query = B.Stmt qStr V.empty True
-    qStr = Data.Text.unwords [
+    --qStr = Data.Text.unwords [
+    query = Data.Text.unwords [
       ("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
       "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
       "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) tbls),
-      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions
+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions,
+      orderF (fromMaybe [] ord)
       ]
     emptyOnNull val x = if null x then "" else val
     (withs, selects) = foldr getQueryParts ([],[]) forest
@@ -106,13 +110,15 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
            <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
            <> "FROM (" <> subquery <> ") " <> table
            <> ") AS " <> table
-           where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
+           --where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
+           where subquery = requestToQuery schema (Node n forst)
 
     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 n forst)
+          --where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
+          where subquery = requestToQuery schema (Node n forst)
 
     getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
       where
@@ -120,7 +126,8 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
            <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
            <> "FROM (" <> subquery <> ") " <> table
            <> ") AS " <> table
-           where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
+           --where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
+           where 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
@@ -129,9 +136,10 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
 requestToQuery schema (Node (Insert tbl flds vals, (mainTbl, _)) forest) =
   query
   where
-    query = B.Stmt qStr V.empty True
+    --query = B.Stmt qStr V.empty True
     qi = QualifiedIdentifier schema mainTbl
-    qStr = Data.Text.unwords [
+    --qStr = Data.Text.unwords [
+    query = Data.Text.unwords [
       "INSERT INTO ", fromQi qi,
       " (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ",
       "VALUES " <> intercalate ", "