diff --git a/nix/overlays/haskell-packages.nix b/nix/overlays/haskell-packages.nix index 591f44b51..d5146eb8a 100644 --- a/nix/overlays/haskell-packages.nix +++ b/nix/overlays/haskell-packages.nix @@ -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 diff --git a/postgrest.cabal b/postgrest.cabal index 787339f88..db223f162 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 03f9d0afb..6f10336c4 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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 diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs index b9cd3b804..28eb2a635 100644 --- a/src/PostgREST/DbRequestBuilder.hs +++ b/src/PostgREST/DbRequestBuilder.hs @@ -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 diff --git a/src/PostgREST/Private/QueryFragment.hs b/src/PostgREST/Private/QueryFragment.hs index 349c83e41..737eaa5e2 100644 --- a/src/PostgREST/Private/QueryFragment.hs +++ b/src/PostgREST/Private/QueryFragment.hs @@ -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" <> diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 006ea5d6a..22983f9b7 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -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. diff --git a/src/PostgREST/Statements.hs b/src/PostgREST/Statements.hs index 3acdd7419..597b4b21f 100644 --- a/src/PostgREST/Statements.hs +++ b/src/PostgREST/Statements.hs @@ -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 diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index c8c6355fd..61dbeda7a 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -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] }| diff --git a/stack.yaml b/stack.yaml index e2afa9718..975ca4ad0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/test/QueryCost.hs b/test/QueryCost.hs index cffaeeec6..fd1f41cd5 100644 --- a/test/QueryCost.hs +++ b/test/QueryCost.hs @@ -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