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: # To get the sha256:
# nix-prefetch-url --unpack https://hackage.haskell.org/package/protolude-0.3.0/protolude-0.3.0.tar.gz # 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; protolude = prev.protolude_0_3_0;
} // extraOverrides final prev; } // extraOverrides final prev;
in in
postgrest.cabal
+2
View File
@@ -62,6 +62,7 @@ library
, fast-logger >= 2.4.5 , fast-logger >= 2.4.5
, gitrev >= 1.2 && < 1.4 , gitrev >= 1.2 && < 1.4
, hasql >= 1.4 && < 1.5 , hasql >= 1.4 && < 1.5
, hasql-dynamic-statements == 0.3.1
, hasql-pool >= 0.5 && < 0.6 , hasql-pool >= 0.5 && < 0.6
, hasql-transaction >= 0.7.2 && < 1.1 , hasql-transaction >= 0.7.2 && < 1.1
, heredoc >= 0.2 && < 0.3 , heredoc >= 0.2 && < 0.3
@@ -234,6 +235,7 @@ Test-Suite spec-querycost
, containers >= 0.5.7 && < 0.7 , containers >= 0.5.7 && < 0.7
, contravariant >= 1.4 && < 1.6 , contravariant >= 1.4 && < 1.6
, hasql >= 1.4 && < 1.5 , hasql >= 1.4 && < 1.5
, hasql-dynamic-statements == 0.3.1
, hasql-pool >= 0.5 && < 0.6 , hasql-pool >= 0.5 && < 0.6
, hasql-transaction >= 0.7.2 && < 1.1 , hasql-transaction >= 0.7.2 && < 1.1
, heredoc >= 0.2 && < 0.3 , 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 case responseContentTypeOrError (iAccepts apiRequest) rawContentTypes (iAction apiRequest) (iTarget apiRequest) of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right contentType -> 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 case readSqlParts tSchema tName of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (q, cq, bField, _) -> do Right (q, cq, bField, _) -> do
@@ -131,7 +131,7 @@ app dbStructure conf apiRequest =
stm = createReadStatement q cQuery (contentType == CTSingularJSON) shouldCount stm = createReadStatement q cQuery (contentType == CTSingularJSON) shouldCount
(contentType == CTTextCSV) bField pgVer (contentType == CTTextCSV) bField pgVer
explStm = createExplainStatement cq explStm = createExplainStatement cq
row <- H.statement () stm row <- H.statement mempty stm
let (tableTotal, queryTotal, _ , body, gucHeaders, gucStatus) = row let (tableTotal, queryTotal, _ , body, gucHeaders, gucStatus) = row
gucs = (,) <$> gucHeaders <*> gucStatus gucs = (,) <$> gucHeaders <*> gucStatus
case gucs of case gucs of
@@ -155,7 +155,7 @@ app dbStructure conf apiRequest =
then errorResponseFor . singularityError $ queryTotal then errorResponseFor . singularityError $ queryTotal
else responseLBS status headers rBody else responseLBS status headers rBody
(ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName)) ->
case mutateSqlParts tSchema tName of case mutateSqlParts tSchema tName of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
@@ -163,7 +163,7 @@ app dbStructure conf apiRequest =
stm = createWriteStatement sq mq stm = createWriteStatement sq mq
(contentType == CTSingularJSON) True (contentType == CTSingularJSON) True
(contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols pgVer (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 let (_, queryTotal, fields, body, gucHeaders, gucStatus) = row
gucs = (,) <$> gucHeaders <*> gucStatus gucs = (,) <$> gucHeaders <*> gucStatus
case gucs of case gucs of
@@ -190,14 +190,14 @@ app dbStructure conf apiRequest =
else else
return $ responseLBS status headers rBody return $ responseLBS status headers rBody
(ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName)) ->
case mutateSqlParts tSchema tName of case mutateSqlParts tSchema tName of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
let stm = createWriteStatement sq mq row <- H.statement mempty $
(contentType == CTSingularJSON) False (contentType == CTTextCSV) createWriteStatement sq mq
(iPreferRepresentation apiRequest) [] pgVer (contentType == CTSingularJSON) False (contentType == CTTextCSV)
row <- H.statement (toS $ pjRaw pJson) stm (iPreferRepresentation apiRequest) [] pgVer
let (_, queryTotal, _, body, gucHeaders, gucStatus) = row let (_, queryTotal, _, body, gucHeaders, gucStatus) = row
gucs = (,) <$> gucHeaders <*> gucStatus gucs = (,) <$> gucHeaders <*> gucStatus
case gucs of case gucs of
@@ -221,14 +221,14 @@ app dbStructure conf apiRequest =
else else
return $ responseLBS status headers rBody return $ responseLBS status headers rBody
(ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName)) ->
case mutateSqlParts tSchema tName of case mutateSqlParts tSchema tName of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (sq, mq) -> Right (sq, mq) ->
if topLevelRange /= allRange if topLevelRange /= allRange
then return . errorResponseFor $ PutRangeNotAllowedError then return . errorResponseFor $ PutRangeNotAllowedError
else do else do
row <- H.statement (toS $ pjRaw pJson) $ row <- H.statement mempty $
createWriteStatement sq mq (contentType == CTSingularJSON) False createWriteStatement sq mq (contentType == CTSingularJSON) False
(contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] pgVer (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] pgVer
let (_, queryTotal, _, body, gucHeaders, gucStatus) = row let (_, queryTotal, _, body, gucHeaders, gucStatus) = row
@@ -249,7 +249,7 @@ app dbStructure conf apiRequest =
else else
return $ responseLBS status headers rBody return $ responseLBS status headers rBody
(ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) -> (ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName)) ->
case mutateSqlParts tSchema tName of case mutateSqlParts tSchema tName of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
@@ -279,7 +279,7 @@ app dbStructure conf apiRequest =
else else
return $ responseLBS status headers rBody 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 let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
case mTable of case mTable of
Nothing -> return notFound Nothing -> return notFound
@@ -288,18 +288,18 @@ app dbStructure conf apiRequest =
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header in allOrigins = ("Access-Control-Allow-Origin", "*") :: Header in
return $ responseLBS status200 [allOrigins, allowH] mempty 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 let tName = fromMaybe pdName $ procTableName proc in
case readSqlParts pdSchema tName of case readSqlParts pdSchema tName of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (q, cq, bField, returning) -> do Right (q, cq, bField, returning) -> do
let let
preferParams = iPreferParameters apiRequest 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) stm = callProcStatement returnsScalar pq q cq shouldCount (contentType == CTSingularJSON)
(contentType == CTTextCSV) (contentType `elem` rawContentTypes) (preferParams == Just MultipleObjects) (contentType == CTTextCSV) (contentType `elem` rawContentTypes) (preferParams == Just MultipleObjects)
bField pgVer bField pgVer
row <- H.statement (toS $ pjRaw pJson) stm row <- H.statement mempty stm
let (tableTotal, queryTotal, body, gucHeaders, gucStatus) = row let (tableTotal, queryTotal, body, gucHeaders, gucStatus) = row
gucs = (,) <$> gucHeaders <*> gucStatus gucs = (,) <$> gucHeaders <*> gucStatus
case gucs of case gucs of
@@ -318,7 +318,7 @@ app dbStructure conf apiRequest =
else else
return $ responseLBS status headers rBody return $ responseLBS status headers rBody
(ActionInspect headersOnly, TargetDefaultSpec tSchema, Nothing) -> do (ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
let host = configHost conf let host = configHost conf
port = toInteger $ configPort conf port = toInteger $ configPort conf
proxy = pickProxy $ toS <$> configOpenAPIProxyUri 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 confCols <- case iOnConflict apiRequest of
Nothing -> pure pkCols Nothing -> pure pkCols
Just param -> pRequestOnConflict param Just param -> pRequestOnConflict param
pure $ Insert qi (iColumns apiRequest) ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings pure $ Insert qi (iColumns apiRequest) body ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings
ActionUpdate -> Update qi (iColumns apiRequest) <$> combinedLogic <*> pure returnings ActionUpdate -> Update qi (iColumns apiRequest) body <$> combinedLogic <*> pure returnings
ActionSingleUpsert -> ActionSingleUpsert ->
(\flts -> (\flts ->
if null (iLogic apiRequest) && if null (iLogic apiRequest) &&
@@ -304,7 +304,7 @@ mutateRequest schema tName apiRequest pkCols readReq = mapLeft errorResponseFor
all (\case all (\case
Filter _ (OpExpr False (Op "eq" _)) -> True Filter _ (OpExpr False (Op "eq" _)) -> True
_ -> False) flts _ -> 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 else
Left InvalidFilters) =<< filters Left InvalidFilters) =<< filters
ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings 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 -- update/delete filters can be only on the root table
(mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest) (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest)
onlyRoot = filter (not . ( "." `isInfixOf` ) . fst) onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)
body = pjRaw <$> iPayload apiRequest
returningCols :: ReadRequest -> [FieldName] -> [FieldName] returningCols :: ReadRequest -> [FieldName] -> [FieldName]
returningCols rr@(Node _ forest) pkCols 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 module PostgREST.Private.QueryFragment where
import qualified Data.ByteString.Char8 as BS (intercalate, import qualified Data.ByteString.Char8 as BS (intercalate,
pack, unwords) pack, unwords)
import qualified Data.HashMap.Strict as HM import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import Data.Maybe import Data.Maybe
import qualified Data.Text as T (intercalate, import qualified Data.Text as T (intercalate,
isInfixOf, map, isInfixOf, map,
null, replace, null, replace,
takeWhile, takeWhile,
toLower) toLower)
import qualified Hasql.DynamicStatements.Snippet as H
import PostgREST.Types import PostgREST.Types
import Protolude hiding (cast, import Protolude hiding (cast,
intercalate, replace, intercalate,
toLower) replace, toLower,
import Text.InterpolatedString.Perl6 (qc) toS)
import Protolude.Conv (toS)
import Text.InterpolatedString.Perl6 (qc)
import qualified Hasql.Encoders as HE
noLocationF :: SqlFragment noLocationF :: SqlFragment
noLocationF = "array[]::text[]" 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 -- 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 -- 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 -- We do this in SQL to avoid processing the JSON in application code
normalizedBody :: SqlFragment normalizedBody :: Maybe BL.ByteString -> H.Snippet
normalizedBody = normalizedBody body =
BS.unwords [ "pgrst_payload AS (SELECT " <> jsonPlaceHolder body <> " AS json_data), " <>
"pgrst_payload AS (SELECT $1::json AS json_data),", H.sql (BS.unwords [
"pgrst_body AS (", "pgrst_body AS (",
"SELECT", "SELECT",
"CASE WHEN json_typeof(json_data) = 'array'", "CASE WHEN json_typeof(json_data) = 'array'",
"THEN json_data", "THEN json_data",
"ELSE json_build_array(json_data)", "ELSE json_build_array(json_data)",
"END AS val", "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 :: SqlFragment
selectBody = "(SELECT val FROM pgrst_body)" selectBody = "(SELECT val FROM pgrst_body)"
@@ -72,7 +77,7 @@ asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
asCsvHeaderF = asCsvHeaderF =
"(SELECT coalesce(string_agg(a.k, ','), '')" <> "(SELECT coalesce(string_agg(a.k, ','), '')" <>
" FROM (" <> " FROM (" <>
" SELECT json_object_keys(r)::TEXT as k" <> " SELECT json_object_keys(r)::text as k" <>
" FROM ( " <> " FROM ( " <>
" SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <> " SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>
" ) s" <> " ) s" <>
src/PostgREST/QueryBuilder.hs
+36 -38
View File
@@ -20,8 +20,9 @@ module PostgREST.QueryBuilder (
, setLocalSearchPathQuery , setLocalSearchPathQuery
) where ) where
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import qualified Data.Set as S import qualified Data.Set as S
import qualified Hasql.DynamicStatements.Snippet as H
import Data.Tree (Tree (..)) import Data.Tree (Tree (..))
@@ -69,10 +70,10 @@ getJoinsSelects rr@(Node (_, (name, Just Relation{relType=relTyp,relTable=Table{
(j,sel:s) (j,sel:s)
getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], []) getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], [])
mutateRequestToQuery :: MutateRequest -> SqlQuery mutateRequestToQuery :: MutateRequest -> H.Snippet
mutateRequestToQuery (Insert mainQi iCols onConflct putConditions returnings) = mutateRequestToQuery (Insert mainQi iCols body onConflct putConditions returnings) =
BS.unwords [ "WITH " <> normalizedBody body <>
"WITH " <> normalizedBody, H.sql (BS.unwords [
"INSERT INTO ", fromQi mainQi, if S.null iCols then " " else "(" <> cols <> ")", "INSERT INTO ", fromQi mainQi, if S.null iCols then " " else "(" <> cols <> ")",
BS.unwords [ BS.unwords [
"SELECT " <> cols <> " FROM", "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) else "DO UPDATE SET " <> BS.intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols)
) `emptyOnFalse` null oncCols) onConflct, ) `emptyOnFalse` null oncCols) onConflct,
returningF mainQi returnings returningF mainQi returnings
] ])
where where
cols = BS.intercalate ", " $ pgFmtIdent <$> S.toList iCols 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 S.null uCols
-- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax -- 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= -- 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 -- 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 else
BS.unwords [ "WITH " <> normalizedBody body <>
"WITH " <> normalizedBody, H.sql (BS.unwords [
"UPDATE " <> fromQi mainQi <> " SET " <> cols, "UPDATE " <> fromQi mainQi <> " SET " <> cols,
"FROM (SELECT * FROM json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ")) _ ", "FROM (SELECT * FROM json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ")) _ ",
("WHERE " <> BS.intercalate " AND " (pgFmtLogicTree mainQi <$> logicForest)) `emptyOnFalse` null logicForest, ("WHERE " <> BS.intercalate " AND " (pgFmtLogicTree mainQi <$> logicForest)) `emptyOnFalse` null logicForest,
returningF mainQi returnings returningF mainQi returnings
] ])
where where
cols = BS.intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols) cols = BS.intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols)
empty_body_returned_columns :: SqlFragment emptyBodyReturnedColumns :: SqlFragment
empty_body_returned_columns emptyBodyReturnedColumns
| null returnings = "NULL" | null returnings = "NULL"
| otherwise = BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings) | otherwise = BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)
mutateRequestToQuery (Delete mainQi logicForest returnings) = mutateRequestToQuery (Delete mainQi logicForest returnings) =
BS.unwords [ H.sql $ BS.unwords [
"WITH " <> ignoredBody,
"DELETE FROM ", fromQi mainQi, "DELETE FROM ", fromQi mainQi,
("WHERE " <> BS.intercalate " AND " (map (pgFmtLogicTree mainQi) logicForest)) `emptyOnFalse` null logicForest, ("WHERE " <> BS.intercalate " AND " (map (pgFmtLogicTree mainQi) logicForest)) `emptyOnFalse` null logicForest,
returningF mainQi returnings returningF mainQi returnings
] ]
requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Bool -> Maybe PreferParameters -> [FieldName] -> SqlQuery requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Maybe PayloadJSON -> Bool -> Maybe PreferParameters -> [FieldName] -> H.Snippet
requestToCallProcQuery qi pgArgs returnsScalar preferParams returnings = requestToCallProcQuery qi pgArgs pj returnsScalar preferParams returnings =
BS.unwords [ argsCTE <> sourceBody
"WITH",
argsCTE,
sourceBody ]
where where
body = pjRaw <$> pj
paramsAsSingleObject = preferParams == Just SingleObject paramsAsSingleObject = preferParams == Just SingleObject
paramsAsMultipleObjects = preferParams == Just MultipleObjects paramsAsMultipleObjects = preferParams == Just MultipleObjects
(argsCTE, args) (argsCTE, args)
| null pgArgs = (ignoredBody, "") | null pgArgs = (mempty, mempty)
| paramsAsSingleObject = ("pgrst_args AS (SELECT NULL)", "$1::json") | paramsAsSingleObject = ("WITH pgrst_args AS (SELECT NULL)", jsonPlaceHolder body)
| otherwise = ( | otherwise = (
BS.unwords [ "WITH " <> normalizedBody body <> ", " <>
normalizedBody <> ",", H.sql (
BS.unwords [
"pgrst_args AS (", "pgrst_args AS (",
"SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtArgs (const mempty) (\a -> " " <> encodeUtf8 (pgaType a)) <> ")", "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)) then fmtArgs varadicPrefix (\a -> " := pgrst_args." <> pgFmtIdent (pgaName a))
else fmtArgs varadicPrefix (\a -> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM pgrst_args LIMIT 1)") 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 :: PgArg -> SqlFragment
varadicPrefix a = if pgaVar a then "VARIADIC " else mempty varadicPrefix a = if pgaVar a then "VARIADIC " else mempty
sourceBody :: SqlFragment sourceBody :: H.Snippet
sourceBody sourceBody
| paramsAsMultipleObjects = | paramsAsMultipleObjects =
if returnsScalar if returnsScalar
then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args" then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args"
else BS.unwords [ "SELECT pgrst_lat_args.*" else "SELECT pgrst_lat_args.* FROM pgrst_args, " <>
, "FROM pgrst_args," "LATERAL ( SELECT " <> returnedColumns <> " FROM " <> callIt <> " ) pgrst_lat_args"
, "LATERAL ( SELECT " <> returned_columns <> " FROM " <> callIt <> " ) pgrst_lat_args" ]
| otherwise = | otherwise =
if returnsScalar if returnsScalar
then "SELECT " <> callIt <> " AS pgrst_scalar" then "SELECT " <> callIt <> " AS pgrst_scalar"
else "SELECT " <> returned_columns <> " FROM " <> callIt else "SELECT " <> returnedColumns <> " FROM " <> callIt
callIt :: SqlFragment callIt :: H.Snippet
callIt = fromQi qi <> "(" <> args <> ")" callIt = H.sql (fromQi qi) <> "(" <> args <> ")"
returned_columns :: SqlFragment returnedColumns :: H.Snippet
returned_columns returnedColumns
| null returnings = "*" | 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. -- | 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 Protolude.Conv (toS)
import Text.InterpolatedString.Perl6 (qc) 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 {-| The generic query result format used by API responses. The location header
is represented as a list of strings containing variable bindings like is represented as a list of strings containing variable bindings like
@"k1=eq.42"@, or the empty list if there is no location header. @"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)) 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 -> PreferRepresentation -> [Text] -> PgVersion ->
H.Statement ByteString ResultsWithCount H.Statement () ResultsWithCount
createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys pgVer = createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys pgVer =
H.Statement sql (param HE.unknown) decodeStandard True H.dynamicallyParameterized snippet decodeStandard True
where where
sql = [qc| snippet =
WITH "WITH " <> H.sql sourceCTEName <> " AS (" <> mutateQuery <> ") " <>
{sourceCTEName} AS ({mutateQuery}) H.sql (
SELECT "SELECT " <>
'' AS total_result_set, "'' AS total_result_set, " <>
pg_catalog.count(_postgrest_t) AS page_total, "pg_catalog.count(_postgrest_t) AS page_total, " <>
{locF} AS header, locF <> " AS header, " <>
{bodyF} AS body, bodyF <> " AS body, " <>
{responseHeadersF pgVer} AS response_headers, responseHeadersF pgVer <> " AS response_headers, " <>
{responseStatusF pgVer} AS response_status responseStatusF pgVer <> " AS response_status " <>
FROM ({selectF}) _postgrest_t |] "FROM (" <> selectF <> ") _postgrest_t"
)
locF = locF =
if isInsert && rep `elem` [Full, HeadersOnly] 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)) 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 -> 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 = 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 where
sql = [qc| snippet =
WITH {sourceCTEName} AS ({callProcQuery}) "WITH " <> H.sql sourceCTEName <> " AS (" <> callProcQuery <> ") " <>
{countCTEF} H.sql (
SELECT countCTEF <>
{countResultF} AS total_result_set, "SELECT " <>
pg_catalog.count(_postgrest_t) AS page_total, countResultF <> " AS total_result_set, " <>
{bodyF} AS body, "pg_catalog.count(_postgrest_t) AS page_total, " <>
{responseHeadersF pgVer} AS response_headers, bodyF <> " AS body, " <>
{responseStatusF pgVer} AS response_status responseHeadersF pgVer <> " AS response_headers, " <>
FROM ({selectQuery}) _postgrest_t;|] responseStatusF pgVer <> " AS response_status " <>
"FROM (" <> selectQuery <> ") _postgrest_t")
(countCTEF, countResultF) = countF countQuery countTotal (countCTEF, countResultF) = countF countQuery countTotal
src/PostgREST/Types.hs
+2
View File
@@ -472,6 +472,7 @@ data MutateQuery =
Insert { Insert {
in_ :: QualifiedIdentifier in_ :: QualifiedIdentifier
, insCols :: S.Set FieldName , insCols :: S.Set FieldName
, insBody :: Maybe BL.ByteString
, onConflict :: Maybe (PreferResolution, [FieldName]) , onConflict :: Maybe (PreferResolution, [FieldName])
, where_ :: [LogicTree] , where_ :: [LogicTree]
, returning :: [FieldName] , returning :: [FieldName]
@@ -479,6 +480,7 @@ data MutateQuery =
Update { Update {
in_ :: QualifiedIdentifier in_ :: QualifiedIdentifier
, updCols :: S.Set FieldName , updCols :: S.Set FieldName
, updBody :: Maybe BL.ByteString
, where_ :: [LogicTree] , where_ :: [LogicTree]
, returning :: [FieldName] , returning :: [FieldName]
}| }|
stack.yaml
+3
View File
@@ -13,3 +13,6 @@ extra-deps:
- interpolatedstring-perl6-1.0.2@sha256:7ce49c8a69a2a1b89c001ed79db2aab656ffd0faf2a7a701a553b6deb5c8ba7f,1073 - interpolatedstring-perl6-1.0.2@sha256:7ce49c8a69a2a1b89c001ed79db2aab656ffd0faf2a7a701a553b6deb5c8ba7f,1073
- protolude-0.3.0@sha256:8361b811b420585b122a7ba715aa5923834db6e8c36309bf267df2dbf66b95ef,2693 - protolude-0.3.0@sha256:8361b811b420585b122a7ba715aa5923834db6e8c36309bf267df2dbf66b95ef,2693
- hasql-notifications-0.1.0.0@sha256:9ab112d2bb5da0d55abd65f0d27a7bb1dc4aeb792518d9a2ea8a16e243e19985,2156 - 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 module Main where
import Control.Lens ((^?)) import Control.Lens ((^?))
import qualified Data.Aeson.Lens as L import qualified Data.Aeson.Lens as L
import qualified Hasql.Decoders as HD import qualified Hasql.Decoders as HD
import qualified Hasql.Encoders as HE import qualified Hasql.DynamicStatements.Snippet as H
import qualified Hasql.Pool as P import qualified Hasql.DynamicStatements.Statement as H
import qualified Hasql.Statement as H import qualified Hasql.Encoders as HE
import qualified Hasql.Transaction as HT import qualified Hasql.Pool as P
import qualified Hasql.Transaction.Sessions as HT import qualified Hasql.Statement as H
import qualified Hasql.Transaction as HT
import qualified Hasql.Transaction.Sessions as HT
import Text.Heredoc import Text.Heredoc
import Protolude hiding (get, toS) import Protolude hiding (get, toS)
@@ -28,49 +30,53 @@ main = do
hspec $ describe "QueryCost" $ hspec $ describe "QueryCost" $
context "call proc query" $ do context "call proc query" $ do
it "should not exceed cost when calling setof composite proc" $ do it "should not exceed cost when calling setof composite proc" $ do
cost <- exec pool [str| {"id": 3} |] $ cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False] False Nothing [] requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False]
(Just $ RawJSON [str| {"id": 3} |]) False Nothing []
liftIO $ liftIO $
cost `shouldSatisfy` (< Just 40) cost `shouldSatisfy` (< Just 40)
it "should not exceed cost when calling setof composite proc with empty params" $ do it "should not exceed cost when calling setof composite proc with empty params" $ do
cost <- exec pool mempty $ cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] False Nothing [] requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] Nothing False Nothing []
liftIO $ liftIO $
cost `shouldSatisfy` (< Just 30) cost `shouldSatisfy` (< Just 30)
it "should not exceed cost when calling scalar proc" $ do it "should not exceed cost when calling scalar proc" $ do
cost <- exec pool [str| {"a": 3, "b": 4} |] $ cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False] True Nothing [] 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 $ liftIO $
cost `shouldSatisfy` (< Just 10) cost `shouldSatisfy` (< Just 10)
context "params=multiple-objects" $ do context "params=multiple-objects" $ do
it "should not exceed cost when calling setof composite proc" $ do it "should not exceed cost when calling setof composite proc" $ do
cost <- exec pool [str| [{"id": 1}, {"id": 4}] |] $ cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False] False (Just MultipleObjects) [] requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False]
(Just $ RawJSON [str| [{"id": 1}, {"id": 4}] |]) False (Just MultipleObjects) []
liftIO $ do liftIO $ do
-- lower bound needed for now to make sure that cost is not Nothing -- lower bound needed for now to make sure that cost is not Nothing
cost `shouldSatisfy` (> Just 2000) cost `shouldSatisfy` (> Just 2000)
cost `shouldSatisfy` (< Just 2100) cost `shouldSatisfy` (< Just 2100)
it "should not exceed cost when calling scalar proc" $ do 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}] |] $ cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False] True Nothing [] 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 $ liftIO $
cost `shouldSatisfy` (< Just 10) cost `shouldSatisfy` (< Just 10)
exec :: P.Pool -> ByteString -> SqlQuery -> IO (Maybe Int64) exec :: P.Pool -> H.Snippet -> IO (Maybe Int64)
exec pool input query = exec pool query =
join . rightToMaybe <$> 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 = explainCost query =
H.Statement sql (HE.param $ HE.nonNullable HE.unknown) decodeExplain False H.dynamicallyParameterized snippet decodeExplain False
where where
sql = "EXPLAIN (FORMAT JSON) " <> query snippet = "EXPLAIN (FORMAT JSON) " <> query
decodeExplain :: HD.Result (Maybe Int64) decodeExplain :: HD.Result (Maybe Int64)
decodeExplain = decodeExplain =
let row = HD.singleRow $ HD.column $ HD.nonNullable HD.bytea in let row = HD.singleRow $ HD.column $ HD.nonNullable HD.bytea in