From 291de5bc1c88ef04483c3f4ac80fa1829c1f4dd4 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Mon, 29 Jul 2019 13:14:06 -0400 Subject: [PATCH] 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 --- .circleci/config.yml | 49 ++- postgrest.cabal | 4 + src/PostgREST/QueryBuilder.hs | 384 +------------------ src/PostgREST/QueryBuilder/Private.hs | 237 ++++++++++++ src/PostgREST/QueryBuilder/Procedure.hs | 85 ++++ src/PostgREST/QueryBuilder/ReadStatement.hs | 32 ++ src/PostgREST/QueryBuilder/WriteStatement.hs | 53 +++ stack.yaml | 2 +- stack.yaml.lock | 96 +++++ test/memory-tests.sh | 4 +- 10 files changed, 552 insertions(+), 394 deletions(-) create mode 100644 src/PostgREST/QueryBuilder/Private.hs create mode 100644 src/PostgREST/QueryBuilder/Procedure.hs create mode 100644 src/PostgREST/QueryBuilder/ReadStatement.hs create mode 100644 src/PostgREST/QueryBuilder/WriteStatement.hs create mode 100644 stack.yaml.lock diff --git a/.circleci/config.yml b/.circleci/config.yml index 98e17f2d9..08cdfb0c5 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -74,8 +74,8 @@ jobs: - run: name: install stack & dependencies 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 - sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin + 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-2.1.3-linux-x86_64/stack /usr/bin sudo apt-get update sudo apt-get install -y libgmp-dev sudo apt-get install -y --only-upgrade binutils @@ -83,6 +83,16 @@ jobs: stack setup rm -rf $(stack path --dist-dir) $(stack path --local-install-root) 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: name: build src and tests command: | @@ -99,11 +109,6 @@ jobs: - run: name: run styler 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: docker: @@ -122,8 +127,8 @@ jobs: - run: name: install stack & dependencies 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 - sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin + 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-2.1.3-linux-x86_64/stack /usr/bin sudo apt-get update sudo apt-get install -y libgmp-dev sudo apt-get install -y postgresql-client @@ -154,8 +159,8 @@ jobs: - run: name: install stack & dependencies 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 - sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin + 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-2.1.3-linux-x86_64/stack /usr/bin sudo apt-get update sudo apt-get install -y libgmp-dev sudo apt-get install -y postgresql-client @@ -186,8 +191,8 @@ jobs: - run: name: install stack & dependencies 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 - sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin + 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-2.1.3-linux-x86_64/stack /usr/bin sudo apt-get update sudo apt-get install -y libgmp-dev sudo apt-get install -y postgresql-client @@ -219,12 +224,21 @@ jobs: - run: name: install stack & dependencies 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 - sudo mv /tmp/stack-1.9.3-linux-x86_64/stack /usr/bin + 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-2.1.3-linux-x86_64/stack /usr/bin sudo apt-get update sudo apt-get install -y libgmp-dev sudo apt-get install -y postgresql-client 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: name: build with profiling enabled command: | @@ -240,11 +254,6 @@ jobs: psql "postgres:///postgrest_test" -f test/fixtures/jsonschema.sql psql "postgres:///postgrest_test" -f test/fixtures/privileges.sql test/memory-tests.sh - - save_cache: - paths: - - "~/.stack" - - ".stack-work" - key: v1-stack-prof-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }} centos6: <<: *build-distro-bin diff --git a/postgrest.cabal b/postgrest.cabal index 7fbd6274f..c915e13c1 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -39,6 +39,10 @@ library PostgREST.RangeQuery PostgREST.Types other-modules: Paths_postgrest + PostgREST.QueryBuilder.Private + PostgREST.QueryBuilder.Procedure + PostgREST.QueryBuilder.ReadStatement + PostgREST.QueryBuilder.WriteStatement hs-source-dirs: src build-depends: base >= 4.9 && < 4.13 , HTTP >= 4000.3.7 && < 4000.4 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 3ccdc6245..29ba252f2 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module : PostgREST.QueryBuilder @@ -17,8 +16,6 @@ module PostgREST.QueryBuilder ( callProc , createReadStatement , createWriteStatement - , pgFmtIdent - , pgFmtLit , requestToQuery , requestToCountQuery , unquoted @@ -27,215 +24,24 @@ module PostgREST.QueryBuilder ( , pgFmtSetLocalSearchPath ) where -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Char8 as BS -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 qualified Data.Aeson as JSON +import qualified Data.Set as S -import Data.Scientific (FPFormat (..), formatScientific, - isInteger) -import Data.Text (intercalate, isInfixOf, replace, - toLower, unwords) -import Data.Tree (Tree (..)) -import Text.InterpolatedString.Perl6 (qc) +import Data.Scientific (FPFormat (..), formatScientific, isInteger) +import Data.Text (intercalate, unwords) +import Data.Tree (Tree (..)) import Data.Maybe -import PostgREST.ApiRequest (PreferRepresentation (..)) -import PostgREST.RangeQuery (allRange, rangeLimit, rangeOffset) +import PostgREST.QueryBuilder.Private +import PostgREST.QueryBuilder.Procedure +import PostgREST.QueryBuilder.ReadStatement +import PostgREST.QueryBuilder.WriteStatement +import PostgREST.RangeQuery (allRange, rangeLimit, + rangeOffset) import PostgREST.Types -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 +import Protolude hiding (cast, + intercalate, replace) requestToCountQuery :: Schema -> DbRequest -> SqlQuery requestToCountQuery _ (DbMutate _) = witness @@ -339,173 +145,9 @@ requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) = where 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.String t) = t unquoted (JSON.Number n) = toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n unquoted (JSON.Bool b) = show b 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') diff --git a/src/PostgREST/QueryBuilder/Private.hs b/src/PostgREST/QueryBuilder/Private.hs new file mode 100644 index 000000000..1e8b6e989 --- /dev/null +++ b/src/PostgREST/QueryBuilder/Private.hs @@ -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') diff --git a/src/PostgREST/QueryBuilder/Procedure.hs b/src/PostgREST/QueryBuilder/Procedure.hs new file mode 100644 index 000000000..0de487753 --- /dev/null +++ b/src/PostgREST/QueryBuilder/Procedure.hs @@ -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 + diff --git a/src/PostgREST/QueryBuilder/ReadStatement.hs b/src/PostgREST/QueryBuilder/ReadStatement.hs new file mode 100644 index 000000000..7f34f065b --- /dev/null +++ b/src/PostgREST/QueryBuilder/ReadStatement.hs @@ -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 diff --git a/src/PostgREST/QueryBuilder/WriteStatement.hs b/src/PostgREST/QueryBuilder/WriteStatement.hs new file mode 100644 index 000000000..ea93b32f5 --- /dev/null +++ b/src/PostgREST/QueryBuilder/WriteStatement.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index d390a0aca..948460010 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,7 @@ # 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. -resolver: lts-12.26 +resolver: lts-13.29 extra-deps: - Ranged-sets-0.4.0 - configurator-pg-0.1.0.3 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 000000000..868cb3d24 --- /dev/null +++ b/stack.yaml.lock @@ -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 diff --git a/test/memory-tests.sh b/test/memory-tests.sh index 16db351b6..2da192e7a 100755 --- a/test/memory-tests.sh +++ b/test/memory-tests.sh @@ -7,9 +7,9 @@ ko(){ result 'not ok' "- $1"; failedTests=$(( $failedTests + 1 )); } 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; } setUp(){ pgrStopAll; }