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.

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