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.
2018-01-10 11:43:16 -05:00
parent f159233de8
commit 38f3bcf4a6
7 changed files with 141 additions and 132 deletions
@@ -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

@@ -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
@@ -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
@@ -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 ->
@@ -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
@@ -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

@@ -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: