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

refactor: Use hasql-dynamic on RPC/POST/PUT/PATCH

Browse Source 
Change callProc/createWriteStatement to H.Snippet.

Parametrize the inputs on the same SQLFragments by taking advantage
of hasql-dynamic-statements. It's not necessary to parametrize
every input, inlining with pgFmtLit can still be used for queries
that can't be parametrized(like SET LOCALs).

Also adds hasql-dynamic-statements to Nix and stack.
This commit is contained in:
steve-chavez
2020-11-23 19:00:50 -05:00
committed by Steve Chavez
parent b13e95aefb
commit 8e58b56d5c
10 changed files with 184 additions and 135 deletions
Download Patch File Download Diff File Expand all files Collapse all files
nix/overlays/haskell-packages.nix
+27
View File
@@ -17,6 +17,33 @@ let
#
# To get the sha256:
# nix-prefetch-url --unpack https://hackage.haskell.org/package/protolude-0.3.0/protolude-0.3.0.tar.gz
# TODO: We need to patch upstream for unbreaking hasql-dynamic-statements, hasql-implicits, ptr
hasql-dynamic-statements =
self.haskell.lib.dontCheck (prev.callHackageDirect
{
pkg = "hasql-dynamic-statements";
ver = "0.3.1";
sha256 = "1zjv91xlfkyxwq6mhzj7rsfm4kjvs9ygkgbl6jbbg19jihcn2kiy";
}
{ }
);
hasql-implicits =
prev.callHackageDirect
{
pkg = "hasql-implicits";
ver = "0.1.0.2";
sha256 = "1z05amiy5zmf8fmr3dqp8b4svb0sj037gdjc5b9va5d5kdi95bv7";
}
{ };
ptr =
prev.callHackageDirect
{
pkg = "ptr";
ver = "0.16.7.2";
sha256 = "1njb05jc1bdyxk7qh7s1y4ivn5nrpy3rhlkf4jlfamvlg8idkavc";
}
{ };
protolude = prev.protolude_0_3_0;
} // extraOverrides final prev;
in
postgrest.cabal
+2
View File
@@ -62,6 +62,7 @@ library
, fast-logger >= 2.4.5
, gitrev >= 1.2 && < 1.4
, hasql >= 1.4 && < 1.5
, hasql-dynamic-statements == 0.3.1
, hasql-pool >= 0.5 && < 0.6
, hasql-transaction >= 0.7.2 && < 1.1
, heredoc >= 0.2 && < 0.3
@@ -234,6 +235,7 @@ Test-Suite spec-querycost
, containers >= 0.5.7 && < 0.7
, contravariant >= 1.4 && < 1.6
, hasql >= 1.4 && < 1.5
, hasql-dynamic-statements == 0.3.1
, hasql-pool >= 0.5 && < 0.6
, hasql-transaction >= 0.7.2 && < 1.1
, heredoc >= 0.2 && < 0.3
src/PostgREST/App.hs
+16 -16
View File
@@ -119,9 +119,9 @@ app dbStructure conf apiRequest =
case responseContentTypeOrError (iAccepts apiRequest) rawContentTypes (iAction apiRequest) (iTarget apiRequest) of
Left errorResponse -> return errorResponse
Right contentType ->
case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
case (iAction apiRequest, iTarget apiRequest) of
(ActionRead headersOnly, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) ->
(ActionRead headersOnly, TargetIdent (QualifiedIdentifier tSchema tName)) ->
case readSqlParts tSchema tName of
Left errorResponse -> return errorResponse
Right (q, cq, bField, _) -> do
@@ -131,7 +131,7 @@ app dbStructure conf apiRequest =
stm = createReadStatement q cQuery (contentType == CTSingularJSON) shouldCount
(contentType == CTTextCSV) bField pgVer
explStm = createExplainStatement cq
row <- H.statement () stm
row <- H.statement mempty stm
let (tableTotal, queryTotal, _ , body, gucHeaders, gucStatus) = row
gucs = (,) <$> gucHeaders <*> gucStatus
case gucs of
@@ -155,7 +155,7 @@ app dbStructure conf apiRequest =
then errorResponseFor . singularityError $ queryTotal
else responseLBS status headers rBody
(ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->
(ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName)) ->
case mutateSqlParts tSchema tName of
Left errorResponse -> return errorResponse
Right (sq, mq) -> do
@@ -163,7 +163,7 @@ app dbStructure conf apiRequest =
stm = createWriteStatement sq mq
(contentType == CTSingularJSON) True
(contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols pgVer
row <- H.statement (toS $ pjRaw pJson) stm
row <- H.statement mempty stm
let (_, queryTotal, fields, body, gucHeaders, gucStatus) = row
gucs = (,) <$> gucHeaders <*> gucStatus
case gucs of
@@ -190,14 +190,14 @@ app dbStructure conf apiRequest =
else
return $ responseLBS status headers rBody
(ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->
(ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName)) ->
case mutateSqlParts tSchema tName of
Left errorResponse -> return errorResponse
Right (sq, mq) -> do
let stm = createWriteStatement sq mq
row <- H.statement mempty $
createWriteStatement sq mq
(contentType == CTSingularJSON) False (contentType == CTTextCSV)
(iPreferRepresentation apiRequest) [] pgVer
row <- H.statement (toS $ pjRaw pJson) stm
let (_, queryTotal, _, body, gucHeaders, gucStatus) = row
gucs = (,) <$> gucHeaders <*> gucStatus
case gucs of
@@ -221,14 +221,14 @@ app dbStructure conf apiRequest =
else
return $ responseLBS status headers rBody
(ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->
(ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName)) ->
case mutateSqlParts tSchema tName of
Left errorResponse -> return errorResponse
Right (sq, mq) ->
if topLevelRange /= allRange
then return . errorResponseFor $ PutRangeNotAllowedError
else do
row <- H.statement (toS $ pjRaw pJson) $
row <- H.statement mempty $
createWriteStatement sq mq (contentType == CTSingularJSON) False
(contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] pgVer
let (_, queryTotal, _, body, gucHeaders, gucStatus) = row
@@ -249,7 +249,7 @@ app dbStructure conf apiRequest =
else
return $ responseLBS status headers rBody
(ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) ->
(ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName)) ->
case mutateSqlParts tSchema tName of
Left errorResponse -> return errorResponse
Right (sq, mq) -> do
@@ -279,7 +279,7 @@ app dbStructure conf apiRequest =
else
return $ responseLBS status headers rBody
(ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
(ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable)) ->
let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
case mTable of
Nothing -> return notFound
@@ -288,18 +288,18 @@ app dbStructure conf apiRequest =
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header in
return $ responseLBS status200 [allOrigins, allowH] mempty
(ActionInvoke invMethod, TargetProc proc@ProcDescription{pdSchema, pdName} _, Just pJson) ->
(ActionInvoke invMethod, TargetProc proc@ProcDescription{pdSchema, pdName} _) ->
let tName = fromMaybe pdName $ procTableName proc in
case readSqlParts pdSchema tName of
Left errorResponse -> return errorResponse
Right (q, cq, bField, returning) -> do
let
preferParams = iPreferParameters apiRequest
pq = requestToCallProcQuery (QualifiedIdentifier pdSchema pdName) (specifiedProcArgs (iColumns apiRequest) proc) returnsScalar preferParams returning
pq = requestToCallProcQuery (QualifiedIdentifier pdSchema pdName) (specifiedProcArgs (iColumns apiRequest) proc) (iPayload apiRequest) returnsScalar preferParams returning
stm = callProcStatement returnsScalar pq q cq shouldCount (contentType == CTSingularJSON)
(contentType == CTTextCSV) (contentType `elem` rawContentTypes) (preferParams == Just MultipleObjects)
bField pgVer
row <- H.statement (toS $ pjRaw pJson) stm
row <- H.statement mempty stm
let (tableTotal, queryTotal, body, gucHeaders, gucStatus) = row
gucs = (,) <$> gucHeaders <*> gucStatus
case gucs of
@@ -318,7 +318,7 @@ app dbStructure conf apiRequest =
else
return $ responseLBS status headers rBody
(ActionInspect headersOnly, TargetDefaultSpec tSchema, Nothing) -> do
(ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
let host = configHost conf
port = toInteger $ configPort conf
proxy = pickProxy $ toS <$> configOpenAPIProxyUri conf
src/PostgREST/DbRequestBuilder.hs
+4 -3
View File
@@ -294,8 +294,8 @@ mutateRequest schema tName apiRequest pkCols readReq = mapLeft errorResponseFor
confCols <- case iOnConflict apiRequest of
Nothing -> pure pkCols
Just param -> pRequestOnConflict param
pure $ Insert qi (iColumns apiRequest) ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings
ActionUpdate -> Update qi (iColumns apiRequest) <$> combinedLogic <*> pure returnings
pure $ Insert qi (iColumns apiRequest) body ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings
ActionUpdate -> Update qi (iColumns apiRequest) body <$> combinedLogic <*> pure returnings
ActionSingleUpsert ->
(\flts ->
if null (iLogic apiRequest) &&
@@ -304,7 +304,7 @@ mutateRequest schema tName apiRequest pkCols readReq = mapLeft errorResponseFor
all (\case
Filter _ (OpExpr False (Op "eq" _)) -> True
_ -> False) flts
then Insert qi (iColumns apiRequest) (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
then Insert qi (iColumns apiRequest) body (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
else
Left InvalidFilters) =<< filters
ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings
@@ -322,6 +322,7 @@ mutateRequest schema tName apiRequest pkCols readReq = mapLeft errorResponseFor
-- update/delete filters can be only on the root table
(mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest)
onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)
body = pjRaw <$> iPayload apiRequest
returningCols :: ReadRequest -> [FieldName] -> [FieldName]
returningCols rr@(Node _ forest) pkCols
src/PostgREST/Private/QueryFragment.hs
+20 -15
View File
@@ -9,6 +9,7 @@ module PostgREST.Private.QueryFragment where
import qualified Data.ByteString.Char8 as BS (intercalate,
pack, unwords)
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import Data.Maybe
import qualified Data.Text as T (intercalate,
@@ -16,37 +17,41 @@ import qualified Data.Text as T (intercalate,
null, replace,
takeWhile,
toLower)
import qualified Hasql.DynamicStatements.Snippet as H
import PostgREST.Types
import Protolude hiding (cast,
intercalate, replace,
toLower)
intercalate,
replace, toLower,
toS)
import Protolude.Conv (toS)
import Text.InterpolatedString.Perl6 (qc)
import qualified Hasql.Encoders as HE
noLocationF :: SqlFragment
noLocationF = "array[]::text[]"
-- 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.
-- The error also happens on raw libpq used with C.
ignoredBody :: SqlFragment
ignoredBody = "pgrst_ignored_body AS (SELECT $1::text) "
-- |
-- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads
-- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays
-- We do this in SQL to avoid processing the JSON in application code
normalizedBody :: SqlFragment
normalizedBody =
BS.unwords [
"pgrst_payload AS (SELECT $1::json AS json_data),",
normalizedBody :: Maybe BL.ByteString -> H.Snippet
normalizedBody body =
"pgrst_payload AS (SELECT " <> jsonPlaceHolder body <> " AS json_data), " <>
H.sql (BS.unwords [
"pgrst_body AS (",
"SELECT",
"CASE WHEN json_typeof(json_data) = 'array'",
"THEN json_data",
"ELSE json_build_array(json_data)",
"END AS val",
"FROM pgrst_payload)"]
"FROM pgrst_payload)"])
-- | Equivalent to "$1::json"
-- | TODO: At this stage there shouldn't be a Maybe since ApiRequest should ensure that an INSERT/UPDATE has a body
jsonPlaceHolder :: Maybe BL.ByteString -> H.Snippet
jsonPlaceHolder body =
H.encoderAndParam (HE.nullable HE.unknown) (toS <$> body) <> "::json"
selectBody :: SqlFragment
selectBody = "(SELECT val FROM pgrst_body)"
@@ -72,7 +77,7 @@ asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
asCsvHeaderF =
"(SELECT coalesce(string_agg(a.k, ','), '')" <>
" FROM (" <>
" SELECT json_object_keys(r)::TEXT as k" <>
" SELECT json_object_keys(r)::text as k" <>
" FROM ( " <>
" SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>
" ) s" <>
src/PostgREST/QueryBuilder.hs
+33 -35
View File
@@ -22,6 +22,7 @@ module PostgREST.QueryBuilder (
import qualified Data.ByteString.Char8 as BS
import qualified Data.Set as S
import qualified Hasql.DynamicStatements.Snippet as H
import Data.Tree (Tree (..))
@@ -69,10 +70,10 @@ getJoinsSelects rr@(Node (_, (name, Just Relation{relType=relTyp,relTable=Table{
(j,sel:s)
getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], [])
mutateRequestToQuery :: MutateRequest -> SqlQuery
mutateRequestToQuery (Insert mainQi iCols onConflct putConditions returnings) =
BS.unwords [
"WITH " <> normalizedBody,
mutateRequestToQuery :: MutateRequest -> H.Snippet
mutateRequestToQuery (Insert mainQi iCols body onConflct putConditions returnings) =
"WITH " <> normalizedBody body <>
H.sql (BS.unwords [
"INSERT INTO ", fromQi mainQi, if S.null iCols then " " else "(" <> cols <> ")",
BS.unwords [
"SELECT " <> cols <> " FROM",
@@ -89,57 +90,55 @@ mutateRequestToQuery (Insert mainQi iCols onConflct putConditions returnings) =
else "DO UPDATE SET " <> BS.intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols)
) `emptyOnFalse` null oncCols) onConflct,
returningF mainQi returnings
]
])
where
cols = BS.intercalate ", " $ pgFmtIdent <$> S.toList iCols
mutateRequestToQuery (Update mainQi uCols logicForest returnings) =
mutateRequestToQuery (Update mainQi uCols body logicForest returnings) =
if S.null uCols
-- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax
-- selecting an empty resultset from mainQi gives us the column names to prevent errors when using &select=
-- the select has to be based on "returnings" to make computed overloaded functions not throw
then "WITH " <> ignoredBody <> "SELECT " <> empty_body_returned_columns <> " FROM " <> fromQi mainQi <> " WHERE false"
then H.sql ("SELECT " <> emptyBodyReturnedColumns <> " FROM " <> fromQi mainQi <> " WHERE false")
else
BS.unwords [
"WITH " <> normalizedBody,
"WITH " <> normalizedBody body <>
H.sql (BS.unwords [
"UPDATE " <> fromQi mainQi <> " SET " <> cols,
"FROM (SELECT * FROM json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ")) _ ",
("WHERE " <> BS.intercalate " AND " (pgFmtLogicTree mainQi <$> logicForest)) `emptyOnFalse` null logicForest,
returningF mainQi returnings
]
])
where
cols = BS.intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols)
empty_body_returned_columns :: SqlFragment
empty_body_returned_columns
emptyBodyReturnedColumns :: SqlFragment
emptyBodyReturnedColumns
| null returnings = "NULL"
| otherwise = BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)
mutateRequestToQuery (Delete mainQi logicForest returnings) =
BS.unwords [
"WITH " <> ignoredBody,
H.sql $ BS.unwords [
"DELETE FROM ", fromQi mainQi,
("WHERE " <> BS.intercalate " AND " (map (pgFmtLogicTree mainQi) logicForest)) `emptyOnFalse` null logicForest,
returningF mainQi returnings
]
requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Bool -> Maybe PreferParameters -> [FieldName] -> SqlQuery
requestToCallProcQuery qi pgArgs returnsScalar preferParams returnings =
BS.unwords [
"WITH",
argsCTE,
sourceBody ]
requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Maybe PayloadJSON -> Bool -> Maybe PreferParameters -> [FieldName] -> H.Snippet
requestToCallProcQuery qi pgArgs pj returnsScalar preferParams returnings =
argsCTE <> sourceBody
where
body = pjRaw <$> pj
paramsAsSingleObject = preferParams == Just SingleObject
paramsAsMultipleObjects = preferParams == Just MultipleObjects
(argsCTE, args)
| null pgArgs = (ignoredBody, "")
| paramsAsSingleObject = ("pgrst_args AS (SELECT NULL)", "$1::json")
| null pgArgs = (mempty, mempty)
| paramsAsSingleObject = ("WITH pgrst_args AS (SELECT NULL)", jsonPlaceHolder body)
| otherwise = (
"WITH " <> normalizedBody body <> ", " <>
H.sql (
BS.unwords [
normalizedBody <> ",",
"pgrst_args AS (",
"SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtArgs (const mempty) (\a -> " " <> encodeUtf8 (pgaType a)) <> ")",
")"]
, if paramsAsMultipleObjects
")"])
, H.sql $ if paramsAsMultipleObjects
then fmtArgs varadicPrefix (\a -> " := pgrst_args." <> pgFmtIdent (pgaName a))
else fmtArgs varadicPrefix (\a -> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM pgrst_args LIMIT 1)")
)
@@ -150,26 +149,25 @@ requestToCallProcQuery qi pgArgs returnsScalar preferParams returnings =
varadicPrefix :: PgArg -> SqlFragment
varadicPrefix a = if pgaVar a then "VARIADIC " else mempty
sourceBody :: SqlFragment
sourceBody :: H.Snippet
sourceBody
| paramsAsMultipleObjects =
if returnsScalar
then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args"
else BS.unwords [ "SELECT pgrst_lat_args.*"
, "FROM pgrst_args,"
, "LATERAL ( SELECT " <> returned_columns <> " FROM " <> callIt <> " ) pgrst_lat_args" ]
else "SELECT pgrst_lat_args.* FROM pgrst_args, " <>
"LATERAL ( SELECT " <> returnedColumns <> " FROM " <> callIt <> " ) pgrst_lat_args"
| otherwise =
if returnsScalar
then "SELECT " <> callIt <> " AS pgrst_scalar"
else "SELECT " <> returned_columns <> " FROM " <> callIt
else "SELECT " <> returnedColumns <> " FROM " <> callIt
callIt :: SqlFragment
callIt = fromQi qi <> "(" <> args <> ")"
callIt :: H.Snippet
callIt = H.sql (fromQi qi) <> "(" <> args <> ")"
returned_columns :: SqlFragment
returned_columns
returnedColumns :: H.Snippet
returnedColumns
| null returnings = "*"
| otherwise = BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings)
| otherwise = H.sql $ BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings)
-- | SQL query meant for COUNTing the root node of the Tree.
src/PostgREST/Statements.hs
+32 -27
View File
@@ -36,29 +36,33 @@ import Protolude hiding (cast,
import Protolude.Conv (toS)
import Text.InterpolatedString.Perl6 (qc)
import qualified Hasql.DynamicStatements.Snippet as H
import qualified Hasql.DynamicStatements.Statement as H
{-| The generic query result format used by API responses. The location header
is represented as a list of strings containing variable bindings like
@"k1=eq.42"@, or the empty list if there is no location header.
-}
type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString, Either SimpleError [GucHeader], Either SimpleError (Maybe Status))
createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
createWriteStatement :: SqlQuery -> H.Snippet -> Bool -> Bool -> Bool ->
PreferRepresentation -> [Text] -> PgVersion ->
H.Statement ByteString ResultsWithCount
H.Statement () ResultsWithCount
createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys pgVer =
H.Statement sql (param HE.unknown) decodeStandard True
H.dynamicallyParameterized snippet decodeStandard True
where
sql = [qc|
WITH
{sourceCTEName} AS ({mutateQuery})
SELECT
'' AS total_result_set,
pg_catalog.count(_postgrest_t) AS page_total,
{locF} AS header,
{bodyF} AS body,
{responseHeadersF pgVer} AS response_headers,
{responseStatusF pgVer} AS response_status
FROM ({selectF}) _postgrest_t |]
snippet =
"WITH " <> H.sql sourceCTEName <> " AS (" <> mutateQuery <> ") " <>
H.sql (
"SELECT " <>
"'' AS total_result_set, " <>
"pg_catalog.count(_postgrest_t) AS page_total, " <>
locF <> " AS header, " <>
bodyF <> " AS body, " <>
responseHeadersF pgVer <> " AS response_headers, " <>
responseStatusF pgVer <> " AS response_status " <>
"FROM (" <> selectF <> ") _postgrest_t"
)
locF =
if isInsert && rep `elem` [Full, HeadersOnly]
@@ -126,22 +130,23 @@ standardRow = (,,,,,) <$> nullableColumn HD.int8 <*> column HD.int8
type ProcResults = (Maybe Int64, Int64, ByteString, Either SimpleError [GucHeader], Either SimpleError (Maybe Status))
callProcStatement :: Bool -> SqlQuery -> SqlQuery -> SqlQuery -> Bool ->
callProcStatement :: Bool -> H.Snippet -> SqlQuery -> SqlQuery -> Bool ->
Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion ->
H.Statement ByteString ProcResults
H.Statement () ProcResults
callProcStatement returnsScalar callProcQuery selectQuery countQuery countTotal isSingle asCsv asBinary multObjects binaryField pgVer =
H.Statement sql (param HE.unknown) decodeProc True
H.dynamicallyParameterized snippet decodeProc True
where
sql = [qc|
WITH {sourceCTEName} AS ({callProcQuery})
{countCTEF}
SELECT
{countResultF} AS total_result_set,
pg_catalog.count(_postgrest_t) AS page_total,
{bodyF} AS body,
{responseHeadersF pgVer} AS response_headers,
{responseStatusF pgVer} AS response_status
FROM ({selectQuery}) _postgrest_t;|]
snippet =
"WITH " <> H.sql sourceCTEName <> " AS (" <> callProcQuery <> ") " <>
H.sql (
countCTEF <>
"SELECT " <>
countResultF <> " AS total_result_set, " <>
"pg_catalog.count(_postgrest_t) AS page_total, " <>
bodyF <> " AS body, " <>
responseHeadersF pgVer <> " AS response_headers, " <>
responseStatusF pgVer <> " AS response_status " <>
"FROM (" <> selectQuery <> ") _postgrest_t")
(countCTEF, countResultF) = countF countQuery countTotal
src/PostgREST/Types.hs
+2
View File
@@ -472,6 +472,7 @@ data MutateQuery =
Insert {
in_ :: QualifiedIdentifier
, insCols :: S.Set FieldName
, insBody :: Maybe BL.ByteString
, onConflict :: Maybe (PreferResolution, [FieldName])
, where_ :: [LogicTree]
, returning :: [FieldName]
@@ -479,6 +480,7 @@ data MutateQuery =
Update {
in_ :: QualifiedIdentifier
, updCols :: S.Set FieldName
, updBody :: Maybe BL.ByteString
, where_ :: [LogicTree]
, returning :: [FieldName]
}|
stack.yaml
+3
View File
@@ -13,3 +13,6 @@ extra-deps:
- interpolatedstring-perl6-1.0.2@sha256:7ce49c8a69a2a1b89c001ed79db2aab656ffd0faf2a7a701a553b6deb5c8ba7f,1073
- protolude-0.3.0@sha256:8361b811b420585b122a7ba715aa5923834db6e8c36309bf267df2dbf66b95ef,2693
- hasql-notifications-0.1.0.0@sha256:9ab112d2bb5da0d55abd65f0d27a7bb1dc4aeb792518d9a2ea8a16e243e19985,2156
- hasql-dynamic-statements-0.3.1@sha256:c3a2c89c4a8b3711368dbd33f0ccfe46a493faa7efc2c85d3e354c56a01dfc48,2673
- hasql-implicits-0.1.0.2@sha256:5d54e09cb779a209681b139fb3cc726bae75134557932156340cc0a56dd834a8,1361
- ptr-0.16.7.2@sha256:4a91e1342db8e627435a002798d65329a0c09c8632b2e415461b9928785327f9,2686
test/QueryCost.hs
+22 -16
View File
@@ -3,6 +3,8 @@ module Main where
import Control.Lens ((^?))
import qualified Data.Aeson.Lens as L
import qualified Hasql.Decoders as HD
import qualified Hasql.DynamicStatements.Snippet as H
import qualified Hasql.DynamicStatements.Statement as H
import qualified Hasql.Encoders as HE
import qualified Hasql.Pool as P
import qualified Hasql.Statement as H
@@ -28,49 +30,53 @@ main = do
hspec $ describe "QueryCost" $
context "call proc query" $ do
it "should not exceed cost when calling setof composite proc" $ do
cost <- exec pool [str| {"id": 3} |] $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False] False Nothing []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False]
(Just $ RawJSON [str| {"id": 3} |]) False Nothing []
liftIO $
cost `shouldSatisfy` (< Just 40)
it "should not exceed cost when calling setof composite proc with empty params" $ do
cost <- exec pool mempty $
requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] False Nothing []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] Nothing False Nothing []
liftIO $
cost `shouldSatisfy` (< Just 30)
it "should not exceed cost when calling scalar proc" $ do
cost <- exec pool [str| {"a": 3, "b": 4} |] $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False] True Nothing []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False]
(Just $ RawJSON [str| {"a": 3, "b": 4} |]) True Nothing []
liftIO $
cost `shouldSatisfy` (< Just 10)
context "params=multiple-objects" $ do
it "should not exceed cost when calling setof composite proc" $ do
cost <- exec pool [str| [{"id": 1}, {"id": 4}] |] $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False] False (Just MultipleObjects) []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False]
(Just $ RawJSON [str| [{"id": 1}, {"id": 4}] |]) False (Just MultipleObjects) []
liftIO $ do
-- lower bound needed for now to make sure that cost is not Nothing
cost `shouldSatisfy` (> Just 2000)
cost `shouldSatisfy` (< Just 2100)
it "should not exceed cost when calling scalar proc" $ do
cost <- exec pool [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |] $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False] True Nothing []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False]
(Just $ RawJSON [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |]) True Nothing []
liftIO $
cost `shouldSatisfy` (< Just 10)
exec :: P.Pool -> ByteString -> SqlQuery -> IO (Maybe Int64)
exec pool input query =
exec :: P.Pool -> H.Snippet -> IO (Maybe Int64)
exec pool query =
join . rightToMaybe <$>
P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement input $ explainCost query)
P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement mempty $ explainCost query)
explainCost :: SqlQuery -> H.Statement ByteString (Maybe Int64)
explainCost :: H.Snippet -> H.Statement () (Maybe Int64)
explainCost query =
H.Statement sql (HE.param $ HE.nonNullable HE.unknown) decodeExplain False
H.dynamicallyParameterized snippet decodeExplain False
where
sql = "EXPLAIN (FORMAT JSON) " <> query
snippet = "EXPLAIN (FORMAT JSON) " <> query
decodeExplain :: HD.Result (Maybe Int64)
decodeExplain =
let row = HD.singleRow $ HD.column $ HD.nonNullable HD.bytea in