refactor: Use hasql-dynamic on RPC/POST/PUT/PATCH
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:
committed by
Steve Chavez
parent
b13e95aefb
commit
8e58b56d5c
+18
-18
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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" <>
|
||||
|
||||
@@ -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.
|
||||
|
||||
+32
-27
@@ -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
|
||||
|
||||
|
||||
@@ -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]
|
||||
}|
|
||||
|
||||
Reference in New Issue
Block a user