jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Reduce memory usage by avoiding Aeson encode

Browse Source 
It was detected that Aeson encoding had high memory usage when
the json payload was large, around x60 the payload size.
With this change we get around x10 payload size memory usage.

The encodeUtf8(when doing a Text -> ByteString with `toS`) function
on a large payload also contributed to the high memory usage.

Main idea to reduce the memory usage was to let the ByteString coming
from the request body go to the database unchanged.
This commit is contained in:
steve-chavez
2018-01-10 11:43:16 -05:00
committed by Steve Chávez
parent f159233de8
commit 38f3bcf4a6
7 changed files with 141 additions and 132 deletions
Download Patch File Download Diff File Expand all files Collapse all files
CHANGELOG.md
+1 -1
View File
@@ -10,7 +10,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
### Fixed ### Fixed
- #828, Fix computed column only working in public schema - @steve-chavez - #828, Fix computed column only working in public schema - @steve-chavez
- #925, Avoid RPC high memory usage by using parametrized query - @steve-chavez - #925, Fix RPC high memory usage by using parametrized query and avoiding json encoding - @steve-chavez
### Changed ### Changed
postgrest.cabal
+2 -2
View File
@@ -60,8 +60,8 @@ library
, either , either
, gitrev , gitrev
, hasql , hasql
, hasql-pool == 0.4.1 , hasql-pool
, hasql-transaction == 0.5 , hasql-transaction
, heredoc , heredoc
, HTTP , HTTP
, http-types , http-types
src/PostgREST/ApiRequest.hs
+32 -40
View File
@@ -13,7 +13,7 @@ module PostgREST.ApiRequest ( ApiRequest(..)
import Protolude import Protolude
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
import Data.Aeson.Types (emptyObject) import Data.Aeson.Types (emptyObject, emptyArray)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS (c2w) import qualified Data.ByteString.Internal as BS (c2w)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
@@ -33,14 +33,7 @@ import Network.Wai (Request (..))
import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Parse (parseHttpAccept)
import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset) import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
import Data.Ranged.Boundaries import Data.Ranged.Boundaries
import PostgREST.Types ( QualifiedIdentifier (..) import PostgREST.Types
, Schema
, PayloadJSON(..)
, ContentType(..)
, ApiRequestError(..)
, toMime
, operators
, ftsOperators)
import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange) import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Web.Cookie (parseCookiesText) import Web.Cookie (parseCookiesText)
@@ -150,17 +143,17 @@ userApiRequest schema req reqBody
payload = payload =
case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of
CTApplicationJSON -> CTApplicationJSON ->
note "All object keys must match" . ensureUniform . pluralize note "All object keys must match" . consPayloadJSON reqBody
=<< if BL.null reqBody && isTargetingProc =<< if BL.null reqBody && isTargetingProc
then Right emptyObject then Right emptyObject
else JSON.eitherDecode reqBody else JSON.eitherDecode reqBody
CTTextCSV -> CTTextCSV -> do
note "All lines must have same number of fields" . ensureUniform . csvToJson json <- csvToJson <$> CSV.decodeByName reqBody
=<< CSV.decodeByName reqBody note "All lines must have same number of fields" $ consPayloadJSON (JSON.encode json) json
CTOther "application/x-www-form-urlencoded" -> CTOther "application/x-www-form-urlencoded" ->
Right . PayloadJSON . V.singleton . M.fromList let json = M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody
. map (toS *** JSON.String . toS) . parseSimpleQuery keys = S.fromList $ M.keys json in
$ toS reqBody Right $ PayloadJSON (JSON.encode json) PJObject keys
ct -> ct ->
Left $ toS $ "Content-Type not acceptable: " <> toMime ct Left $ toS $ "Content-Type not acceptable: " <> toMime ct
topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges
@@ -270,9 +263,9 @@ type CsvData = V.Vector (M.HashMap Text BL.ByteString)
The reason for its odd signature is so that it can compose The reason for its odd signature is so that it can compose
directly with CSV.decodeByName directly with CSV.decodeByName
-} -}
csvToJson :: (CSV.Header, CsvData) -> JSON.Array csvToJson :: (CSV.Header, CsvData) -> JSON.Value
csvToJson (_, vals) = csvToJson (_, vals) =
V.map rowToJsonObj vals JSON.Array $ V.map rowToJsonObj vals
where where
rowToJsonObj = JSON.Object . rowToJsonObj = JSON.Object .
M.map (\str -> M.map (\str ->
@@ -281,27 +274,26 @@ csvToJson (_, vals) =
else JSON.String $ toS str else JSON.String $ toS str
) )
-- | Convert {foo} to [{foo}], leave arrays unchanged consPayloadJSON :: BL.ByteString -> JSON.Value -> Maybe PayloadJSON
-- and truncate everything else to an empty array. consPayloadJSON raw json =
pluralize :: JSON.Value -> JSON.Array -- Test that Array contains only Objects having the same keys
pluralize obj@(JSON.Object _) = V.singleton obj case json of
pluralize (JSON.Array arr) = arr JSON.Array arr ->
pluralize _ = V.empty let objs :: V.Vector JSON.Object
objs = foldr -- filter non-objects, map to raw objects
(\val result -> case val of
JSON.Object o -> V.cons o result
_ -> result)
V.empty arr
keysPerObj = V.map (S.fromList . M.keys) objs
canonicalKeys = fromMaybe S.empty $ keysPerObj V.!? 0
areKeysUniform = all (==canonicalKeys) keysPerObj
arrLength = V.length arr in
if (V.length objs == arrLength) && areKeysUniform
then Just $ PayloadJSON raw (PJArray arrLength) canonicalKeys
else Nothing
-- | Test that Array contains only Objects having the same keys JSON.Object o -> Just $ PayloadJSON raw PJObject (S.fromList $ M.keys o)
-- and if so mark it as PayloadJSON
ensureUniform :: JSON.Array -> Maybe PayloadJSON
ensureUniform arr =
let objs :: V.Vector JSON.Object
objs = foldr -- filter non-objects, map to raw objects
(\val result -> case val of
JSON.Object o -> V.cons o result
_ -> result)
V.empty arr
keysPerObj = V.map (S.fromList . M.keys) objs
canonicalKeys = fromMaybe S.empty $ keysPerObj V.!? 0
areKeysUniform = all (==canonicalKeys) keysPerObj in
if (V.length objs == V.length arr) && areKeysUniform -- truncate everything else to an empty array.
then Just (PayloadJSON objs) _ -> Just $ PayloadJSON (JSON.encode emptyArray) (PJArray 0) S.empty
else Nothing
src/PostgREST/App.hs
+24 -22
View File
@@ -6,11 +6,12 @@ module PostgREST.App (
) where ) where
import Control.Applicative import Control.Applicative
import Data.Aeson (toJSON, eitherDecode) import Data.Aeson as JSON
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.Maybe import Data.Maybe
import Data.IORef (IORef, readIORef) import Data.IORef (IORef, readIORef)
import Data.Text (intercalate) import Data.Text (intercalate)
import qualified Data.Set as S
import qualified Hasql.Pool as P import qualified Hasql.Pool as P
import qualified Hasql.Transaction as HT import qualified Hasql.Transaction as HT
@@ -22,7 +23,6 @@ import Network.HTTP.Types.URI (renderSimpleQuery)
import Network.Wai import Network.Wai
import Network.Wai.Middleware.RequestLogger (logStdout) import Network.Wai.Middleware.RequestLogger (logStdout)
import qualified Data.Vector as V
import qualified Hasql.Transaction as H import qualified Hasql.Transaction as H
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
@@ -136,22 +136,24 @@ app dbStructure conf apiRequest =
) )
] (toS body) ] (toS body)
(ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) -> (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just (PayloadJSON payload pType _)) ->
case mutateSqlParts of case mutateSqlParts of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
let isSingle = (==1) $ V.length rows let (isSingle, rows) = case pType of
PJArray len -> (len == 1, len)
PJObject -> (True, 1)
if contentType == CTSingularJSON if contentType == CTSingularJSON
&& not isSingle && not isSingle
&& iPreferRepresentation apiRequest == Full && iPreferRepresentation apiRequest == Full
then return $ singularityError (toInteger $ V.length rows) then return $ singularityError (toInteger rows)
else do else do
let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
stm = createWriteStatement sq mq stm = createWriteStatement sq mq
(contentType == CTSingularJSON) isSingle (contentType == CTSingularJSON) isSingle
(contentType == CTTextCSV) (iPreferRepresentation apiRequest) (contentType == CTTextCSV) (iPreferRepresentation apiRequest)
pKeys pKeys
row <- H.query payload stm row <- H.query (toS payload) stm
let (_, _, fs, body) = extractQueryResult row let (_, _, fs, body) = extractQueryResult row
headers = catMaybes [ headers = catMaybes [
if null fs if null fs
@@ -161,23 +163,23 @@ app dbStructure conf apiRequest =
then Just $ toHeader contentType then Just $ toHeader contentType
else Nothing else Nothing
, Just . contentRangeH 1 0 $ , Just . contentRangeH 1 0 $
toInteger <$> if shouldCount then Just (V.length rows) else Nothing toInteger <$> if shouldCount then Just rows else Nothing
] ]
return . responseLBS status201 headers $ return . responseLBS status201 headers $
if iPreferRepresentation apiRequest == Full if iPreferRepresentation apiRequest == Full
then toS body else "" then toS body else ""
(ActionUpdate, TargetIdent _, Just payload@(PayloadJSON rows)) -> (ActionUpdate, TargetIdent _, Just p@(PayloadJSON payload _ _)) ->
case (mutateSqlParts, null <$> rows V.!? 0, iPreferRepresentation apiRequest == Full) of case (mutateSqlParts, pjIsEmpty p, iPreferRepresentation apiRequest == Full) of
(Left errorResponse, _, _) -> return errorResponse (Left errorResponse, _, _) -> return errorResponse
(_, Just True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]" (_, True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"
(_, Just True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] "" (_, True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] ""
(Right (sq, mq), _, _) -> do (Right (sq, mq), _, _) -> do
let stm = createWriteStatement sq mq let stm = createWriteStatement sq mq
(contentType == CTSingularJSON) False (contentType == CTTextCSV) (contentType == CTSingularJSON) False (contentType == CTTextCSV)
(iPreferRepresentation apiRequest) [] (iPreferRepresentation apiRequest) []
row <- H.query payload stm row <- H.query (toS payload) stm
let (_, queryTotal, _, body) = extractQueryResult row let (_, queryTotal, _, body) = extractQueryResult row
if contentType == CTSingularJSON if contentType == CTSingularJSON
&& queryTotal /= 1 && queryTotal /= 1
@@ -199,12 +201,11 @@ app dbStructure conf apiRequest =
case mutateSqlParts of case mutateSqlParts of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
let emptyPayload = PayloadJSON V.empty let stm = createWriteStatement sq mq
stm = createWriteStatement sq mq
(contentType == CTSingularJSON) False (contentType == CTSingularJSON) False
(contentType == CTTextCSV) (contentType == CTTextCSV)
(iPreferRepresentation apiRequest) [] (iPreferRepresentation apiRequest) []
row <- H.query emptyPayload stm row <- H.query mempty stm
let (_, queryTotal, _, body) = extractQueryResult row let (_, queryTotal, _, body) = extractQueryResult row
r = contentRangeH 1 0 $ r = contentRangeH 1 0 $
toInteger <$> if shouldCount then Just queryTotal else Nothing toInteger <$> if shouldCount then Just queryTotal else Nothing
@@ -239,22 +240,23 @@ app dbStructure conf apiRequest =
case parts of case parts of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right ((q, cq), bField, params) -> do Right ((q, cq), bField, params) -> do
let prms = case payload of let (prms, keys, isObject) = case payload of
Just (PayloadJSON pld) -> V.head pld Just (PayloadJSON p (PJArray _) ks) -> (p, ks, False)
Nothing -> M.fromList $ second toJSON <$> params Just (PayloadJSON p PJObject ks) -> (p, ks, True)
Nothing -> (JSON.encode $ M.fromList $ second JSON.toJSON <$> params, S.fromList $ fst <$> params, True)
singular = contentType == CTSingularJSON singular = contentType == CTSingularJSON
paramsAsSingleObject = iPreferSingleObjectParameter apiRequest paramsAsSingleObject = iPreferSingleObjectParameter apiRequest
specifiedPgArgs = filter (flip M.member prms . pgaName) $ fromMaybe [] (pdArgs <$> proc) specifiedPgArgs = filter (flip S.member keys . pgaName) $ fromMaybe [] (pdArgs <$> proc)
row <- H.query (toJSON prms) $ row <- H.query (toS prms) $
callProc qi specifiedPgArgs returnsScalar q cq shouldCount callProc qi specifiedPgArgs returnsScalar q cq shouldCount
singular paramsAsSingleObject singular paramsAsSingleObject
(contentType == CTTextCSV) (contentType == CTTextCSV)
(contentType == CTOctetStream) _isReadOnly bField (contentType == CTOctetStream) _isReadOnly bField
(pgVersion dbStructure) isObject (pgVersion dbStructure)
let (tableTotal, queryTotal, body, jsonHeaders) = let (tableTotal, queryTotal, body, jsonHeaders) =
fromMaybe (Just 0, 0, "[]", "[]") row fromMaybe (Just 0, 0, "[]", "[]") row
(status, contentRange) = rangeHeader queryTotal tableTotal (status, contentRange) = rangeHeader queryTotal tableTotal
decodedHeaders = first toS $ eitherDecode $ toS jsonHeaders :: Either Text [GucHeader] decodedHeaders = first toS $ JSON.eitherDecode $ toS jsonHeaders :: Either Text [GucHeader]
case decodedHeaders of case decodedHeaders of
Left _ -> return gucHeadersError Left _ -> return gucHeadersError
Right hs -> Right hs ->
src/PostgREST/QueryBuilder.hs
+57 -54
View File
@@ -31,14 +31,13 @@ import qualified Data.Aeson as JSON
import PostgREST.Config (pgVersion96) import PostgREST.Config (pgVersion96)
import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset, allRange) import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset, allRange)
import Data.Functor.Contravariant (contramap)
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import Data.Maybe import Data.Maybe
import qualified Data.Set as S
import Data.Text (intercalate, unwords, replace, isInfixOf, toLower) import Data.Text (intercalate, unwords, replace, isInfixOf, toLower)
import qualified Data.Text as T (map, takeWhile, null) import qualified Data.Text as T (map, takeWhile, null)
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import Data.Tree (Tree(..)) import Data.Tree (Tree(..))
import qualified Data.Vector as V
import PostgREST.Types import PostgREST.Types
import Text.InterpolatedString.Perl6 (qc) import Text.InterpolatedString.Perl6 (qc)
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
@@ -76,14 +75,6 @@ decodeStandardMay :: HD.Result (Maybe ResultsWithCount)
decodeStandardMay = decodeStandardMay =
HD.maybeRow standardRow HD.maybeRow standardRow
{-| JSON and CSV payloads from the client are given to us as
PayloadJSON (objects who all have the same keys),
and we turn this into an old fasioned JSON array
-}
encodeUniformObjs :: HE.Params PayloadJSON
encodeUniformObjs =
contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json)
createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName -> createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName ->
H.Query () ResultsWithCount H.Query () ResultsWithCount
createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField = createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =
@@ -105,11 +96,12 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField
| isJust binaryField = asBinaryF $ fromJust binaryField | isJust binaryField = asBinaryF $ fromJust binaryField
| otherwise = asJsonF | otherwise = asJsonF
createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
PreferRepresentation -> [Text] -> PreferRepresentation -> [Text] ->
H.Query PayloadJSON (Maybe ResultsWithCount) H.Query ByteString (Maybe ResultsWithCount)
createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys = createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys =
unicodeStatement sql encodeUniformObjs decodeStandardMay True unicodeStatement sql (HE.value HE.unknown) decodeStandardMay True
where where
sql = case rep of sql = case rep of
@@ -143,16 +135,14 @@ createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys
type ProcResults = (Maybe Int64, Int64, ByteString, ByteString) type ProcResults = (Maybe Int64, Int64, ByteString, ByteString)
callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool -> callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool ->
Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> Bool -> PgVersion ->
H.Query JSON.Value (Maybe ProcResults) H.Query ByteString (Maybe ProcResults)
callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsJson asCsv asBinary isReadOnly binaryField pgVer = callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary isReadOnly binaryField isObject pgVer =
unicodeStatement sql (HE.value HE.json) decodeProc True unicodeStatement sql (HE.value HE.unknown) decodeProc True
where where
sql = sql =
if returnsScalar then [qc| if returnsScalar then [qc|
WITH _args_record AS ( WITH {argsRecord},
{argsRecord}
),
{sourceCTEName} AS ( {sourceCTEName} AS (
SELECT {fromQi qi}({args}) SELECT {fromQi qi}({args})
) )
@@ -163,9 +153,7 @@ callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle para
{responseHeaders} AS response_headers {responseHeaders} AS response_headers
FROM ({selectQuery}) _postgrest_t;|] FROM ({selectQuery}) _postgrest_t;|]
else [qc| else [qc|
WITH _args_record AS ( WITH {argsRecord},
{argsRecord}
),
{sourceCTEName} AS ( {sourceCTEName} AS (
SELECT * FROM {fromQi qi}({args}) SELECT * FROM {fromQi qi}({args})
) )
@@ -176,11 +164,14 @@ callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle para
{responseHeaders} AS response_headers {responseHeaders} AS response_headers
FROM ({selectQuery}) _postgrest_t;|] FROM ({selectQuery}) _postgrest_t;|]
(argsRecord, args) | paramsAsJson && not isReadOnly = ("SELECT NULL", "$1") (argsRecord, args) | paramsAsSingleObject && not isReadOnly = ("_args_record AS (SELECT NULL)", "$1::json")
| null pgArgs = ("SELECT NULL", "") | null pgArgs = (ignoredBody, "")
| otherwise = ( | otherwise = (
"SELECT * FROM json_to_record($1) AS _(" <> intercalate ", " ((\a -> pgaName a <> " " <> pgaType a) <$> pgArgs) <> ")", "_args_record AS ( "<>
intercalate ", " ((\a -> pgaName a <> " := (SELECT " <> pgaName a <> " FROM _args_record)") <$> pgArgs) "SELECT * FROM " <> (if isObject then "json_to_record" else "json_to_recordset") <>
"($1) AS _(" <> intercalate ", " ((\a -> pgaName a <> " " <> pgaType a) <$> pgArgs) <> ")" <>
")"
, intercalate ", " ((\a -> pgaName a <> " := (SELECT " <> pgaName a <> " FROM _args_record)") <$> pgArgs)
) )
countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text
_procName = qiName qi _procName = qiName qi
@@ -284,43 +275,55 @@ requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest
--getQueryParts is not total but requestToQuery 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 --posible relations are Child Parent Many
getQueryParts _ _ = undefined getQueryParts _ _ = undefined
requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)) = requestToQuery schema _ (DbMutate (Insert mainTbl p@(PayloadJSON _ pType keys) returnings)) =
insInto <> vals <> ret unwords [
where qi = QualifiedIdentifier schema mainTbl ("WITH " <> ignoredBody) `emptyOnFalse` not payloadIsEmpty,
cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) "INSERT INTO ", fromQi qi, if payloadIsEmpty then " " else "(" <> cols <> ") ",
colsString = intercalate ", " cols case (pType, payloadIsEmpty) of
insInto = unwords [ "INSERT INTO" , fromQi qi, (PJArray _, True) -> "SELECT null WHERE false"
if T.null colsString then "" else "(" <> colsString <> ")" (PJObject, True) -> "DEFAULT VALUES"
] _ -> unwords [
vals = unwords $ "SELECT " <> cols <> " FROM ",
if T.null colsString case pType of
then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"] PJObject -> "json_populate_record"
else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] PJArray _ -> "json_populate_recordset", "(null::", fromQi qi, ", $1) "],
ret = if null returnings ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
then "" ]
else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)] where
requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) logicForest returnings)) = qi = QualifiedIdentifier schema mainTbl
case rows V.!? 0 of cols = intercalate ", " $ pgFmtIdent <$> S.toList keys
Just obj -> payloadIsEmpty = pjIsEmpty p
let cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> HM.keys obj) in requestToQuery schema _ (DbMutate (Update mainTbl p@(PayloadJSON _ pType keys) logicForest returnings)) =
if pjIsEmpty p
then "WITH " <> ignoredBody <> "SELECT ''"
else
unwords [ unwords [
"UPDATE ", fromQi qi, "UPDATE " <> fromQi qi <> " SET " <> cols,
" SET " <> cols <> " FROM (SELECT * FROM json_populate_recordset(null::" <> fromQi qi <> ", $1)) _ ", "FROM (SELECT * FROM ",
case pType of
PJObject -> " json_populate_record"
PJArray _ -> " json_populate_recordset", "(null::", fromQi qi, ", $1)) _ ",
("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest, ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,
("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
] ]
Nothing -> undefined
where where
qi = QualifiedIdentifier schema mainTbl qi = QualifiedIdentifier schema mainTbl
cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList keys)
requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) = requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) =
query unwords [
"WITH " <> ignoredBody,
"DELETE FROM ", fromQi qi,
("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,
("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
]
where where
qi = QualifiedIdentifier schema mainTbl qi = QualifiedIdentifier schema mainTbl
query = unwords [
"DELETE FROM ", fromQi qi, -- Due to the use of the `unknown` encoder we need to cast '$1' when the value is not used in the main query
("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest, -- otherwise the query will err with a `could not determine data type of parameter $1`.
("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings -- This happens because `unknown` relies on the context to determine the value type.
] ignoredBody :: SqlFragment
ignoredBody = "ignored_body AS (SELECT $1::text) "
removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl
src/PostgREST/Types.hs
+22 -13
View File
@@ -2,12 +2,12 @@
module PostgREST.Types where module PostgREST.Types where
import Protolude import Protolude
import qualified GHC.Show import qualified GHC.Show
import Data.Aeson import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import Data.Tree import Data.Tree
import qualified Data.Vector as V
import PostgREST.RangeQuery (NonnegRange) import PostgREST.RangeQuery (NonnegRange)
import Network.HTTP.Types.Header (hContentType, Header) import Network.HTTP.Types.Header (hContentType, Header)
@@ -59,7 +59,6 @@ type Schema = Text
type TableName = Text type TableName = Text
type SqlQuery = Text type SqlQuery = Text
type SqlFragment = Text type SqlFragment = Text
type RequestBody = BL.ByteString
data Table = Table { data Table = Table {
tableSchema :: Schema tableSchema :: Schema
@@ -133,13 +132,23 @@ data Relation = Relation {
, relLCols2 :: Maybe [Column] , relLCols2 :: Maybe [Column]
} deriving (Show, Eq) } deriving (Show, Eq)
-- | An array of JSON objects that has been verified to have -- | Cached attributes of a JSON payload
-- the same keys in every object data PayloadJSON = PayloadJSON {
newtype PayloadJSON = PayloadJSON (V.Vector Object) -- | This is the raw ByteString that comes from the request body.
deriving (Show, Eq) -- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding
-- had high memory usage, see #1005 for more details
pjRaw :: BL.ByteString
, pjType :: PJType
-- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects
, pjKeys :: S.Set Text
} deriving (Show, Eq)
unPayloadJSON :: PayloadJSON -> V.Vector Object data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq)
unPayloadJSON (PayloadJSON objs) = objs
-- | e.g. whether it is []/{} or not
pjIsEmpty :: PayloadJSON -> Bool
pjIsEmpty (PayloadJSON _ PJObject keys) = S.size keys == 0
pjIsEmpty (PayloadJSON _ (PJArray l) _) = l == 0
data Proxy = Proxy { data Proxy = Proxy {
proxyScheme :: Text proxyScheme :: Text
@@ -224,10 +233,10 @@ type RpcQParam = (Text, Text)
-} -}
newtype GucHeader = GucHeader (Text, Text) newtype GucHeader = GucHeader (Text, Text)
instance FromJSON GucHeader where instance JSON.FromJSON GucHeader where
parseJSON (Object o) = case headMay (M.toList o) of parseJSON (JSON.Object o) = case headMay (M.toList o) of
Just (k, String s) | M.size o == 1 -> pure $ GucHeader (k, s) Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (k, s)
| otherwise -> mzero | otherwise -> mzero
_ -> mzero _ -> mzero
parseJSON _ = mzero parseJSON _ = mzero
stack.yaml
+3
View File
@@ -6,6 +6,9 @@ extra-deps:
- hjsonschema-1.5.0.1 - hjsonschema-1.5.0.1
- Ranged-sets-0.3.0 - Ranged-sets-0.3.0
- protolude-0.2 - protolude-0.2
- hasql-1.1
- hasql-pool-0.4.3
- hasql-transaction-0.5.2
ghc-options: ghc-options:
postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints
nix: nix: