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: