refactor: Split up Types.hs and logically organize modules (#1793)
This commit is contained in:
Remo Rechkemmer
@@ -0,0 +1,181 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-|
|
||||
Module : PostgREST.Query.QueryBuilder
|
||||
Description : PostgREST SQL queries generating functions.
|
||||
|
||||
This module provides functions to consume data types that
|
||||
represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment
|
||||
to produce SqlQuery type outputs.
|
||||
-}
|
||||
module PostgREST.Query.QueryBuilder
|
||||
( readRequestToQuery
|
||||
, mutateRequestToQuery
|
||||
, readRequestToCountQuery
|
||||
, requestToCallProcQuery
|
||||
, limitedQuery
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Set as S
|
||||
import qualified Hasql.DynamicStatements.Snippet as H
|
||||
|
||||
import Data.Tree (Tree (..))
|
||||
|
||||
import PostgREST.DbStructure.Identifiers (FieldName,
|
||||
QualifiedIdentifier (..))
|
||||
import PostgREST.DbStructure.Proc (PgArg (..))
|
||||
import PostgREST.DbStructure.Relation (Cardinality (..),
|
||||
Relation (..))
|
||||
import PostgREST.DbStructure.Table (Table (..))
|
||||
import PostgREST.Request.ApiRequest (PayloadJSON (..))
|
||||
import PostgREST.Request.Preferences (PreferParameters (..),
|
||||
PreferResolution (..))
|
||||
|
||||
import PostgREST.Query.SqlFragment
|
||||
import PostgREST.Request.Types
|
||||
|
||||
import Protolude
|
||||
|
||||
readRequestToQuery :: ReadRequest -> H.Snippet
|
||||
readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) =
|
||||
"SELECT " <>
|
||||
intercalateSnippet ", " ((pgFmtSelectItem qi <$> colSelects) ++ selects) <>
|
||||
"FROM " <> H.sql (BS.intercalate ", " (tabl : implJs)) <> " " <>
|
||||
intercalateSnippet " " joins <> " " <>
|
||||
(if null logicForest && null joinConditions_ then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConditions_))
|
||||
<> " " <>
|
||||
(if null ordts then mempty else "ORDER BY " <> intercalateSnippet ", " (map (pgFmtOrderTerm qi) ordts)) <> " " <>
|
||||
limitOffsetF range
|
||||
where
|
||||
implJs = fromQi <$> implJoins
|
||||
tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias
|
||||
qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias
|
||||
(joins, selects) = foldr getJoinsSelects ([],[]) forest
|
||||
|
||||
getJoinsSelects :: ReadRequest -> ([H.Snippet], [H.Snippet]) -> ([H.Snippet], [H.Snippet])
|
||||
getJoinsSelects rr@(Node (_, (name, Just Relation{relType=relTyp,relTable=Table{tableName=table}}, alias, _, _)) _) (j,s) =
|
||||
let subquery = readRequestToQuery rr in
|
||||
case relTyp of
|
||||
M2O ->
|
||||
let aliasOrName = fromMaybe name alias
|
||||
localTableName = pgFmtIdent $ table <> "_" <> aliasOrName
|
||||
sel = H.sql ("row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName)
|
||||
joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> H.sql localTableName <> " ON TRUE " in
|
||||
(joi:j,sel:s)
|
||||
_ ->
|
||||
let sel = "COALESCE (("
|
||||
<> "SELECT json_agg(" <> H.sql (pgFmtIdent table) <> ".*) "
|
||||
<> "FROM (" <> subquery <> ") " <> H.sql (pgFmtIdent table) <> " "
|
||||
<> "), '[]') AS " <> H.sql (pgFmtIdent (fromMaybe name alias)) in
|
||||
(j,sel:s)
|
||||
getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], [])
|
||||
|
||||
mutateRequestToQuery :: MutateRequest -> H.Snippet
|
||||
mutateRequestToQuery (Insert mainQi iCols body onConflct putConditions returnings) =
|
||||
"WITH " <> normalizedBody body <> " " <>
|
||||
"INSERT INTO " <> H.sql (fromQi mainQi) <> H.sql (if S.null iCols then " " else "(" <> cols <> ") ") <>
|
||||
"SELECT " <> H.sql cols <> " " <>
|
||||
H.sql ("FROM json_populate_recordset (null::" <> fromQi mainQi <> ", " <> selectBody <> ") _ ") <>
|
||||
-- Only used for PUT
|
||||
(if null putConditions then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "_") <$> putConditions)) <>
|
||||
H.sql (BS.unwords [
|
||||
maybe "" (\(oncDo, oncCols) ->
|
||||
if null oncCols then
|
||||
mempty
|
||||
else
|
||||
"ON CONFLICT(" <> BS.intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of
|
||||
IgnoreDuplicates ->
|
||||
"DO NOTHING"
|
||||
MergeDuplicates ->
|
||||
if S.null iCols
|
||||
then "DO NOTHING"
|
||||
else "DO UPDATE SET " <> BS.intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols)
|
||||
) onConflct,
|
||||
returningF mainQi returnings
|
||||
])
|
||||
where
|
||||
cols = BS.intercalate ", " $ pgFmtIdent <$> S.toList iCols
|
||||
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 H.sql ("SELECT " <> emptyBodyReturnedColumns <> " FROM " <> fromQi mainQi <> " WHERE false")
|
||||
else
|
||||
"WITH " <> normalizedBody body <> " " <>
|
||||
"UPDATE " <> H.sql (fromQi mainQi) <> " SET " <> H.sql cols <> " " <>
|
||||
"FROM (SELECT * FROM json_populate_recordset (null::" <> H.sql (fromQi mainQi) <> " , " <> H.sql selectBody <> " )) _ " <>
|
||||
(if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)) <> " " <>
|
||||
H.sql (returningF mainQi returnings)
|
||||
where
|
||||
cols = BS.intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols)
|
||||
emptyBodyReturnedColumns :: SqlFragment
|
||||
emptyBodyReturnedColumns
|
||||
| null returnings = "NULL"
|
||||
| otherwise = BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)
|
||||
mutateRequestToQuery (Delete mainQi logicForest returnings) =
|
||||
"DELETE FROM " <> H.sql (fromQi mainQi) <> " " <>
|
||||
(if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree mainQi) logicForest)) <> " " <>
|
||||
H.sql (returningF mainQi returnings)
|
||||
|
||||
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 = (mempty, mempty)
|
||||
| paramsAsSingleObject = ("WITH pgrst_args AS (SELECT NULL)", jsonPlaceHolder body)
|
||||
| otherwise = (
|
||||
"WITH " <> normalizedBody body <> ", " <>
|
||||
H.sql (
|
||||
BS.unwords [
|
||||
"pgrst_args AS (",
|
||||
"SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtArgs (const mempty) (\a -> " " <> encodeUtf8 (pgaType a)) <> ")",
|
||||
")"])
|
||||
, 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)")
|
||||
)
|
||||
|
||||
fmtArgs :: (PgArg -> SqlFragment) -> (PgArg -> SqlFragment) -> SqlFragment
|
||||
fmtArgs argFragPre argFragSuf = BS.intercalate ", " ((\a -> argFragPre a <> pgFmtIdent (pgaName a) <> argFragSuf a) <$> pgArgs)
|
||||
|
||||
varadicPrefix :: PgArg -> SqlFragment
|
||||
varadicPrefix a = if pgaVar a then "VARIADIC " else mempty
|
||||
|
||||
sourceBody :: H.Snippet
|
||||
sourceBody
|
||||
| paramsAsMultipleObjects =
|
||||
if returnsScalar
|
||||
then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_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 " <> returnedColumns <> " FROM " <> callIt
|
||||
|
||||
callIt :: H.Snippet
|
||||
callIt = H.sql (fromQi qi) <> "(" <> args <> ")"
|
||||
|
||||
returnedColumns :: H.Snippet
|
||||
returnedColumns
|
||||
| null returnings = "*"
|
||||
| otherwise = H.sql $ BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings)
|
||||
|
||||
|
||||
-- | SQL query meant for COUNTing the root node of the Tree.
|
||||
-- It only takes WHERE into account and doesn't include LIMIT/OFFSET because it would reduce the COUNT.
|
||||
-- SELECT 1 is done instead of SELECT * to prevent doing expensive operations(like functions based on the columns)
|
||||
-- inside the FROM target.
|
||||
readRequestToCountQuery :: ReadRequest -> H.Snippet
|
||||
readRequestToCountQuery (Node (Select{from=qi, where_=logicForest}, _) _) =
|
||||
"SELECT 1 " <> "FROM " <> H.sql (fromQi qi) <> " " <>
|
||||
if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest)
|
||||
|
||||
limitedQuery :: H.Snippet -> Maybe Integer -> H.Snippet
|
||||
limitedQuery query maxRows = query <> H.sql (maybe mempty (\x -> " LIMIT " <> BS.pack (show x)) maxRows)
|
||||
@@ -0,0 +1,321 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-|
|
||||
Module : PostgREST.Query.SqlFragment
|
||||
Description : Helper functions for PostgREST.QueryBuilder.
|
||||
|
||||
Any function that outputs a SqlFragment should be in this module.
|
||||
-}
|
||||
module PostgREST.Query.SqlFragment
|
||||
( noLocationF
|
||||
, SqlFragment
|
||||
, asBinaryF
|
||||
, asCsvF
|
||||
, asJsonF
|
||||
, asJsonSingleF
|
||||
, countF
|
||||
, fromQi
|
||||
, ftsOperators
|
||||
, jsonPlaceHolder
|
||||
, limitOffsetF
|
||||
, locationF
|
||||
, normalizedBody
|
||||
, operators
|
||||
, pgFmtColumn
|
||||
, pgFmtIdent
|
||||
, pgFmtJoinCondition
|
||||
, pgFmtLogicTree
|
||||
, pgFmtOrderTerm
|
||||
, pgFmtSelectItem
|
||||
, responseHeadersF
|
||||
, responseStatusF
|
||||
, returningF
|
||||
, selectBody
|
||||
, sourceCTEName
|
||||
, unknownLiteral
|
||||
, intercalateSnippet
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Text as T
|
||||
import qualified Hasql.DynamicStatements.Snippet as H
|
||||
import qualified Hasql.Encoders as HE
|
||||
|
||||
import Data.Foldable (foldr1)
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
|
||||
import PostgREST.DbStructure.Identifiers (FieldName,
|
||||
QualifiedIdentifier (..))
|
||||
import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion96)
|
||||
import PostgREST.RangeQuery (NonnegRange, allRange,
|
||||
rangeLimit, rangeOffset)
|
||||
import PostgREST.Request.Types (Alias, Field, Filter (..),
|
||||
JoinCondition (..),
|
||||
JsonOperand (..),
|
||||
JsonOperation (..),
|
||||
JsonPath, LogicTree (..),
|
||||
OpExpr (..), Operation (..),
|
||||
OrderTerm (..), SelectItem)
|
||||
|
||||
import Protolude hiding (cast, toS)
|
||||
import Protolude.Conv (toS)
|
||||
|
||||
|
||||
-- | A part of a SQL query that cannot be executed independently
|
||||
type SqlFragment = ByteString
|
||||
|
||||
noLocationF :: SqlFragment
|
||||
noLocationF = "array[]::text[]"
|
||||
|
||||
sourceCTEName :: SqlFragment
|
||||
sourceCTEName = "pgrst_source"
|
||||
|
||||
operators :: HM.HashMap Text SqlFragment
|
||||
operators = HM.union (HM.fromList [
|
||||
("eq", "="),
|
||||
("gte", ">="),
|
||||
("gt", ">"),
|
||||
("lte", "<="),
|
||||
("lt", "<"),
|
||||
("neq", "<>"),
|
||||
("like", "LIKE"),
|
||||
("ilike", "ILIKE"),
|
||||
("in", "IN"),
|
||||
("is", "IS"),
|
||||
("cs", "@>"),
|
||||
("cd", "<@"),
|
||||
("ov", "&&"),
|
||||
("sl", "<<"),
|
||||
("sr", ">>"),
|
||||
("nxr", "&<"),
|
||||
("nxl", "&>"),
|
||||
("adj", "-|-")]) ftsOperators
|
||||
|
||||
ftsOperators :: HM.HashMap Text SqlFragment
|
||||
ftsOperators = HM.fromList [
|
||||
("fts", "@@ to_tsquery"),
|
||||
("plfts", "@@ plainto_tsquery"),
|
||||
("phfts", "@@ phraseto_tsquery"),
|
||||
("wfts", "@@ websearch_to_tsquery")
|
||||
]
|
||||
|
||||
-- |
|
||||
-- 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 :: 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)"])
|
||||
|
||||
-- | 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)"
|
||||
|
||||
pgFmtLit :: Text -> SqlFragment
|
||||
pgFmtLit x =
|
||||
let trimmed = trimNullChars x
|
||||
escaped = "'" <> T.replace "'" "''" trimmed <> "'"
|
||||
slashed = T.replace "\\" "\\\\" escaped in
|
||||
encodeUtf8 $ if "\\" `T.isInfixOf` escaped
|
||||
then "E" <> slashed
|
||||
else slashed
|
||||
|
||||
pgFmtIdent :: Text -> SqlFragment
|
||||
pgFmtIdent x = encodeUtf8 $ "\"" <> T.replace "\"" "\"\"" (trimNullChars x) <> "\""
|
||||
|
||||
trimNullChars :: Text -> Text
|
||||
trimNullChars = T.takeWhile (/= '\x0')
|
||||
|
||||
asCsvF :: SqlFragment
|
||||
asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
|
||||
where
|
||||
asCsvHeaderF =
|
||||
"(SELECT coalesce(string_agg(a.k, ','), '')" <>
|
||||
" FROM (" <>
|
||||
" SELECT json_object_keys(r)::text as k" <>
|
||||
" FROM ( " <>
|
||||
" SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>
|
||||
" ) s" <>
|
||||
" ) a" <>
|
||||
")"
|
||||
asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"
|
||||
|
||||
asJsonF :: Bool -> SqlFragment
|
||||
asJsonF returnsScalar
|
||||
| returnsScalar = "coalesce(json_agg(_postgrest_t.pgrst_scalar), '[]')::character varying"
|
||||
| otherwise = "coalesce(json_agg(_postgrest_t), '[]')::character varying"
|
||||
|
||||
asJsonSingleF :: Bool -> SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
|
||||
asJsonSingleF returnsScalar
|
||||
| returnsScalar = "coalesce(string_agg(to_json(_postgrest_t.pgrst_scalar)::text, ','), 'null')::character varying"
|
||||
| otherwise = "coalesce(string_agg(to_json(_postgrest_t)::text, ','), '')::character varying"
|
||||
|
||||
asBinaryF :: FieldName -> SqlFragment
|
||||
asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
|
||||
|
||||
locationF :: [Text] -> SqlFragment
|
||||
locationF pKeys = [qc|(
|
||||
WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1)
|
||||
SELECT array_agg(json_data.key || '=eq.' || json_data.value)
|
||||
FROM data CROSS JOIN json_each_text(data.row) AS json_data
|
||||
WHERE json_data.key IN ('{fmtPKeys}')
|
||||
)|]
|
||||
where
|
||||
fmtPKeys = T.intercalate "','" pKeys
|
||||
|
||||
fromQi :: QualifiedIdentifier -> SqlFragment
|
||||
fromQi t = (if T.null s then mempty else pgFmtIdent s <> ".") <> pgFmtIdent n
|
||||
where
|
||||
n = qiName t
|
||||
s = qiSchema t
|
||||
|
||||
pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
|
||||
pgFmtColumn table "*" = fromQi table <> ".*"
|
||||
pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
|
||||
|
||||
pgFmtField :: QualifiedIdentifier -> Field -> H.Snippet
|
||||
pgFmtField table (c, jp) = H.sql (pgFmtColumn table c) <> pgFmtJsonPath jp
|
||||
|
||||
pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> H.Snippet
|
||||
pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> H.sql (pgFmtAs fName jp alias)
|
||||
-- Ideally we'd quote the cast with "pgFmtIdent cast". However, that would invalidate common casts such as "int", "bigint", etc.
|
||||
-- Try doing: `select 1::"bigint"` - it'll err, using "int8" will work though. There's some parser magic that pg does that's invalidated when quoting.
|
||||
-- Not quoting should be fine, we validate the input on Parsers.
|
||||
pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> H.sql (encodeUtf8 cast) <> " )" <> H.sql (pgFmtAs fName jp alias)
|
||||
|
||||
pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> H.Snippet
|
||||
pgFmtOrderTerm qi ot =
|
||||
pgFmtField qi (otTerm ot) <> " " <>
|
||||
H.sql (BS.unwords [
|
||||
BS.pack $ maybe mempty show $ otDirection ot,
|
||||
BS.pack $ maybe mempty show $ otNullOrder ot])
|
||||
|
||||
pgFmtFilter :: QualifiedIdentifier -> Filter -> H.Snippet
|
||||
pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of
|
||||
Op op val -> pgFmtFieldOp op <> " " <> case op of
|
||||
"like" -> unknownLiteral (T.map star val)
|
||||
"ilike" -> unknownLiteral (T.map star val)
|
||||
"is" -> isAllowed val
|
||||
_ -> unknownLiteral val
|
||||
|
||||
-- We don't use "IN", we use "= ANY". IN has the following disadvantages:
|
||||
-- + No way to use an empty value on IN: "col IN ()" is invalid syntax. With ANY we can do "= ANY('{}')"
|
||||
-- + Can invalidate prepared statements: multiple parameters on an IN($1, $2, $3) will lead to using different prepared statements and not take advantage of caching.
|
||||
In vals -> pgFmtField table fld <> " " <>
|
||||
case vals of
|
||||
[""] -> "= ANY('{}') "
|
||||
-- Here we build the pg array, e.g '{"Hebdon, John","Other","Another"}', manually. We quote the values to prevent the "," being treated as an element separator.
|
||||
-- TODO: Ideally this would be done on Hasql with an encoder, but the "array unknown" is not working(Hasql doesn't pass any value).
|
||||
_ -> "= ANY (" <> unknownLiteral ("{" <> T.intercalate "," ((\x -> "\"" <> x <> "\"") <$> vals) <> "}") <> ")"
|
||||
|
||||
Fts op lang val ->
|
||||
pgFmtFieldOp op <> "(" <> ftsLang lang <> unknownLiteral val <> ") "
|
||||
where
|
||||
ftsLang = maybe mempty (\l -> unknownLiteral l <> ", ")
|
||||
pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
|
||||
sqlOperator o = H.sql $ HM.lookupDefault "=" o operators
|
||||
notOp = if hasNot then "NOT" else mempty
|
||||
star c = if c == '*' then '%' else c
|
||||
-- IS cannot be prepared. `PREPARE boolplan AS SELECT * FROM projects where id IS $1` will give a syntax error.
|
||||
-- The above can be fixed by using `PREPARE boolplan AS SELECT * FROM projects where id IS NOT DISTINCT FROM $1;`
|
||||
-- However that would not accept the TRUE/FALSE/NULL keywords. See: https://stackoverflow.com/questions/6133525/proper-way-to-set-preparedstatement-parameter-to-null-under-postgres.
|
||||
isAllowed :: Text -> H.Snippet
|
||||
isAllowed v = H.sql $ maybe
|
||||
(pgFmtLit v <> "::unknown") encodeUtf8
|
||||
(find ((==) . T.toLower $ v) ["null","true","false"])
|
||||
|
||||
pgFmtJoinCondition :: JoinCondition -> H.Snippet
|
||||
pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) =
|
||||
H.sql $ pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2
|
||||
|
||||
pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> H.Snippet
|
||||
pgFmtLogicTree qi (Expr hasNot op forest) = H.sql notOp <> " (" <> intercalateSnippet (" " <> BS.pack (show op) <> " ") (pgFmtLogicTree qi <$> forest) <> ")"
|
||||
where notOp = if hasNot then "NOT" else mempty
|
||||
pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
|
||||
|
||||
pgFmtJsonPath :: JsonPath -> H.Snippet
|
||||
pgFmtJsonPath = \case
|
||||
[] -> mempty
|
||||
(JArrow x:xs) -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
|
||||
(J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
|
||||
where
|
||||
pgFmtJsonOperand (JKey k) = unknownLiteral k
|
||||
pgFmtJsonOperand (JIdx i) = unknownLiteral i <> "::int"
|
||||
|
||||
pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment
|
||||
pgFmtAs _ [] Nothing = mempty
|
||||
pgFmtAs fName jp Nothing = case jOp <$> lastMay jp of
|
||||
Just (JKey key) -> " AS " <> pgFmtIdent key
|
||||
Just (JIdx _) -> " AS " <> pgFmtIdent (fromMaybe fName lastKey)
|
||||
-- We get the lastKey because on:
|
||||
-- `select=data->1->mycol->>2`, we need to show the result as [ {"mycol": ..}, {"mycol": ..} ]
|
||||
-- `select=data->3`, we need to show the result as [ {"data": ..}, {"data": ..} ]
|
||||
where lastKey = jVal <$> find (\case JKey{} -> True; _ -> False) (jOp <$> reverse jp)
|
||||
Nothing -> mempty
|
||||
pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias
|
||||
|
||||
countF :: H.Snippet -> Bool -> (H.Snippet, SqlFragment)
|
||||
countF countQuery shouldCount =
|
||||
if shouldCount
|
||||
then (
|
||||
", pgrst_source_count AS (" <> countQuery <> ")"
|
||||
, "(SELECT pg_catalog.count(*) FROM pgrst_source_count)" )
|
||||
else (
|
||||
mempty
|
||||
, "null::bigint")
|
||||
|
||||
returningF :: QualifiedIdentifier -> [FieldName] -> SqlFragment
|
||||
returningF qi returnings =
|
||||
if null returnings
|
||||
then "RETURNING 1" -- For mutation cases where there's no ?select, we return 1 to know how many rows were modified
|
||||
else "RETURNING " <> BS.intercalate ", " (pgFmtColumn qi <$> returnings)
|
||||
|
||||
limitOffsetF :: NonnegRange -> H.Snippet
|
||||
limitOffsetF range =
|
||||
if range == allRange then mempty else "LIMIT " <> limit <> " OFFSET " <> offset
|
||||
where
|
||||
limit = maybe "ALL" (\l -> unknownEncoder (BS.pack $ show l)) $ rangeLimit range
|
||||
offset = unknownEncoder (BS.pack . show $ rangeOffset range)
|
||||
|
||||
responseHeadersF :: PgVersion -> SqlFragment
|
||||
responseHeadersF pgVer =
|
||||
if pgVer >= pgVersion96
|
||||
then currentSettingF "response.headers"
|
||||
else "null"
|
||||
|
||||
responseStatusF :: PgVersion -> SqlFragment
|
||||
responseStatusF pgVer =
|
||||
if pgVer >= pgVersion96
|
||||
then currentSettingF "response.status"
|
||||
else "null"
|
||||
|
||||
currentSettingF :: Text -> SqlFragment
|
||||
currentSettingF setting =
|
||||
-- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
|
||||
"nullif(current_setting(" <> pgFmtLit setting <> ", true), '')"
|
||||
|
||||
-- Hasql Snippet utilities
|
||||
unknownEncoder :: ByteString -> H.Snippet
|
||||
unknownEncoder = H.encoderAndParam (HE.nonNullable HE.unknown)
|
||||
|
||||
unknownLiteral :: Text -> H.Snippet
|
||||
unknownLiteral = unknownEncoder . encodeUtf8
|
||||
|
||||
intercalateSnippet :: ByteString -> [H.Snippet] -> H.Snippet
|
||||
intercalateSnippet _ [] = mempty
|
||||
intercalateSnippet frag snippets = foldr1 (\a b -> a <> H.sql frag <> b) snippets
|
||||
@@ -0,0 +1,230 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-|
|
||||
Module : PostgREST.Query.Statements
|
||||
Description : PostgREST single SQL statements.
|
||||
|
||||
This module constructs single SQL statements that can be parametrized and prepared.
|
||||
|
||||
- It consumes the SqlQuery types generated by the QueryBuilder module.
|
||||
- It generates the body format and some headers of the final HTTP response.
|
||||
|
||||
TODO: Currently, createReadStatement is not using prepared statements. See https://github.com/PostgREST/postgrest/issues/718.
|
||||
-}
|
||||
module PostgREST.Query.Statements
|
||||
( createWriteStatement
|
||||
, createReadStatement
|
||||
, callProcStatement
|
||||
, createExplainStatement
|
||||
, dbSettingsStatement
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Lens as L
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
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.Statement as H
|
||||
|
||||
import Control.Lens ((^?))
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Text.Read (decimal)
|
||||
import Network.HTTP.Types.Status (Status)
|
||||
import Text.InterpolatedString.Perl6 (q)
|
||||
|
||||
import PostgREST.DbStructure.PgVersion (PgVersion)
|
||||
import PostgREST.Error (Error (..))
|
||||
import PostgREST.GucHeader (GucHeader)
|
||||
|
||||
import PostgREST.DbStructure.Identifiers (FieldName)
|
||||
import PostgREST.Query.SqlFragment
|
||||
import PostgREST.Request.Preferences
|
||||
|
||||
import Protolude hiding (toS)
|
||||
import Protolude.Conv (toS)
|
||||
|
||||
|
||||
{-| 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 Error [GucHeader], Either Error (Maybe Status))
|
||||
|
||||
createWriteStatement :: H.Snippet -> H.Snippet -> Bool -> Bool -> Bool ->
|
||||
PreferRepresentation -> [Text] -> PgVersion -> Bool ->
|
||||
H.Statement () ResultsWithCount
|
||||
createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys pgVer =
|
||||
H.dynamicallyParameterized snippet decodeStandard
|
||||
where
|
||||
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]
|
||||
then BS.unwords [
|
||||
"CASE WHEN pg_catalog.count(_postgrest_t) = 1",
|
||||
"THEN coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")",
|
||||
"ELSE " <> noLocationF,
|
||||
"END"]
|
||||
else noLocationF
|
||||
|
||||
bodyF
|
||||
| rep `elem` [None, HeadersOnly] = "''"
|
||||
| asCsv = asCsvF
|
||||
| wantSingle = asJsonSingleF False
|
||||
| otherwise = asJsonF False
|
||||
|
||||
selectF
|
||||
-- prevent using any of the column names in ?select= when no response is returned from the CTE
|
||||
| rep `elem` [None, HeadersOnly] = H.sql ("SELECT * FROM " <> sourceCTEName)
|
||||
| otherwise = selectQuery
|
||||
|
||||
decodeStandard :: HD.Result ResultsWithCount
|
||||
decodeStandard =
|
||||
fromMaybe (Nothing, 0, [], mempty, Right [], Right Nothing) <$> HD.rowMaybe standardRow
|
||||
|
||||
createReadStatement :: H.Snippet -> H.Snippet -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> Bool ->
|
||||
H.Statement () ResultsWithCount
|
||||
createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField pgVer =
|
||||
H.dynamicallyParameterized snippet decodeStandard
|
||||
where
|
||||
snippet =
|
||||
"WITH " <>
|
||||
H.sql sourceCTEName <> " AS ( " <> selectQuery <> " ) " <>
|
||||
countCTEF <> " " <>
|
||||
H.sql ("SELECT " <>
|
||||
countResultF <> " AS total_result_set, " <>
|
||||
"pg_catalog.count(_postgrest_t) AS page_total, " <>
|
||||
noLocationF <> " AS header, " <>
|
||||
bodyF <> " AS body, " <>
|
||||
responseHeadersF pgVer <> " AS response_headers, " <>
|
||||
responseStatusF pgVer <> " AS response_status " <>
|
||||
"FROM ( SELECT * FROM " <> sourceCTEName <> " ) _postgrest_t")
|
||||
|
||||
(countCTEF, countResultF) = countF countQuery countTotal
|
||||
|
||||
bodyF
|
||||
| asCsv = asCsvF
|
||||
| isSingle = asJsonSingleF False
|
||||
| isJust binaryField = asBinaryF $ fromJust binaryField
|
||||
| otherwise = asJsonF False
|
||||
|
||||
decodeStandard :: HD.Result ResultsWithCount
|
||||
decodeStandard =
|
||||
HD.singleRow standardRow
|
||||
|
||||
{-| Read and Write api requests use a similar response format which includes
|
||||
various record counts and possible location header. This is the decoder
|
||||
for that common type of query.
|
||||
-}
|
||||
standardRow :: HD.Row ResultsWithCount
|
||||
standardRow = (,,,,,) <$> nullableColumn HD.int8 <*> column HD.int8
|
||||
<*> arrayColumn HD.bytea <*> column HD.bytea
|
||||
<*> (fromMaybe (Right []) <$> nullableColumn decodeGucHeaders)
|
||||
<*> (fromMaybe (Right Nothing) <$> nullableColumn decodeGucStatus)
|
||||
|
||||
type ProcResults = (Maybe Int64, Int64, ByteString, Either Error [GucHeader], Either Error (Maybe Status))
|
||||
|
||||
callProcStatement :: Bool -> Bool -> H.Snippet -> H.Snippet -> H.Snippet -> Bool ->
|
||||
Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> Bool ->
|
||||
H.Statement () ProcResults
|
||||
callProcStatement returnsScalar returnsSingle callProcQuery selectQuery countQuery countTotal asSingle asCsv multObjects binaryField pgVer =
|
||||
H.dynamicallyParameterized snippet decodeProc
|
||||
where
|
||||
snippet =
|
||||
"WITH " <> H.sql sourceCTEName <> " AS (" <> callProcQuery <> ") " <>
|
||||
countCTEF <>
|
||||
H.sql (
|
||||
"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
|
||||
|
||||
bodyF
|
||||
| asSingle = asJsonSingleF returnsScalar
|
||||
| asCsv = asCsvF
|
||||
| isJust binaryField = asBinaryF $ fromJust binaryField
|
||||
| returnsSingle
|
||||
&& not multObjects = asJsonSingleF returnsScalar
|
||||
| otherwise = asJsonF returnsScalar
|
||||
|
||||
decodeProc :: HD.Result ProcResults
|
||||
decodeProc =
|
||||
fromMaybe (Just 0, 0, mempty, defGucHeaders, defGucStatus) <$> HD.rowMaybe procRow
|
||||
where
|
||||
defGucHeaders = Right []
|
||||
defGucStatus = Right Nothing
|
||||
procRow = (,,,,) <$> nullableColumn HD.int8 <*> column HD.int8
|
||||
<*> column HD.bytea
|
||||
<*> (fromMaybe defGucHeaders <$> nullableColumn decodeGucHeaders)
|
||||
<*> (fromMaybe defGucStatus <$> nullableColumn decodeGucStatus)
|
||||
|
||||
createExplainStatement :: H.Snippet -> Bool -> H.Statement () (Maybe Int64)
|
||||
createExplainStatement countQuery =
|
||||
H.dynamicallyParameterized snippet decodeExplain
|
||||
where
|
||||
snippet = "EXPLAIN (FORMAT JSON) " <> countQuery
|
||||
-- |
|
||||
-- An `EXPLAIN (FORMAT JSON) select * from items;` output looks like this:
|
||||
-- [{
|
||||
-- "Plan": {
|
||||
-- "Node Type": "Seq Scan", "Parallel Aware": false, "Relation Name": "items",
|
||||
-- "Alias": "items", "Startup Cost": 0.00, "Total Cost": 32.60,
|
||||
-- "Plan Rows": 2260,"Plan Width": 8} }]
|
||||
-- We only obtain the Plan Rows here.
|
||||
decodeExplain :: HD.Result (Maybe Int64)
|
||||
decodeExplain =
|
||||
let row = HD.singleRow $ column HD.bytea in
|
||||
(^? L.nth 0 . L.key "Plan" . L.key "Plan Rows" . L._Integral) <$> row
|
||||
|
||||
decodeGucHeaders :: HD.Value (Either Error [GucHeader])
|
||||
decodeGucHeaders = first (const GucHeadersError) . JSON.eitherDecode . toS <$> HD.bytea
|
||||
|
||||
decodeGucStatus :: HD.Value (Either Error (Maybe Status))
|
||||
decodeGucStatus = first (const GucStatusError) . fmap (Just . toEnum . fst) . decimal <$> HD.text
|
||||
|
||||
-- | Get db settings from the connection role. Global settings will be overridden by database specific settings.
|
||||
dbSettingsStatement :: H.Statement () [(Text, Text)]
|
||||
dbSettingsStatement = H.Statement sql HE.noParams decodeSettings False
|
||||
where
|
||||
sql = [q|
|
||||
with
|
||||
role_setting as (
|
||||
select setdatabase, unnest(setconfig) as setting from pg_catalog.pg_db_role_setting
|
||||
where setrole = current_user::regrole::oid
|
||||
and setdatabase in (0, (select oid from pg_catalog.pg_database where datname = current_catalog))
|
||||
),
|
||||
kv_settings as (
|
||||
select setdatabase, split_part(setting, '=', 1) as k, split_part(setting, '=', 2) as value from role_setting
|
||||
where setting like 'pgrst.%'
|
||||
)
|
||||
select distinct on (key) replace(k, 'pgrst.', '') as key, value
|
||||
from kv_settings
|
||||
order by key, setdatabase desc;
|
||||
|]
|
||||
decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
|
||||
|
||||
column :: HD.Value a -> HD.Row a
|
||||
column = HD.column . HD.nonNullable
|
||||
|
||||
nullableColumn :: HD.Value a -> HD.Row (Maybe a)
|
||||
nullableColumn = HD.column . HD.nullable
|
||||
|
||||
arrayColumn :: HD.Value a -> HD.Row [a]
|
||||
arrayColumn = column . HD.listArray . HD.nonNullable
|
||||
Reference in New Issue
Block a user