diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index e89357c62..dca5a2262 100644 --- a/src/PostgREST/App.hs +++ b/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 - 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 diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index 9d3d43a01..4997786e7 100644 --- a/src/PostgREST/PgQuery.hs +++ b/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) <> " " diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index c0194b508..8c66712d0 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/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 - 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 ", "