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
+18 -18
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
(contentType == CTSingularJSON) False (contentType == CTTextCSV)
(iPreferRepresentation apiRequest) [] pgVer
row <- H.statement (toS $ pjRaw pJson) stm
row <- H.statement mempty $
createWriteStatement sq mq
(contentType == CTSingularJSON) False (contentType == CTTextCSV)
(iPreferRepresentation apiRequest) [] pgVer
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
+30 -25
View File
@@ -7,46 +7,51 @@ Any function that outputs a SqlFragment should be in this module.
-}
module PostgREST.Private.QueryFragment where
import qualified Data.ByteString.Char8 as BS (intercalate,
pack, unwords)
import qualified Data.HashMap.Strict as HM
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,
isInfixOf, map,
null, replace,
takeWhile,
toLower)
import qualified Data.Text as T (intercalate,
isInfixOf, map,
null, replace,
takeWhile,
toLower)
import qualified Hasql.DynamicStatements.Snippet as H
import PostgREST.Types
import Protolude hiding (cast,
intercalate, replace,
toLower)
import Text.InterpolatedString.Perl6 (qc)
import Protolude hiding (cast,
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
+36 -38
View File
@@ -20,8 +20,9 @@ module PostgREST.QueryBuilder (
, setLocalSearchPathQuery
) where
import qualified Data.ByteString.Char8 as BS
import qualified Data.Set as S
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 = (
BS.unwords [
normalizedBody <> ",",
"WITH " <> normalizedBody body <> ", " <>
H.sql (
BS.unwords [
"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
+30 -24
View File
@@ -1,13 +1,15 @@
module Main where
import Control.Lens ((^?))
import qualified Data.Aeson.Lens as L
import qualified Hasql.Decoders as HD
import qualified Hasql.Encoders as HE
import qualified Hasql.Pool as P
import qualified Hasql.Statement as H
import qualified Hasql.Transaction as HT
import qualified Hasql.Transaction.Sessions as HT
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
import qualified Hasql.Transaction as HT
import qualified Hasql.Transaction.Sessions as HT
import Text.Heredoc
import Protolude hiding (get, toS)
@@ -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