LTS 13.29 (#1364)
* Update resolver to lts-13.29 and add lock file to repository * Upgrade stack version * Save cache after building dependencies only to have faster feedback loop when tests fail * Move private functions from QueryBuilder to a separate Private module * Move more functions over to private trying to make compilation consume less memory * Split private in 4 modules * Remove unused LambdaCase pragma * Add profile to memory-tests.sh so it can find postgrest executable * Move save dependencies before building and running tests for faster feedback loop
This commit is contained in:
Diogo Biazus
committed by
Steve Chávez
Steve Chávez
parent
c37a9f5ec3
commit
291de5bc1c
+29
-20
@@ -74,8 +74,8 @@ jobs:
|
|||||||
- run:
|
- run:
|
||||||
name: install stack & dependencies
|
name: install stack & dependencies
|
||||||
command: |
|
command: |
|
||||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v1.9.3/stack-1.9.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
||||||
sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin
|
sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
|
||||||
sudo apt-get update
|
sudo apt-get update
|
||||||
sudo apt-get install -y libgmp-dev
|
sudo apt-get install -y libgmp-dev
|
||||||
sudo apt-get install -y --only-upgrade binutils
|
sudo apt-get install -y --only-upgrade binutils
|
||||||
@@ -83,6 +83,16 @@ jobs:
|
|||||||
stack setup
|
stack setup
|
||||||
rm -rf $(stack path --dist-dir) $(stack path --local-install-root)
|
rm -rf $(stack path --dist-dir) $(stack path --local-install-root)
|
||||||
stack install hlint stylish-haskell
|
stack install hlint stylish-haskell
|
||||||
|
- run:
|
||||||
|
name: build src and tests dependencies
|
||||||
|
command: |
|
||||||
|
stack build --fast -j1 --only-dependencies
|
||||||
|
stack build --fast --test --no-run-tests --only-dependencies
|
||||||
|
- save_cache:
|
||||||
|
paths:
|
||||||
|
- "~/.stack"
|
||||||
|
- ".stack-work"
|
||||||
|
key: v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
|
||||||
- run:
|
- run:
|
||||||
name: build src and tests
|
name: build src and tests
|
||||||
command: |
|
command: |
|
||||||
@@ -99,11 +109,6 @@ jobs:
|
|||||||
- run:
|
- run:
|
||||||
name: run styler
|
name: run styler
|
||||||
command: git ls-files | grep '\.l\?hs$' | xargs stack exec -- stylish-haskell -i && git diff-index --exit-code HEAD --
|
command: git ls-files | grep '\.l\?hs$' | xargs stack exec -- stylish-haskell -i && git diff-index --exit-code HEAD --
|
||||||
- save_cache:
|
|
||||||
paths:
|
|
||||||
- "~/.stack"
|
|
||||||
- ".stack-work"
|
|
||||||
key: v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
|
|
||||||
|
|
||||||
build-test-9.6:
|
build-test-9.6:
|
||||||
docker:
|
docker:
|
||||||
@@ -122,8 +127,8 @@ jobs:
|
|||||||
- run:
|
- run:
|
||||||
name: install stack & dependencies
|
name: install stack & dependencies
|
||||||
command: |
|
command: |
|
||||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v1.9.3/stack-1.9.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
||||||
sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin
|
sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
|
||||||
sudo apt-get update
|
sudo apt-get update
|
||||||
sudo apt-get install -y libgmp-dev
|
sudo apt-get install -y libgmp-dev
|
||||||
sudo apt-get install -y postgresql-client
|
sudo apt-get install -y postgresql-client
|
||||||
@@ -154,8 +159,8 @@ jobs:
|
|||||||
- run:
|
- run:
|
||||||
name: install stack & dependencies
|
name: install stack & dependencies
|
||||||
command: |
|
command: |
|
||||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v1.9.3/stack-1.9.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
||||||
sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin
|
sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
|
||||||
sudo apt-get update
|
sudo apt-get update
|
||||||
sudo apt-get install -y libgmp-dev
|
sudo apt-get install -y libgmp-dev
|
||||||
sudo apt-get install -y postgresql-client
|
sudo apt-get install -y postgresql-client
|
||||||
@@ -186,8 +191,8 @@ jobs:
|
|||||||
- run:
|
- run:
|
||||||
name: install stack & dependencies
|
name: install stack & dependencies
|
||||||
command: |
|
command: |
|
||||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v1.9.3/stack-1.9.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
||||||
sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin
|
sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
|
||||||
sudo apt-get update
|
sudo apt-get update
|
||||||
sudo apt-get install -y libgmp-dev
|
sudo apt-get install -y libgmp-dev
|
||||||
sudo apt-get install -y postgresql-client
|
sudo apt-get install -y postgresql-client
|
||||||
@@ -219,12 +224,21 @@ jobs:
|
|||||||
- run:
|
- run:
|
||||||
name: install stack & dependencies
|
name: install stack & dependencies
|
||||||
command: |
|
command: |
|
||||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v1.9.3/stack-1.9.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
|
||||||
sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin
|
sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
|
||||||
sudo apt-get update
|
sudo apt-get update
|
||||||
sudo apt-get install -y libgmp-dev
|
sudo apt-get install -y libgmp-dev
|
||||||
sudo apt-get install -y postgresql-client
|
sudo apt-get install -y postgresql-client
|
||||||
stack setup
|
stack setup
|
||||||
|
- run:
|
||||||
|
name: build dependencies with profiling enabled
|
||||||
|
command: |
|
||||||
|
stack build --profile -j1 --only-dependencies
|
||||||
|
- save_cache:
|
||||||
|
paths:
|
||||||
|
- "~/.stack"
|
||||||
|
- ".stack-work"
|
||||||
|
key: v1-stack-prof-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
|
||||||
- run:
|
- run:
|
||||||
name: build with profiling enabled
|
name: build with profiling enabled
|
||||||
command: |
|
command: |
|
||||||
@@ -240,11 +254,6 @@ jobs:
|
|||||||
psql "postgres:///postgrest_test" -f test/fixtures/jsonschema.sql
|
psql "postgres:///postgrest_test" -f test/fixtures/jsonschema.sql
|
||||||
psql "postgres:///postgrest_test" -f test/fixtures/privileges.sql
|
psql "postgres:///postgrest_test" -f test/fixtures/privileges.sql
|
||||||
test/memory-tests.sh
|
test/memory-tests.sh
|
||||||
- save_cache:
|
|
||||||
paths:
|
|
||||||
- "~/.stack"
|
|
||||||
- ".stack-work"
|
|
||||||
key: v1-stack-prof-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
|
|
||||||
|
|
||||||
centos6:
|
centos6:
|
||||||
<<: *build-distro-bin
|
<<: *build-distro-bin
|
||||||
|
|||||||
@@ -39,6 +39,10 @@ library
|
|||||||
PostgREST.RangeQuery
|
PostgREST.RangeQuery
|
||||||
PostgREST.Types
|
PostgREST.Types
|
||||||
other-modules: Paths_postgrest
|
other-modules: Paths_postgrest
|
||||||
|
PostgREST.QueryBuilder.Private
|
||||||
|
PostgREST.QueryBuilder.Procedure
|
||||||
|
PostgREST.QueryBuilder.ReadStatement
|
||||||
|
PostgREST.QueryBuilder.WriteStatement
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
build-depends: base >= 4.9 && < 4.13
|
build-depends: base >= 4.9 && < 4.13
|
||||||
, HTTP >= 4000.3.7 && < 4000.4
|
, HTTP >= 4000.3.7 && < 4000.4
|
||||||
|
|||||||
+13
-371
@@ -1,7 +1,6 @@
|
|||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-|
|
{-|
|
||||||
Module : PostgREST.QueryBuilder
|
Module : PostgREST.QueryBuilder
|
||||||
@@ -17,8 +16,6 @@ module PostgREST.QueryBuilder (
|
|||||||
callProc
|
callProc
|
||||||
, createReadStatement
|
, createReadStatement
|
||||||
, createWriteStatement
|
, createWriteStatement
|
||||||
, pgFmtIdent
|
|
||||||
, pgFmtLit
|
|
||||||
, requestToQuery
|
, requestToQuery
|
||||||
, requestToCountQuery
|
, requestToCountQuery
|
||||||
, unquoted
|
, unquoted
|
||||||
@@ -27,215 +24,24 @@ module PostgREST.QueryBuilder (
|
|||||||
, pgFmtSetLocalSearchPath
|
, pgFmtSetLocalSearchPath
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.Aeson as JSON
|
import qualified Data.Aeson as JSON
|
||||||
import qualified Data.ByteString.Char8 as BS
|
import qualified Data.Set as S
|
||||||
import qualified Data.HashMap.Strict as HM
|
|
||||||
import qualified Data.Set as S
|
|
||||||
import qualified Data.Text as T (map, null, takeWhile)
|
|
||||||
import qualified Data.Text.Encoding as T
|
|
||||||
import qualified Hasql.Decoders as HD
|
|
||||||
import qualified Hasql.Encoders as HE
|
|
||||||
import qualified Hasql.Statement as H
|
|
||||||
|
|
||||||
import Data.Scientific (FPFormat (..), formatScientific,
|
import Data.Scientific (FPFormat (..), formatScientific, isInteger)
|
||||||
isInteger)
|
import Data.Text (intercalate, unwords)
|
||||||
import Data.Text (intercalate, isInfixOf, replace,
|
import Data.Tree (Tree (..))
|
||||||
toLower, unwords)
|
|
||||||
import Data.Tree (Tree (..))
|
|
||||||
import Text.InterpolatedString.Perl6 (qc)
|
|
||||||
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
import PostgREST.ApiRequest (PreferRepresentation (..))
|
import PostgREST.QueryBuilder.Private
|
||||||
import PostgREST.RangeQuery (allRange, rangeLimit, rangeOffset)
|
import PostgREST.QueryBuilder.Procedure
|
||||||
|
import PostgREST.QueryBuilder.ReadStatement
|
||||||
|
import PostgREST.QueryBuilder.WriteStatement
|
||||||
|
import PostgREST.RangeQuery (allRange, rangeLimit,
|
||||||
|
rangeOffset)
|
||||||
import PostgREST.Types
|
import PostgREST.Types
|
||||||
import Protolude hiding (cast, intercalate, replace)
|
import Protolude hiding (cast,
|
||||||
|
intercalate, replace)
|
||||||
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
|
|
||||||
|
|
||||||
element :: HD.Value a -> HD.Array a
|
|
||||||
element = HD.element . HD.nonNullable
|
|
||||||
|
|
||||||
param :: HE.Value a -> HE.Params a
|
|
||||||
param = HE.param . HE.nonNullable
|
|
||||||
|
|
||||||
{-| 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)
|
|
||||||
|
|
||||||
standardRow :: HD.Row ResultsWithCount
|
|
||||||
standardRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8
|
|
||||||
<*> column header <*> column HD.bytea
|
|
||||||
where
|
|
||||||
header = HD.array $ HD.dimension replicateM $ element HD.bytea
|
|
||||||
|
|
||||||
noLocationF :: Text
|
|
||||||
noLocationF = "array[]::text[]"
|
|
||||||
|
|
||||||
{-| 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.
|
|
||||||
-}
|
|
||||||
decodeStandard :: HD.Result ResultsWithCount
|
|
||||||
decodeStandard =
|
|
||||||
HD.singleRow standardRow
|
|
||||||
|
|
||||||
decodeStandardMay :: HD.Result (Maybe ResultsWithCount)
|
|
||||||
decodeStandardMay =
|
|
||||||
HD.rowMaybe standardRow
|
|
||||||
|
|
||||||
createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName ->
|
|
||||||
H.Statement () ResultsWithCount
|
|
||||||
createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =
|
|
||||||
unicodeStatement sql HE.noParams decodeStandard False
|
|
||||||
where
|
|
||||||
sql = [qc|
|
|
||||||
WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}
|
|
||||||
FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |]
|
|
||||||
countResultF = if countTotal then "("<>countQuery<>")" else "null"
|
|
||||||
cols = intercalate ", " [
|
|
||||||
countResultF <> " AS total_result_set",
|
|
||||||
"pg_catalog.count(_postgrest_t) AS page_total",
|
|
||||||
noLocationF <> " AS header",
|
|
||||||
bodyF <> " AS body"
|
|
||||||
]
|
|
||||||
bodyF
|
|
||||||
| asCsv = asCsvF
|
|
||||||
| isSingle = asJsonSingleF
|
|
||||||
| isJust binaryField = asBinaryF $ fromJust binaryField
|
|
||||||
| otherwise = asJsonF
|
|
||||||
|
|
||||||
|
|
||||||
createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
|
|
||||||
PreferRepresentation -> [Text] ->
|
|
||||||
H.Statement ByteString (Maybe ResultsWithCount)
|
|
||||||
createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys =
|
|
||||||
unicodeStatement sql (param HE.unknown) decodeStandardMay True
|
|
||||||
|
|
||||||
where
|
|
||||||
sql = case rep of
|
|
||||||
None -> [qc|
|
|
||||||
WITH {sourceCTEName} AS ({mutateQuery})
|
|
||||||
SELECT '', 0, {noLocationF}, '' |]
|
|
||||||
HeadersOnly -> [qc|
|
|
||||||
WITH {sourceCTEName} AS ({mutateQuery})
|
|
||||||
SELECT {cols}
|
|
||||||
FROM (SELECT 1 FROM {sourceCTEName}) _postgrest_t |]
|
|
||||||
Full -> [qc|
|
|
||||||
WITH {sourceCTEName} AS ({mutateQuery})
|
|
||||||
SELECT {cols}
|
|
||||||
FROM ({selectQuery}) _postgrest_t |]
|
|
||||||
|
|
||||||
cols = intercalate ", " [
|
|
||||||
"'' AS total_result_set", -- when updateing it does not make sense
|
|
||||||
"pg_catalog.count(_postgrest_t) AS page_total",
|
|
||||||
if isInsert
|
|
||||||
then unwords [
|
|
||||||
"CASE",
|
|
||||||
"WHEN pg_catalog.count(_postgrest_t) = 1 THEN",
|
|
||||||
"coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")",
|
|
||||||
"ELSE " <> noLocationF,
|
|
||||||
"END AS header"]
|
|
||||||
else noLocationF <> "AS header",
|
|
||||||
if rep == Full
|
|
||||||
then bodyF <> " AS body"
|
|
||||||
else "''"
|
|
||||||
]
|
|
||||||
|
|
||||||
bodyF
|
|
||||||
| asCsv = asCsvF
|
|
||||||
| wantSingle = asJsonSingleF
|
|
||||||
| otherwise = asJsonF
|
|
||||||
|
|
||||||
type ProcResults = (Maybe Int64, Int64, ByteString, ByteString)
|
|
||||||
callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool ->
|
|
||||||
Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion ->
|
|
||||||
H.Statement ByteString (Maybe ProcResults)
|
|
||||||
callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField pgVer =
|
|
||||||
unicodeStatement sql (param HE.unknown) decodeProc True
|
|
||||||
where
|
|
||||||
sql =[qc|
|
|
||||||
WITH
|
|
||||||
{argsRecord},
|
|
||||||
{sourceCTEName} AS (
|
|
||||||
{sourceBody}
|
|
||||||
)
|
|
||||||
SELECT
|
|
||||||
{countResultF} AS total_result_set,
|
|
||||||
pg_catalog.count(_postgrest_t) AS page_total,
|
|
||||||
{bodyF} AS body,
|
|
||||||
{responseHeaders} AS response_headers
|
|
||||||
FROM ({selectQuery}) _postgrest_t;|]
|
|
||||||
|
|
||||||
(argsRecord, args)
|
|
||||||
| paramsAsSingleObject = ("_args_record AS (SELECT NULL)", "$1::json")
|
|
||||||
| null pgArgs = (ignoredBody, "")
|
|
||||||
| otherwise = (
|
|
||||||
unwords [
|
|
||||||
normalizedBody <> ",",
|
|
||||||
"_args_record AS (",
|
|
||||||
"SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <>
|
|
||||||
intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " " <> pgaType a) <$> pgArgs) <> ")",
|
|
||||||
")"]
|
|
||||||
, intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " := _args_record." <> pgFmtIdent (pgaName a)) <$> pgArgs))
|
|
||||||
|
|
||||||
sourceBody :: SqlFragment
|
|
||||||
sourceBody
|
|
||||||
| paramsAsSingleObject || null pgArgs =
|
|
||||||
if returnsScalar
|
|
||||||
then [qc| SELECT {fromQi qi}({args}) |]
|
|
||||||
else [qc| SELECT * FROM {fromQi qi}({args}) |]
|
|
||||||
| otherwise =
|
|
||||||
if returnsScalar
|
|
||||||
then [qc| SELECT {fromQi qi}({args}) FROM _args_record |]
|
|
||||||
else [qc| SELECT _.*
|
|
||||||
FROM _args_record,
|
|
||||||
LATERAL ( SELECT * FROM {fromQi qi}({args}) ) _ |]
|
|
||||||
|
|
||||||
bodyF
|
|
||||||
| returnsScalar = scalarBodyF
|
|
||||||
| isSingle = asJsonSingleF
|
|
||||||
| asCsv = asCsvF
|
|
||||||
| isJust binaryField = asBinaryF $ fromJust binaryField
|
|
||||||
| otherwise = asJsonF
|
|
||||||
|
|
||||||
scalarBodyF
|
|
||||||
| asBinary = asBinaryF _procName
|
|
||||||
| otherwise = unwords [
|
|
||||||
"CASE",
|
|
||||||
"WHEN pg_catalog.count(_postgrest_t) = 1",
|
|
||||||
"THEN (json_agg(_postgrest_t." <> pgFmtIdent _procName <> ")->0)::character varying",
|
|
||||||
"ELSE (json_agg(_postgrest_t." <> pgFmtIdent _procName <> "))::character varying",
|
|
||||||
"END"]
|
|
||||||
|
|
||||||
countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text
|
|
||||||
_procName = qiName qi
|
|
||||||
responseHeaders =
|
|
||||||
if pgVer >= pgVersion96
|
|
||||||
then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
|
|
||||||
else "'[]'" :: Text
|
|
||||||
|
|
||||||
decodeProc = HD.rowMaybe procRow
|
|
||||||
procRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8
|
|
||||||
<*> column HD.bytea <*> column HD.bytea
|
|
||||||
|
|
||||||
pgFmtIdent :: SqlFragment -> SqlFragment
|
|
||||||
pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""
|
|
||||||
|
|
||||||
pgFmtLit :: SqlFragment -> SqlFragment
|
|
||||||
pgFmtLit x =
|
|
||||||
let trimmed = trimNullChars x
|
|
||||||
escaped = "'" <> replace "'" "''" trimmed <> "'"
|
|
||||||
slashed = replace "\\" "\\\\" escaped in
|
|
||||||
if "\\" `isInfixOf` escaped
|
|
||||||
then "E" <> slashed
|
|
||||||
else slashed
|
|
||||||
|
|
||||||
requestToCountQuery :: Schema -> DbRequest -> SqlQuery
|
requestToCountQuery :: Schema -> DbRequest -> SqlQuery
|
||||||
requestToCountQuery _ (DbMutate _) = witness
|
requestToCountQuery _ (DbMutate _) = witness
|
||||||
@@ -339,173 +145,9 @@ requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) =
|
|||||||
where
|
where
|
||||||
qi = QualifiedIdentifier schema mainTbl
|
qi = QualifiedIdentifier schema mainTbl
|
||||||
|
|
||||||
-- 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 = "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 =
|
|
||||||
unwords [
|
|
||||||
"pgrst_payload AS (SELECT $1::json AS json_data),",
|
|
||||||
"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)"]
|
|
||||||
|
|
||||||
selectBody :: SqlFragment
|
|
||||||
selectBody = "(SELECT val FROM pgrst_body)"
|
|
||||||
|
|
||||||
removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
|
|
||||||
removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl
|
|
||||||
|
|
||||||
unquoted :: JSON.Value -> Text
|
unquoted :: JSON.Value -> Text
|
||||||
unquoted (JSON.String t) = t
|
unquoted (JSON.String t) = t
|
||||||
unquoted (JSON.Number n) =
|
unquoted (JSON.Number n) =
|
||||||
toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
|
toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
|
||||||
unquoted (JSON.Bool b) = show b
|
unquoted (JSON.Bool b) = show b
|
||||||
unquoted v = toS $ JSON.encode v
|
unquoted v = toS $ JSON.encode v
|
||||||
|
|
||||||
-- private functions
|
|
||||||
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 :: SqlFragment
|
|
||||||
asJsonF = "coalesce(json_agg(_postgrest_t), '[]')::character varying"
|
|
||||||
|
|
||||||
asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
|
|
||||||
asJsonSingleF = "coalesce(string_agg(row_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 || '=' || coalesce('eq.' || json_data.value, 'is.null'))
|
|
||||||
FROM data CROSS JOIN json_each_text(data.row) AS json_data
|
|
||||||
{("WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')") `emptyOnFalse` null pKeys}
|
|
||||||
)|]
|
|
||||||
|
|
||||||
fromQi :: QualifiedIdentifier -> SqlFragment
|
|
||||||
fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
|
|
||||||
where
|
|
||||||
n = qiName t
|
|
||||||
s = qiSchema t
|
|
||||||
|
|
||||||
unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Statement a b
|
|
||||||
unicodeStatement = H.Statement . T.encodeUtf8
|
|
||||||
|
|
||||||
emptyOnFalse :: Text -> Bool -> Text
|
|
||||||
emptyOnFalse val cond = if cond then "" else val
|
|
||||||
|
|
||||||
pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
|
|
||||||
pgFmtColumn table "*" = fromQi table <> ".*"
|
|
||||||
pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
|
|
||||||
|
|
||||||
pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment
|
|
||||||
pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp
|
|
||||||
|
|
||||||
pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment
|
|
||||||
pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> pgFmtAs fName jp alias
|
|
||||||
pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs fName jp alias
|
|
||||||
|
|
||||||
pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SqlFragment
|
|
||||||
pgFmtOrderTerm qi ot = unwords [
|
|
||||||
toS . pgFmtField qi $ otTerm ot,
|
|
||||||
maybe "" show $ otDirection ot,
|
|
||||||
maybe "" show $ otNullOrder ot]
|
|
||||||
|
|
||||||
pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment
|
|
||||||
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" -> whiteList val
|
|
||||||
_ -> unknownLiteral val
|
|
||||||
|
|
||||||
In vals -> pgFmtField table fld <> " " <>
|
|
||||||
let emptyValForIn = "= any('{}') " in -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"
|
|
||||||
case (&&) (length vals == 1) . T.null <$> headMay vals of
|
|
||||||
Just False -> sqlOperator "in" <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "
|
|
||||||
Just True -> emptyValForIn
|
|
||||||
Nothing -> emptyValForIn
|
|
||||||
|
|
||||||
Fts op lang val ->
|
|
||||||
pgFmtFieldOp op
|
|
||||||
<> "("
|
|
||||||
<> maybe "" ((<> ", ") . pgFmtLit) lang
|
|
||||||
<> unknownLiteral val
|
|
||||||
<> ") "
|
|
||||||
where
|
|
||||||
pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
|
|
||||||
sqlOperator o = HM.lookupDefault "=" o operators
|
|
||||||
notOp = if hasNot then "NOT" else ""
|
|
||||||
star c = if c == '*' then '%' else c
|
|
||||||
unknownLiteral = (<> "::unknown ") . pgFmtLit
|
|
||||||
whiteList :: Text -> SqlFragment
|
|
||||||
whiteList v = fromMaybe
|
|
||||||
(toS (pgFmtLit v) <> "::unknown ")
|
|
||||||
(find ((==) . toLower $ v) ["null","true","false"])
|
|
||||||
|
|
||||||
pgFmtJoinCondition :: JoinCondition -> SqlFragment
|
|
||||||
pgFmtJoinCondition (JoinCondition (qi, col1) (QualifiedIdentifier schema fTable, col2)) =
|
|
||||||
pgFmtColumn qi col1 <> " = " <>
|
|
||||||
pgFmtColumn (removeSourceCTESchema schema fTable) col2
|
|
||||||
|
|
||||||
pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment
|
|
||||||
pgFmtLogicTree qi (Expr hasNot op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")"
|
|
||||||
where notOp = if hasNot then "NOT" else ""
|
|
||||||
pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
|
|
||||||
|
|
||||||
pgFmtJsonPath :: JsonPath -> SqlFragment
|
|
||||||
pgFmtJsonPath = \case
|
|
||||||
[] -> ""
|
|
||||||
(JArrow x:xs) -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
|
|
||||||
(J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
|
|
||||||
where
|
|
||||||
pgFmtJsonOperand (JKey k) = pgFmtLit k
|
|
||||||
pgFmtJsonOperand (JIdx i) = pgFmtLit i <> "::int"
|
|
||||||
|
|
||||||
pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment
|
|
||||||
pgFmtAs _ [] Nothing = ""
|
|
||||||
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 -> ""
|
|
||||||
pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias
|
|
||||||
|
|
||||||
pgFmtSetLocal :: Text -> (Text, Text) -> SqlFragment
|
|
||||||
pgFmtSetLocal prefix (k, v) =
|
|
||||||
"SET LOCAL " <> pgFmtIdent (prefix <> k) <> " = " <> pgFmtLit v <> ";"
|
|
||||||
|
|
||||||
pgFmtSetLocalSearchPath :: [Text] -> SqlFragment
|
|
||||||
pgFmtSetLocalSearchPath vals =
|
|
||||||
"SET LOCAL search_path = " <> intercalate ", " (pgFmtLit <$> vals) <> ";"
|
|
||||||
|
|
||||||
trimNullChars :: Text -> Text
|
|
||||||
trimNullChars = T.takeWhile (/= '\x0')
|
|
||||||
|
|||||||
@@ -0,0 +1,237 @@
|
|||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-|
|
||||||
|
Module : PostgREST.QueryBuilder.Private
|
||||||
|
Description : Helper functions for PostgREST.QueryBuilder.
|
||||||
|
-}
|
||||||
|
module PostgREST.QueryBuilder.Private where
|
||||||
|
|
||||||
|
import qualified Data.ByteString.Char8 as BS
|
||||||
|
import qualified Data.HashMap.Strict as HM
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Text (intercalate,
|
||||||
|
isInfixOf, replace,
|
||||||
|
toLower, unwords)
|
||||||
|
import qualified Data.Text as T (map, null,
|
||||||
|
takeWhile)
|
||||||
|
import qualified Data.Text.Encoding as T
|
||||||
|
import qualified Hasql.Decoders as HD
|
||||||
|
import qualified Hasql.Encoders as HE
|
||||||
|
import qualified Hasql.Statement as H
|
||||||
|
import PostgREST.Types
|
||||||
|
import Protolude hiding (cast,
|
||||||
|
intercalate, replace)
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
element :: HD.Value a -> HD.Array a
|
||||||
|
element = HD.element . HD.nonNullable
|
||||||
|
|
||||||
|
param :: HE.Value a -> HE.Params a
|
||||||
|
param = HE.param . HE.nonNullable
|
||||||
|
|
||||||
|
{-| 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)
|
||||||
|
|
||||||
|
standardRow :: HD.Row ResultsWithCount
|
||||||
|
standardRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8
|
||||||
|
<*> column header <*> column HD.bytea
|
||||||
|
where
|
||||||
|
header = HD.array $ HD.dimension replicateM $ element HD.bytea
|
||||||
|
|
||||||
|
noLocationF :: Text
|
||||||
|
noLocationF = "array[]::text[]"
|
||||||
|
|
||||||
|
{-| 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.
|
||||||
|
-}
|
||||||
|
decodeStandard :: HD.Result ResultsWithCount
|
||||||
|
decodeStandard =
|
||||||
|
HD.singleRow standardRow
|
||||||
|
|
||||||
|
decodeStandardMay :: HD.Result (Maybe ResultsWithCount)
|
||||||
|
decodeStandardMay =
|
||||||
|
HD.rowMaybe standardRow
|
||||||
|
|
||||||
|
removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
|
||||||
|
removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl
|
||||||
|
|
||||||
|
-- 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 = "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 =
|
||||||
|
unwords [
|
||||||
|
"pgrst_payload AS (SELECT $1::json AS json_data),",
|
||||||
|
"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)"]
|
||||||
|
|
||||||
|
selectBody :: SqlFragment
|
||||||
|
selectBody = "(SELECT val FROM pgrst_body)"
|
||||||
|
|
||||||
|
pgFmtLit :: SqlFragment -> SqlFragment
|
||||||
|
pgFmtLit x =
|
||||||
|
let trimmed = trimNullChars x
|
||||||
|
escaped = "'" <> replace "'" "''" trimmed <> "'"
|
||||||
|
slashed = replace "\\" "\\\\" escaped in
|
||||||
|
if "\\" `isInfixOf` escaped
|
||||||
|
then "E" <> slashed
|
||||||
|
else slashed
|
||||||
|
|
||||||
|
pgFmtIdent :: SqlFragment -> SqlFragment
|
||||||
|
pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""
|
||||||
|
|
||||||
|
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 :: SqlFragment
|
||||||
|
asJsonF = "coalesce(json_agg(_postgrest_t), '[]')::character varying"
|
||||||
|
|
||||||
|
asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
|
||||||
|
asJsonSingleF = "coalesce(string_agg(row_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 || '=' || coalesce('eq.' || json_data.value, 'is.null'))
|
||||||
|
FROM data CROSS JOIN json_each_text(data.row) AS json_data
|
||||||
|
{("WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')") `emptyOnFalse` null pKeys}
|
||||||
|
)|]
|
||||||
|
|
||||||
|
fromQi :: QualifiedIdentifier -> SqlFragment
|
||||||
|
fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
|
||||||
|
where
|
||||||
|
n = qiName t
|
||||||
|
s = qiSchema t
|
||||||
|
|
||||||
|
unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Statement a b
|
||||||
|
unicodeStatement = H.Statement . T.encodeUtf8
|
||||||
|
|
||||||
|
emptyOnFalse :: Text -> Bool -> Text
|
||||||
|
emptyOnFalse val cond = if cond then "" else val
|
||||||
|
|
||||||
|
pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
|
||||||
|
pgFmtColumn table "*" = fromQi table <> ".*"
|
||||||
|
pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
|
||||||
|
|
||||||
|
pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment
|
||||||
|
pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp
|
||||||
|
|
||||||
|
pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment
|
||||||
|
pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> pgFmtAs fName jp alias
|
||||||
|
pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs fName jp alias
|
||||||
|
|
||||||
|
pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SqlFragment
|
||||||
|
pgFmtOrderTerm qi ot = unwords [
|
||||||
|
toS . pgFmtField qi $ otTerm ot,
|
||||||
|
maybe "" show $ otDirection ot,
|
||||||
|
maybe "" show $ otNullOrder ot]
|
||||||
|
|
||||||
|
pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment
|
||||||
|
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" -> whiteList val
|
||||||
|
_ -> unknownLiteral val
|
||||||
|
|
||||||
|
In vals -> pgFmtField table fld <> " " <>
|
||||||
|
let emptyValForIn = "= any('{}') " in -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"
|
||||||
|
case (&&) (length vals == 1) . T.null <$> headMay vals of
|
||||||
|
Just False -> sqlOperator "in" <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "
|
||||||
|
Just True -> emptyValForIn
|
||||||
|
Nothing -> emptyValForIn
|
||||||
|
|
||||||
|
Fts op lang val ->
|
||||||
|
pgFmtFieldOp op
|
||||||
|
<> "("
|
||||||
|
<> maybe "" ((<> ", ") . pgFmtLit) lang
|
||||||
|
<> unknownLiteral val
|
||||||
|
<> ") "
|
||||||
|
where
|
||||||
|
pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
|
||||||
|
sqlOperator o = HM.lookupDefault "=" o operators
|
||||||
|
notOp = if hasNot then "NOT" else ""
|
||||||
|
star c = if c == '*' then '%' else c
|
||||||
|
unknownLiteral = (<> "::unknown ") . pgFmtLit
|
||||||
|
whiteList :: Text -> SqlFragment
|
||||||
|
whiteList v = fromMaybe
|
||||||
|
(toS (pgFmtLit v) <> "::unknown ")
|
||||||
|
(find ((==) . toLower $ v) ["null","true","false"])
|
||||||
|
|
||||||
|
pgFmtJoinCondition :: JoinCondition -> SqlFragment
|
||||||
|
pgFmtJoinCondition (JoinCondition (qi, col1) (QualifiedIdentifier schema fTable, col2)) =
|
||||||
|
pgFmtColumn qi col1 <> " = " <>
|
||||||
|
pgFmtColumn (removeSourceCTESchema schema fTable) col2
|
||||||
|
|
||||||
|
pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment
|
||||||
|
pgFmtLogicTree qi (Expr hasNot op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")"
|
||||||
|
where notOp = if hasNot then "NOT" else ""
|
||||||
|
pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
|
||||||
|
|
||||||
|
pgFmtJsonPath :: JsonPath -> SqlFragment
|
||||||
|
pgFmtJsonPath = \case
|
||||||
|
[] -> ""
|
||||||
|
(JArrow x:xs) -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
|
||||||
|
(J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
|
||||||
|
where
|
||||||
|
pgFmtJsonOperand (JKey k) = pgFmtLit k
|
||||||
|
pgFmtJsonOperand (JIdx i) = pgFmtLit i <> "::int"
|
||||||
|
|
||||||
|
pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment
|
||||||
|
pgFmtAs _ [] Nothing = ""
|
||||||
|
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 -> ""
|
||||||
|
pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias
|
||||||
|
|
||||||
|
pgFmtSetLocal :: Text -> (Text, Text) -> SqlFragment
|
||||||
|
pgFmtSetLocal prefix (k, v) =
|
||||||
|
"SET LOCAL " <> pgFmtIdent (prefix <> k) <> " = " <> pgFmtLit v <> ";"
|
||||||
|
|
||||||
|
pgFmtSetLocalSearchPath :: [Text] -> SqlFragment
|
||||||
|
pgFmtSetLocalSearchPath vals =
|
||||||
|
"SET LOCAL search_path = " <> intercalate ", " (pgFmtLit <$> vals) <> ";"
|
||||||
|
|
||||||
|
trimNullChars :: Text -> Text
|
||||||
|
trimNullChars = T.takeWhile (/= '\x0')
|
||||||
@@ -0,0 +1,85 @@
|
|||||||
|
module PostgREST.QueryBuilder.Procedure where
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Text (intercalate, unwords)
|
||||||
|
import qualified Hasql.Decoders as HD
|
||||||
|
import qualified Hasql.Encoders as HE
|
||||||
|
import qualified Hasql.Statement as H
|
||||||
|
import PostgREST.QueryBuilder.Private
|
||||||
|
import PostgREST.Types
|
||||||
|
import Protolude hiding (cast,
|
||||||
|
intercalate, replace)
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
|
||||||
|
type ProcResults = (Maybe Int64, Int64, ByteString, ByteString)
|
||||||
|
callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool ->
|
||||||
|
Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion ->
|
||||||
|
H.Statement ByteString (Maybe ProcResults)
|
||||||
|
callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField pgVer =
|
||||||
|
unicodeStatement sql (param HE.unknown) decodeProc True
|
||||||
|
where
|
||||||
|
sql =[qc|
|
||||||
|
WITH
|
||||||
|
{argsRecord},
|
||||||
|
{sourceCTEName} AS (
|
||||||
|
{sourceBody}
|
||||||
|
)
|
||||||
|
SELECT
|
||||||
|
{countResultF} AS total_result_set,
|
||||||
|
pg_catalog.count(_postgrest_t) AS page_total,
|
||||||
|
{bodyF} AS body,
|
||||||
|
{responseHeaders} AS response_headers
|
||||||
|
FROM ({selectQuery}) _postgrest_t;|]
|
||||||
|
|
||||||
|
(argsRecord, args)
|
||||||
|
| paramsAsSingleObject = ("_args_record AS (SELECT NULL)", "$1::json")
|
||||||
|
| null pgArgs = (ignoredBody, "")
|
||||||
|
| otherwise = (
|
||||||
|
unwords [
|
||||||
|
normalizedBody <> ",",
|
||||||
|
"_args_record AS (",
|
||||||
|
"SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <>
|
||||||
|
intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " " <> pgaType a) <$> pgArgs) <> ")",
|
||||||
|
")"]
|
||||||
|
, intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " := _args_record." <> pgFmtIdent (pgaName a)) <$> pgArgs))
|
||||||
|
|
||||||
|
sourceBody :: SqlFragment
|
||||||
|
sourceBody
|
||||||
|
| paramsAsSingleObject || null pgArgs =
|
||||||
|
if returnsScalar
|
||||||
|
then [qc| SELECT {fromQi qi}({args}) |]
|
||||||
|
else [qc| SELECT * FROM {fromQi qi}({args}) |]
|
||||||
|
| otherwise =
|
||||||
|
if returnsScalar
|
||||||
|
then [qc| SELECT {fromQi qi}({args}) FROM _args_record |]
|
||||||
|
else [qc| SELECT _.*
|
||||||
|
FROM _args_record,
|
||||||
|
LATERAL ( SELECT * FROM {fromQi qi}({args}) ) _ |]
|
||||||
|
|
||||||
|
bodyF
|
||||||
|
| returnsScalar = scalarBodyF
|
||||||
|
| isSingle = asJsonSingleF
|
||||||
|
| asCsv = asCsvF
|
||||||
|
| isJust binaryField = asBinaryF $ fromJust binaryField
|
||||||
|
| otherwise = asJsonF
|
||||||
|
|
||||||
|
scalarBodyF
|
||||||
|
| asBinary = asBinaryF _procName
|
||||||
|
| otherwise = unwords [
|
||||||
|
"CASE",
|
||||||
|
"WHEN pg_catalog.count(_postgrest_t) = 1",
|
||||||
|
"THEN (json_agg(_postgrest_t." <> pgFmtIdent _procName <> ")->0)::character varying",
|
||||||
|
"ELSE (json_agg(_postgrest_t." <> pgFmtIdent _procName <> "))::character varying",
|
||||||
|
"END"]
|
||||||
|
|
||||||
|
countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text
|
||||||
|
_procName = qiName qi
|
||||||
|
responseHeaders =
|
||||||
|
if pgVer >= pgVersion96
|
||||||
|
then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
|
||||||
|
else "'[]'" :: Text
|
||||||
|
|
||||||
|
decodeProc = HD.rowMaybe procRow
|
||||||
|
procRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8
|
||||||
|
<*> column HD.bytea <*> column HD.bytea
|
||||||
|
|
||||||
@@ -0,0 +1,32 @@
|
|||||||
|
module PostgREST.QueryBuilder.ReadStatement where
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Text (intercalate)
|
||||||
|
import qualified Hasql.Encoders as HE
|
||||||
|
import qualified Hasql.Statement as H
|
||||||
|
import PostgREST.QueryBuilder.Private
|
||||||
|
import PostgREST.Types
|
||||||
|
import Protolude hiding (cast,
|
||||||
|
intercalate, replace)
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
|
||||||
|
createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName ->
|
||||||
|
H.Statement () ResultsWithCount
|
||||||
|
createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =
|
||||||
|
unicodeStatement sql HE.noParams decodeStandard False
|
||||||
|
where
|
||||||
|
sql = [qc|
|
||||||
|
WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}
|
||||||
|
FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |]
|
||||||
|
countResultF = if countTotal then "("<>countQuery<>")" else "null"
|
||||||
|
cols = intercalate ", " [
|
||||||
|
countResultF <> " AS total_result_set",
|
||||||
|
"pg_catalog.count(_postgrest_t) AS page_total",
|
||||||
|
noLocationF <> " AS header",
|
||||||
|
bodyF <> " AS body"
|
||||||
|
]
|
||||||
|
bodyF
|
||||||
|
| asCsv = asCsvF
|
||||||
|
| isSingle = asJsonSingleF
|
||||||
|
| isJust binaryField = asBinaryF $ fromJust binaryField
|
||||||
|
| otherwise = asJsonF
|
||||||
@@ -0,0 +1,53 @@
|
|||||||
|
module PostgREST.QueryBuilder.WriteStatement where
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Text (intercalate, unwords)
|
||||||
|
import qualified Hasql.Encoders as HE
|
||||||
|
import qualified Hasql.Statement as H
|
||||||
|
import PostgREST.ApiRequest (PreferRepresentation (..))
|
||||||
|
import PostgREST.QueryBuilder.Private
|
||||||
|
import PostgREST.Types
|
||||||
|
import Protolude hiding (cast,
|
||||||
|
intercalate, replace)
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
|
||||||
|
createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
|
||||||
|
PreferRepresentation -> [Text] ->
|
||||||
|
H.Statement ByteString (Maybe ResultsWithCount)
|
||||||
|
createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys =
|
||||||
|
unicodeStatement sql (param HE.unknown) decodeStandardMay True
|
||||||
|
|
||||||
|
where
|
||||||
|
sql = case rep of
|
||||||
|
None -> [qc|
|
||||||
|
WITH {sourceCTEName} AS ({mutateQuery})
|
||||||
|
SELECT '', 0, {noLocationF}, '' |]
|
||||||
|
HeadersOnly -> [qc|
|
||||||
|
WITH {sourceCTEName} AS ({mutateQuery})
|
||||||
|
SELECT {cols}
|
||||||
|
FROM (SELECT 1 FROM {sourceCTEName}) _postgrest_t |]
|
||||||
|
Full -> [qc|
|
||||||
|
WITH {sourceCTEName} AS ({mutateQuery})
|
||||||
|
SELECT {cols}
|
||||||
|
FROM ({selectQuery}) _postgrest_t |]
|
||||||
|
|
||||||
|
cols = intercalate ", " [
|
||||||
|
"'' AS total_result_set", -- when updateing it does not make sense
|
||||||
|
"pg_catalog.count(_postgrest_t) AS page_total",
|
||||||
|
if isInsert
|
||||||
|
then unwords [
|
||||||
|
"CASE",
|
||||||
|
"WHEN pg_catalog.count(_postgrest_t) = 1 THEN",
|
||||||
|
"coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")",
|
||||||
|
"ELSE " <> noLocationF,
|
||||||
|
"END AS header"]
|
||||||
|
else noLocationF <> "AS header",
|
||||||
|
if rep == Full
|
||||||
|
then bodyF <> " AS body"
|
||||||
|
else "''"
|
||||||
|
]
|
||||||
|
|
||||||
|
bodyF
|
||||||
|
| asCsv = asCsvF
|
||||||
|
| wantSingle = asJsonSingleF
|
||||||
|
| otherwise = asJsonF
|
||||||
+1
-1
@@ -1,7 +1,7 @@
|
|||||||
# stack.yaml is used for circle-ci tests. Profiling build fails on circleci
|
# stack.yaml is used for circle-ci tests. Profiling build fails on circleci
|
||||||
# with GHC 8.6, so we build with 8.4 for now.
|
# with GHC 8.6, so we build with 8.4 for now.
|
||||||
|
|
||||||
resolver: lts-12.26
|
resolver: lts-13.29
|
||||||
extra-deps:
|
extra-deps:
|
||||||
- Ranged-sets-0.4.0
|
- Ranged-sets-0.4.0
|
||||||
- configurator-pg-0.1.0.3
|
- configurator-pg-0.1.0.3
|
||||||
|
|||||||
@@ -0,0 +1,96 @@
|
|||||||
|
# This file was autogenerated by Stack.
|
||||||
|
# You should not edit this file by hand.
|
||||||
|
# For more information, please see the documentation at:
|
||||||
|
# https://docs.haskellstack.org/en/stable/lock_files
|
||||||
|
|
||||||
|
packages:
|
||||||
|
- completed:
|
||||||
|
hackage: Ranged-sets-0.4.0@sha256:04bb4ce482fbdc052c9ee3346ba210986b33002b8c3440b714d62750144f86b6,1373
|
||||||
|
pantry-tree:
|
||||||
|
size: 566
|
||||||
|
sha256: ae6809a20be4da39729ac3c6e10b5c311b80628c767184da95903ecff6efc095
|
||||||
|
original:
|
||||||
|
hackage: Ranged-sets-0.4.0
|
||||||
|
- completed:
|
||||||
|
hackage: configurator-pg-0.1.0.3@sha256:ddccf34fef0a5c4f1364ec4c6fda459f089a592e18662b0263ed85ea943c9c70,2885
|
||||||
|
pantry-tree:
|
||||||
|
size: 1008
|
||||||
|
sha256: 5eb16e5536e8bfd921286fb4c97eaaf0c1cb9bdbdf9630a7ffdf1cc64942b79b
|
||||||
|
original:
|
||||||
|
hackage: configurator-pg-0.1.0.3
|
||||||
|
- completed:
|
||||||
|
hackage: http-types-0.12.3@sha256:f35229edb1bc7b3ae27f961b2407dadb5bfa69d43a8f5337ab46cdc79ca4afe9,2035
|
||||||
|
pantry-tree:
|
||||||
|
size: 833
|
||||||
|
sha256: c9b77e1ba204fffbe4e1be80412bc48e47440a07e4b7db4cdc77d573a3e21b9a
|
||||||
|
original:
|
||||||
|
hackage: http-types-0.12.3
|
||||||
|
- completed:
|
||||||
|
hackage: hasql-1.4@sha256:fcb1b0046c1e888b6c4cad53c972d23318dbc6ababa9ceb7d9cfd3b546732bcd,6515
|
||||||
|
pantry-tree:
|
||||||
|
size: 2567
|
||||||
|
sha256: 2e253e7f3052ae4f838d26191355eb0c0b9f344e265b7dec50e13b799ef32450
|
||||||
|
original:
|
||||||
|
hackage: hasql-1.4
|
||||||
|
- completed:
|
||||||
|
hackage: hasql-pool-0.5.1@sha256:a98f2fc38f60eb037a8ac6c5e17591b090089e305f367219c4879812592aaafe,2436
|
||||||
|
pantry-tree:
|
||||||
|
size: 412
|
||||||
|
sha256: 22e4cea8c23ea0eaa871388236c1d3e10349d993fd1bbc602f40aeb4909d6100
|
||||||
|
original:
|
||||||
|
hackage: hasql-pool-0.5.1
|
||||||
|
- completed:
|
||||||
|
hackage: hasql-transaction-0.7.2@sha256:d6d8ceb0b32be75686fe31c4b5bc15c569a71023fc60394893508ea733e8714b,2835
|
||||||
|
pantry-tree:
|
||||||
|
size: 1028
|
||||||
|
sha256: 9bd8c7bf3e30d033192ff53c97e5f1f5e9c08ebfe9a1b3364ab0f9e8f2c2872e
|
||||||
|
original:
|
||||||
|
hackage: hasql-transaction-0.7.2
|
||||||
|
- completed:
|
||||||
|
hackage: text-builder-0.6.5.1@sha256:547f292707c7488c0fbee415adb5fa107d725b720f8697e966a3e3e00cac02cd,4210
|
||||||
|
pantry-tree:
|
||||||
|
size: 542
|
||||||
|
sha256: 5b2be8c9530d3460cadfe142429e0f82bb4b5c238737de473b6f9a25a33e232f
|
||||||
|
original:
|
||||||
|
hackage: text-builder-0.6.5.1
|
||||||
|
- completed:
|
||||||
|
hackage: deferred-folds-0.9.10.1@sha256:eb2634488e2a836da7d5aed9afd15ad2bead38817249f60bb68e459cc32fb0b0,2928
|
||||||
|
pantry-tree:
|
||||||
|
size: 958
|
||||||
|
sha256: b9132db4ffe78f11254871ed88071c5abe1ff41eeffcbec30ce484f24db81c19
|
||||||
|
original:
|
||||||
|
hackage: deferred-folds-0.9.10.1
|
||||||
|
- completed:
|
||||||
|
hackage: primitive-0.6.4.0@sha256:5b6a2c3cc70a35aabd4565fcb9bb1dd78fe2814a36e62428a9a1aae8c32441a1,2079
|
||||||
|
pantry-tree:
|
||||||
|
size: 1517
|
||||||
|
sha256: 5d5e591311664886e88ade3da6880c32adf0d1fe80c55f40a3c93bb91df8fdeb
|
||||||
|
original:
|
||||||
|
hackage: primitive-0.6.4.0
|
||||||
|
- completed:
|
||||||
|
hackage: jose-0.8.1.0@sha256:904e64203f0e074c4601529be2b57c94eec9fd588b19e16165391f8f9e84a6a0,3353
|
||||||
|
pantry-tree:
|
||||||
|
size: 1935
|
||||||
|
sha256: 8d5f80f184b61e89fedbf61d4d7b54ce85326fe67d8ec888117387522c06504d
|
||||||
|
original:
|
||||||
|
hackage: jose-0.8.1.0
|
||||||
|
- completed:
|
||||||
|
hackage: text-printer-0.5.0.1@sha256:9171204826a67c97bc3578968d8b3dcfbd81be08dfd18fef2af71eaf7b2737b1,1502
|
||||||
|
pantry-tree:
|
||||||
|
size: 461
|
||||||
|
sha256: 656053744f42551bc9cffd76746bfae77a249f54ca69497f6835e35312c7b5bb
|
||||||
|
original:
|
||||||
|
hackage: text-printer-0.5.0.1
|
||||||
|
- completed:
|
||||||
|
hackage: network-2.7.0.1@sha256:e8ab30822597c44f0520875699e005c8b284d19000bdacfddbc980c7dfa00bec,2823
|
||||||
|
pantry-tree:
|
||||||
|
size: 2313
|
||||||
|
sha256: 5729e7f6993505243e13fde01833e768024303052becb72f915d8cff1c20e177
|
||||||
|
original:
|
||||||
|
hackage: network-2.7.0.1
|
||||||
|
snapshots:
|
||||||
|
- completed:
|
||||||
|
size: 500539
|
||||||
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/29.yaml
|
||||||
|
sha256: 006398c5e92d1d64737b7e98ae4d63987c36808814504d1451f56ebd98093f75
|
||||||
|
original: lts-13.29
|
||||||
@@ -7,9 +7,9 @@ ko(){ result 'not ok' "- $1"; failedTests=$(( $failedTests + 1 )); }
|
|||||||
|
|
||||||
pgrPort=49421
|
pgrPort=49421
|
||||||
|
|
||||||
pgrStopAll(){ pkill -f "$(stack path --local-install-root)/bin/postgrest"; }
|
pgrStopAll(){ pkill -f "$(stack path --profile --local-install-root)/bin/postgrest"; }
|
||||||
|
|
||||||
pgrStart(){ stack exec -- postgrest test/memory-tests/config +RTS -p -h >/dev/null & pgrPID="$!"; }
|
pgrStart(){ stack exec --profile -- postgrest test/memory-tests/config +RTS -p -h >/dev/null & pgrPID="$!"; }
|
||||||
pgrStop(){ kill "$pgrPID" 2>/dev/null; }
|
pgrStop(){ kill "$pgrPID" 2>/dev/null; }
|
||||||
|
|
||||||
setUp(){ pgrStopAll; }
|
setUp(){ pgrStopAll; }
|
||||||
|
|||||||
Reference in New Issue
Block a user