From 38f3bcf4a66fff807d1b899c9941a9b52289ad53 Mon Sep 17 00:00:00 2001 From: steve-chavez Date: Fri, 10 Nov 2017 19:41:47 -0500 Subject: [PATCH] Reduce memory usage by avoiding Aeson encode 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. --- CHANGELOG.md | 2 +- postgrest.cabal | 4 +- src/PostgREST/ApiRequest.hs | 72 ++++++++++------------ src/PostgREST/App.hs | 46 +++++++------- src/PostgREST/QueryBuilder.hs | 111 +++++++++++++++++----------------- src/PostgREST/Types.hs | 35 +++++++---- stack.yaml | 3 + 7 files changed, 141 insertions(+), 132 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5b2687970..eba086696 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,7 +10,7 @@ This project adheres to [Semantic Versioning](http://semver.org/). ### Fixed - #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 diff --git a/postgrest.cabal b/postgrest.cabal index 9a2c92190..dd9f13e40 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -60,8 +60,8 @@ library , either , gitrev , hasql - , hasql-pool == 0.4.1 - , hasql-transaction == 0.5 + , hasql-pool + , hasql-transaction , heredoc , HTTP , http-types diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 9818f0b2c..1f8b3ac3e 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -13,7 +13,7 @@ module PostgREST.ApiRequest ( ApiRequest(..) import Protolude 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.Internal as BS (c2w) import qualified Data.ByteString.Lazy as BL @@ -33,14 +33,7 @@ import Network.Wai (Request (..)) import Network.Wai.Parse (parseHttpAccept) import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset) import Data.Ranged.Boundaries -import PostgREST.Types ( QualifiedIdentifier (..) - , Schema - , PayloadJSON(..) - , ContentType(..) - , ApiRequestError(..) - , toMime - , operators - , ftsOperators) +import PostgREST.Types import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange) import qualified Data.CaseInsensitive as CI import Web.Cookie (parseCookiesText) @@ -150,17 +143,17 @@ userApiRequest schema req reqBody payload = case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of CTApplicationJSON -> - note "All object keys must match" . ensureUniform . pluralize + note "All object keys must match" . consPayloadJSON reqBody =<< if BL.null reqBody && isTargetingProc then Right emptyObject else JSON.eitherDecode reqBody - CTTextCSV -> - note "All lines must have same number of fields" . ensureUniform . csvToJson - =<< CSV.decodeByName reqBody + CTTextCSV -> do + json <- csvToJson <$> CSV.decodeByName reqBody + note "All lines must have same number of fields" $ consPayloadJSON (JSON.encode json) json CTOther "application/x-www-form-urlencoded" -> - Right . PayloadJSON . V.singleton . M.fromList - . map (toS *** JSON.String . toS) . parseSimpleQuery - $ toS reqBody + let json = M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody + keys = S.fromList $ M.keys json in + Right $ PayloadJSON (JSON.encode json) PJObject keys ct -> Left $ toS $ "Content-Type not acceptable: " <> toMime ct 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 directly with CSV.decodeByName -} -csvToJson :: (CSV.Header, CsvData) -> JSON.Array +csvToJson :: (CSV.Header, CsvData) -> JSON.Value csvToJson (_, vals) = - V.map rowToJsonObj vals + JSON.Array $ V.map rowToJsonObj vals where rowToJsonObj = JSON.Object . M.map (\str -> @@ -281,27 +274,26 @@ csvToJson (_, vals) = else JSON.String $ toS str ) --- | Convert {foo} to [{foo}], leave arrays unchanged --- and truncate everything else to an empty array. -pluralize :: JSON.Value -> JSON.Array -pluralize obj@(JSON.Object _) = V.singleton obj -pluralize (JSON.Array arr) = arr -pluralize _ = V.empty +consPayloadJSON :: BL.ByteString -> JSON.Value -> Maybe PayloadJSON +consPayloadJSON raw json = + -- Test that Array contains only Objects having the same keys + case json of + JSON.Array 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 + 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 --- 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 + JSON.Object o -> Just $ PayloadJSON raw PJObject (S.fromList $ M.keys o) - if (V.length objs == V.length arr) && areKeysUniform - then Just (PayloadJSON objs) - else Nothing + -- truncate everything else to an empty array. + _ -> Just $ PayloadJSON (JSON.encode emptyArray) (PJArray 0) S.empty diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 2ecb88d8f..ea449c5a1 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -6,11 +6,12 @@ module PostgREST.App ( ) where import Control.Applicative -import Data.Aeson (toJSON, eitherDecode) +import Data.Aeson as JSON import qualified Data.ByteString.Char8 as BS import Data.Maybe import Data.IORef (IORef, readIORef) import Data.Text (intercalate) +import qualified Data.Set as S import qualified Hasql.Pool as P import qualified Hasql.Transaction as HT @@ -22,7 +23,6 @@ import Network.HTTP.Types.URI (renderSimpleQuery) import Network.Wai import Network.Wai.Middleware.RequestLogger (logStdout) -import qualified Data.Vector as V import qualified Hasql.Transaction as H import qualified Data.HashMap.Strict as M @@ -136,22 +136,24 @@ app dbStructure conf apiRequest = ) ] (toS body) - (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) -> + (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just (PayloadJSON payload pType _)) -> case mutateSqlParts of Left errorResponse -> return errorResponse 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 && not isSingle && iPreferRepresentation apiRequest == Full - then return $ singularityError (toInteger $ V.length rows) + then return $ singularityError (toInteger rows) else do 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 (contentType == CTSingularJSON) isSingle (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pKeys - row <- H.query payload stm + row <- H.query (toS payload) stm let (_, _, fs, body) = extractQueryResult row headers = catMaybes [ if null fs @@ -161,23 +163,23 @@ app dbStructure conf apiRequest = then Just $ toHeader contentType else Nothing , 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 $ if iPreferRepresentation apiRequest == Full then toS body else "" - (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON rows)) -> - case (mutateSqlParts, null <$> rows V.!? 0, iPreferRepresentation apiRequest == Full) of + (ActionUpdate, TargetIdent _, Just p@(PayloadJSON payload _ _)) -> + case (mutateSqlParts, pjIsEmpty p, iPreferRepresentation apiRequest == Full) of (Left errorResponse, _, _) -> return errorResponse - (_, Just True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]" - (_, Just True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] "" + (_, True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]" + (_, True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] "" (Right (sq, mq), _, _) -> do let stm = createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] - row <- H.query payload stm + row <- H.query (toS payload) stm let (_, queryTotal, _, body) = extractQueryResult row if contentType == CTSingularJSON && queryTotal /= 1 @@ -199,12 +201,11 @@ app dbStructure conf apiRequest = case mutateSqlParts of Left errorResponse -> return errorResponse Right (sq, mq) -> do - let emptyPayload = PayloadJSON V.empty - stm = createWriteStatement sq mq + let stm = createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] - row <- H.query emptyPayload stm + row <- H.query mempty stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 1 0 $ toInteger <$> if shouldCount then Just queryTotal else Nothing @@ -239,22 +240,23 @@ app dbStructure conf apiRequest = case parts of Left errorResponse -> return errorResponse Right ((q, cq), bField, params) -> do - let prms = case payload of - Just (PayloadJSON pld) -> V.head pld - Nothing -> M.fromList $ second toJSON <$> params + let (prms, keys, isObject) = case payload of + Just (PayloadJSON p (PJArray _) ks) -> (p, ks, False) + 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 paramsAsSingleObject = iPreferSingleObjectParameter apiRequest - specifiedPgArgs = filter (flip M.member prms . pgaName) $ fromMaybe [] (pdArgs <$> proc) - row <- H.query (toJSON prms) $ + specifiedPgArgs = filter (flip S.member keys . pgaName) $ fromMaybe [] (pdArgs <$> proc) + row <- H.query (toS prms) $ callProc qi specifiedPgArgs returnsScalar q cq shouldCount singular paramsAsSingleObject (contentType == CTTextCSV) (contentType == CTOctetStream) _isReadOnly bField - (pgVersion dbStructure) + isObject (pgVersion dbStructure) let (tableTotal, queryTotal, body, jsonHeaders) = fromMaybe (Just 0, 0, "[]", "[]") row (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 Left _ -> return gucHeadersError Right hs -> diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 0f5b1ca33..713545d71 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -31,14 +31,13 @@ import qualified Data.Aeson as JSON import PostgREST.Config (pgVersion96) import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset, allRange) -import Data.Functor.Contravariant (contramap) import qualified Data.HashMap.Strict as HM import Data.Maybe +import qualified Data.Set as S import Data.Text (intercalate, unwords, replace, isInfixOf, toLower) import qualified Data.Text as T (map, takeWhile, null) import qualified Data.Text.Encoding as T import Data.Tree (Tree(..)) -import qualified Data.Vector as V import PostgREST.Types import Text.InterpolatedString.Perl6 (qc) import qualified Data.ByteString.Char8 as BS @@ -76,14 +75,6 @@ decodeStandardMay :: HD.Result (Maybe ResultsWithCount) decodeStandardMay = 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 -> H.Query () ResultsWithCount createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField = @@ -105,11 +96,12 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField | isJust binaryField = asBinaryF $ fromJust binaryField | otherwise = asJsonF + createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> PreferRepresentation -> [Text] -> - H.Query PayloadJSON (Maybe ResultsWithCount) + H.Query ByteString (Maybe ResultsWithCount) createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys = - unicodeStatement sql encodeUniformObjs decodeStandardMay True + unicodeStatement sql (HE.value HE.unknown) decodeStandardMay True where sql = case rep of @@ -143,16 +135,14 @@ createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys type ProcResults = (Maybe Int64, Int64, ByteString, ByteString) callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool -> - Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> - H.Query JSON.Value (Maybe ProcResults) -callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsJson asCsv asBinary isReadOnly binaryField pgVer = - unicodeStatement sql (HE.value HE.json) decodeProc True + Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> Bool -> PgVersion -> + H.Query ByteString (Maybe ProcResults) +callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary isReadOnly binaryField isObject pgVer = + unicodeStatement sql (HE.value HE.unknown) decodeProc True where sql = if returnsScalar then [qc| - WITH _args_record AS ( - {argsRecord} - ), + WITH {argsRecord}, {sourceCTEName} AS ( SELECT {fromQi qi}({args}) ) @@ -163,9 +153,7 @@ callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle para {responseHeaders} AS response_headers FROM ({selectQuery}) _postgrest_t;|] else [qc| - WITH _args_record AS ( - {argsRecord} - ), + WITH {argsRecord}, {sourceCTEName} AS ( SELECT * FROM {fromQi qi}({args}) ) @@ -176,11 +164,14 @@ callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle para {responseHeaders} AS response_headers FROM ({selectQuery}) _postgrest_t;|] - (argsRecord, args) | paramsAsJson && not isReadOnly = ("SELECT NULL", "$1") - | null pgArgs = ("SELECT NULL", "") + (argsRecord, args) | paramsAsSingleObject && not isReadOnly = ("_args_record AS (SELECT NULL)", "$1::json") + | null pgArgs = (ignoredBody, "") | otherwise = ( - "SELECT * FROM json_to_record($1) AS _(" <> intercalate ", " ((\a -> pgaName a <> " " <> pgaType a) <$> pgArgs) <> ")", - intercalate ", " ((\a -> pgaName a <> " := (SELECT " <> pgaName a <> " FROM _args_record)") <$> pgArgs) + "_args_record AS ( "<> + "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 _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 --posible relations are Child Parent Many getQueryParts _ _ = undefined -requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)) = - insInto <> vals <> ret - where qi = QualifiedIdentifier schema mainTbl - cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) - colsString = intercalate ", " cols - insInto = unwords [ "INSERT INTO" , fromQi qi, - if T.null colsString then "" else "(" <> colsString <> ")" - ] - vals = unwords $ - if T.null colsString - then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"] - else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] - ret = if null returnings - then "" - else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)] -requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) logicForest returnings)) = - case rows V.!? 0 of - Just obj -> - let cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> HM.keys obj) in +requestToQuery schema _ (DbMutate (Insert mainTbl p@(PayloadJSON _ pType keys) returnings)) = + unwords [ + ("WITH " <> ignoredBody) `emptyOnFalse` not payloadIsEmpty, + "INSERT INTO ", fromQi qi, if payloadIsEmpty then " " else "(" <> cols <> ") ", + case (pType, payloadIsEmpty) of + (PJArray _, True) -> "SELECT null WHERE false" + (PJObject, True) -> "DEFAULT VALUES" + _ -> unwords [ + "SELECT " <> cols <> " FROM ", + case pType of + PJObject -> "json_populate_record" + PJArray _ -> "json_populate_recordset", "(null::", fromQi qi, ", $1) "], + ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings + ] + where + qi = QualifiedIdentifier schema mainTbl + cols = intercalate ", " $ pgFmtIdent <$> S.toList keys + payloadIsEmpty = pjIsEmpty p +requestToQuery schema _ (DbMutate (Update mainTbl p@(PayloadJSON _ pType keys) logicForest returnings)) = + if pjIsEmpty p + then "WITH " <> ignoredBody <> "SELECT ''" + else unwords [ - "UPDATE ", fromQi qi, - " SET " <> cols <> " FROM (SELECT * FROM json_populate_recordset(null::" <> fromQi qi <> ", $1)) _ ", + "UPDATE " <> fromQi qi <> " SET " <> cols, + "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, ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings ] - Nothing -> undefined where qi = QualifiedIdentifier schema mainTbl + cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList keys) 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 qi = QualifiedIdentifier schema mainTbl - query = unwords [ - "DELETE FROM ", fromQi qi, - ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest, - ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings - ] + +-- Due to the use of the `unknown` encoder we need to cast '$1' when the value is not used in the main query +-- otherwise the query will err with a `could not determine data type of parameter $1`. +-- 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 tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 80f092182..8441a129e 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -2,12 +2,12 @@ module PostgREST.Types where import Protolude import qualified GHC.Show -import Data.Aeson +import qualified Data.Aeson as JSON import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as M +import qualified Data.Set as S import Data.Tree -import qualified Data.Vector as V import PostgREST.RangeQuery (NonnegRange) import Network.HTTP.Types.Header (hContentType, Header) @@ -59,7 +59,6 @@ type Schema = Text type TableName = Text type SqlQuery = Text type SqlFragment = Text -type RequestBody = BL.ByteString data Table = Table { tableSchema :: Schema @@ -133,13 +132,23 @@ data Relation = Relation { , relLCols2 :: Maybe [Column] } deriving (Show, Eq) --- | An array of JSON objects that has been verified to have --- the same keys in every object -newtype PayloadJSON = PayloadJSON (V.Vector Object) - deriving (Show, Eq) +-- | Cached attributes of a JSON payload +data PayloadJSON = PayloadJSON { +-- | This is the raw ByteString that comes from the request body. +-- 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 -unPayloadJSON (PayloadJSON objs) = objs +data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq) + +-- | 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 { proxyScheme :: Text @@ -224,10 +233,10 @@ type RpcQParam = (Text, Text) -} newtype GucHeader = GucHeader (Text, Text) -instance FromJSON GucHeader where - parseJSON (Object o) = case headMay (M.toList o) of - Just (k, String s) | M.size o == 1 -> pure $ GucHeader (k, s) - | otherwise -> mzero +instance JSON.FromJSON GucHeader where + parseJSON (JSON.Object o) = case headMay (M.toList o) of + Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (k, s) + | otherwise -> mzero _ -> mzero parseJSON _ = mzero diff --git a/stack.yaml b/stack.yaml index 22c3bf7c3..b17f9e807 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,6 +6,9 @@ extra-deps: - hjsonschema-1.5.0.1 - Ranged-sets-0.3.0 - protolude-0.2 + - hasql-1.1 + - hasql-pool-0.4.3 + - hasql-transaction-0.5.2 ghc-options: postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints nix: