using query fragments instead of query transformers o generate queries

2015-10-22 13:47:34 +03:00
parent 71ef03070e
commit 2b8f5f791a
3 changed files with 198 additions and 39 deletions
@@ -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
-                count = if hasPrefer "count=none"
-                      then countNone
-                      else cqs
-                q = B.Stmt "select " V.empty True <>
-                    parentheticT count
-                    <> commaq <> (
-                    bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables
-                    . limitT range
-                    $ qs
-                  )
+            -- let qt = qualify table
+            --     count = if hasPrefer "count=none"
+            --           then countNone
+            --           else cqs
+            --     q = B.Stmt "select " V.empty True <>
+            --         parentheticT count
+            --         <> commaq <> (
+            --         bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables
+            --         . limitT range
+            --         $ 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"
-      case query of
+      let echoRequested = hasPrefer "return=representation" --TODO!! do not request content at all in query if not echoRequested
+      case insertQuery of
        Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
        Right q -> do
-          row <- H.maybeEx q
-          let (queryTotal, body) = fromMaybe (Just (0::Int), Just "" :: Maybe BL.ByteString) row
+          let isSingle = either (const False) id returnSingle
+              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
-            <*> pure "t"
-            <*> pure (B.Stmt "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying" V.empty True)
+
+        -- localWithT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =
+        --   B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq)
+        --     (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
@@ -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) <> " "
@@ -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
-    qStr = Data.Text.unwords [
+    --query = B.Stmt qStr V.empty True
+    --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 ", "