bump version to 10.2.0

ci: pin Nix version to avoid error
To 2.13.3
2023-04-12 12:49:39 -05:00 · 2023-04-12 12:49:39 -05:00 · 2023-04-12 12:49:36 -05:00 · 2023-04-12 12:49:04 -05:00 · 2023-04-12 09:52:08 -05:00 · 2023-04-12 09:52:08 -05:00
37 changed files with 277 additions and 449 deletions
@@ -12,6 +12,8 @@ runs:
  using: composite
  steps:
    - uses: cachix/install-nix-action@v18
+      with:
+        install_url: https://releases.nixos.org/nix/nix-2.13.3/install
    - uses: cachix/cachix-action@v12
      with:
        name: postgrest
@@ -86,10 +86,6 @@ jobs:
        if: always()
        run: postgrest-with-postgresql-${{ matrix.pgVersion }} -f test/io/fixtures.sql postgrest-test-io

-      - name: Run query cost tests
-        if: always()
-        run: postgrest-with-postgresql-${{ matrix.pgVersion }} postgrest-test-querycost
-

  Test-Memory-Nix:
    name: Test memory (Nix)
@@ -253,7 +249,7 @@ jobs:
      - uses: actions/checkout@v3
      - id: Remote-Dir
        name: Unique directory name for the remote build
-        run: echo "::set-output name=remotepath::postgrest-build-$(uuidgen)"
+        run: echo "remotepath=postgrest-build-$(uuidgen)" >> "$GITHUB_OUTPUT"
      - name: Copy script files to the remote server
        uses: appleboy/scp-action@master
        with:
@@ -326,14 +322,14 @@ jobs:
            exit 1
          else
            echo "Version to be released is $cabal_version"
-            echo "::set-output name=version::$cabal_version"
+            echo "version=$cabal_version" >> "$GITHUB_OUTPUT"
          fi

          if [[ "$cabal_version" != *.*.*.* ]]; then
            echo "Version is for a full release (version does not have four components)"
          else
            echo "Version is for a pre-release (version has four components, e.g., 1.1.1.1)"
-            echo "::set-output name=isprerelease::1"
+            echo "isprerelease=1" >> "$GITHUB_OUTPUT"
          fi
      - name: Identify changes from CHANGELOG.md
        run: |
@@ -3,6 +3,19 @@
 All notable changes to this project will be documented in this file.
 This project adheres to [Semantic Versioning](http://semver.org/).

+## [10.2.0] - 2023-04-12
+
+### Added
+
+ - #2663, Limit maximal postgresql connection lifetime - @robx
+   + New option `db-pool-max-lifetime` (default 30m)
+   + `db-pool-acquisition-timeout` is no longer optional and defaults to 10s
+   + Fixes postgresql resource leak with long-lived connections (#2638)
+
+### Fixed
+
+ - #2667, Fix `db-pool-acquisition-timeout` not logging to stderr when the timeout is reached - @steve-chavez
+
 ## [10.1.2] - 2023-02-01

 ### Fixed
@@ -17,4 +17,4 @@ packages: .
 source-repository-package
  type: git
  location: https://github.com/PostgREST/postgresql-libpq.git
-  tag: 33ff97db570b5b432255f5f24a68db51453f6eb8
+  tag: 890a0a16cf57dd401420fdc6c7d576fb696003bc
@@ -208,12 +208,6 @@ postgrest-loadtest-against master
 postgrest-loadtest-report
 ```

-Our query cost tests ensure that our generated queries don't surpass a threshold EXPLAIN cost.
-
-```bash
-postgrest-test-querycost
-```
-
 doctests for some of our modules are also available:

 ```bash
@@ -1,6 +1,6 @@
 # Pinned version of Nixpkgs, generated with postgrest-nixpkgs-upgrade.
 {
-  date = "2022-10-28";
-  rev = "f44ba1be526c8da9e79a5759feca2365204003f6";
-  tarballHash = "0npbwsdjw88py5w2pjflwh94wgi4jmnmls0k1n7q8m6h94w1y1ps";
+  date = "2023-01-12";
+  rev = "92f9580a4c369b4b51a7b6a5e77da43720134c9f";
+  tarballHash = "0w9bz4f2bmkj4a59n4z279zcgs9clyc40a4ny312rafyaknzghvw";
 }
@@ -29,33 +29,33 @@ let
      # To fill in the sha256:
      #   update-nix-fetchgit nix/overlays/haskell-packages.nix

-      hashtables = lib.dontCheck prev.hashtables_1_3_1;
-      hasql = lib.dontCheck prev.hasql_1_6_1_4;
-      hasql-dynamic-statements = lib.dontCheck prev.hasql-dynamic-statements_0_3_1_2;
-      hasql-pool = lib.dontCheck
-        (prev.callHackageDirect
-          {
-            pkg = "hasql-pool";
-            ver = "0.8.0.6";
-            sha256 = "sha256-2u/cwPk8XfXffaDRzGeyzhL+9k2+2T4b8bGOZwz8AX0=";
-          }
-          { });
-      hasql-transaction = lib.dontCheck prev.hasql-transaction_1_0_1_2;
-      isomorphism-class = lib.unmarkBroken prev.isomorphism-class;
-      lens = lib.dontCheck prev.lens_5_2;
-      postgresql-binary = lib.dontCheck prev.postgresql-binary_0_13_1;
-      text-builder = lib.dontCheck prev.text-builder_0_6_7;
-      text-builder-dev = lib.dontCheck prev.text-builder-dev_0_3_3;
-
      postgresql-libpq = lib.dontCheck
        (prev.callCabal2nix "postgresql-libpq"
          (super.fetchFromGitHub {
            owner = "PostgREST";
            repo = "postgresql-libpq";
-            rev = "cef92cb4c07b56568dffdbf4b719258b82183119"; # master
-            sha256 = "0r59klrz47qcnd22s47h612mlz3jbg40wwalfj3f6djwg0cdyr85";
+            rev = "890a0a16cf57dd401420fdc6c7d576fb696003bc"; # master
+            sha256 = "1wmyhldk0k14y8whp1p4akrkqxf5snh8qsbm7fv5f7kz95nyffd0";
          })
          { });
+
+      hasql-notifications = lib.dontCheck
+        (prev.callHackageDirect
+          {
+            pkg = "hasql-notifications";
+            ver = "0.2.0.4";
+            sha256 = "sha256-fm1xiDyvDkb5WLOJ73/s8wrWEW23XFS7luAv2brfr8I=";
+          }
+          { });
+
+      hasql-pool = lib.dontCheck
+        (prev.callHackageDirect
+          {
+            pkg = "hasql-pool";
+            ver = "0.9";
+            sha256 = "sha256-5UshbbaBVY8eJ/9VagNVVxonRwMcd7UmGqDc35pJNFY=";
+          }
+          { });
    } // extraOverrides final prev;
 in
 {
@@ -77,7 +77,6 @@ let
      }
      ''
        ${tests}/bin/postgrest-test-spec
-        ${tests}/bin/postgrest-test-querycost
        ${tests}/bin/postgrest-test-doctests
        ${tests}/bin/postgrest-test-io
        ${style}/bin/postgrest-lint
@@ -165,6 +164,7 @@ let
          # The following unsets all GIT_ variables.
          unset "''${!GIT_@}"

+          # shellcheck disable=SC2317
          function restore () {
            ref="$(git stash list --format=format:%gD --grep "$1" -n1)"
            # this will avoid merge conflicts when applying the stash
@@ -106,7 +106,7 @@ let
        echo "Tagging ..."
        git tag "v$new_version" > /dev/null

-        trap "Couldn't find remote. Please push manually ..." ERR
+        trap "echo Remote not found. Please push manually ..." ERR
        remote="$(git remote -v | grep PostgREST/postgrest | grep push | cut -f1)"
        trap "" ERR

@@ -32,18 +32,6 @@ let
          test:spec -- "''${_arg_leftovers[@]}"
      '';

-  testQuerycost =
-    checkedShellScript
-      {
-        name = "postgrest-test-querycost";
-        docs = "Run the Haskell test suite for query costs";
-        inRootDir = true;
-        withEnv = postgrest.env;
-      }
-      ''
-        ${withTools.withPg} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:querycost
-      '';
-
  testDoctests =
    checkedShellScript
      {
@@ -140,7 +128,7 @@ let
          rm -rf coverage/*

          # build once before running all the tests
-          ${cabal-install}/bin/cabal v2-build ${devCabalOptions} exe:postgrest lib:postgrest test:spec test:querycost
+          ${cabal-install}/bin/cabal v2-build ${devCabalOptions} exe:postgrest lib:postgrest test:spec

          (
            trap 'echo Found dead code: Check file list above.' ERR ;
@@ -155,14 +143,11 @@ let
          HPCTIXFILE="$tmpdir"/spec.tix \
            ${withTools.withPg} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec

-          HPCTIXFILE="$tmpdir"/querycost.tix \
-            ${withTools.withPg} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:querycost
-
          # Note: No coverage for doctests, as doctests leverage GHCi and GHCi does not support hpc

          # collect all the tix files
          ${ghc}/bin/hpc sum  --union --exclude=Paths_postgrest --output="$tmpdir"/tests.tix \
-            "$tmpdir"/io*.tix "$tmpdir"/spec.tix "$tmpdir"/querycost.tix
+            "$tmpdir"/io*.tix "$tmpdir"/spec.tix

          # prepare the overlay
          ${ghc}/bin/hpc overlay --output="$tmpdir"/overlay.tix test/coverage.overlay
@@ -234,7 +219,6 @@ buildToolbox
  tools =
    [
      testSpec
-      testQuerycost
      testDoctests
      testSpecIdempotence
      testIO
@@ -69,6 +69,7 @@ let
        pg_ctl -l "$tmpdir/db.log" -w start -o "-F -c listen_addresses=\"\" -c hba_file=$HBA_FILE -k $PGHOST -c log_statement=\"all\"" \
          >> "$setuplog"

+        # shellcheck disable=SC2317
        stop () {
          log "Stopping the database cluster..."
          pg_ctl stop -m i >> "$setuplog"
@@ -260,6 +261,7 @@ let
        echo -n "Starting postgrest... "
        ./result/bin/postgrest ${legacyConfig} > "$tmpdir"/run.log 2>&1 &
        pid=$!
+        # shellcheck disable=SC2317
        cleanup() {
          kill "$pid" || true
        }
@@ -1,5 +1,5 @@
 name:               postgrest
-version:            10.1.2
+version:            10.2.0
 synopsis:           REST API for any Postgres database
 description:        Reads the schema of a PostgreSQL database and creates RESTful routes
                    for tables, views, and functions, supporting all HTTP methods that security
@@ -72,7 +72,7 @@ library
                      PostgREST.Workers
  other-modules:      Paths_postgrest
  build-depends:      base                      >= 4.9 && < 4.17
-                    , HTTP                      >= 4000.3.7 && < 4000.4
+                    , HTTP                      >= 4000.3.7 && < 4000.5
                    , Ranged-sets               >= 0.3 && < 0.5
                    , aeson                     >= 2.0.3 && < 2.2
                    , auto-update               >= 0.1.4 && < 0.2
@@ -90,7 +90,7 @@ library
                    , hasql                     >= 1.6.1.1 && < 1.7
                    , hasql-dynamic-statements  >= 0.3.1 && < 0.4
                    , hasql-notifications       >= 0.1 && < 0.3
-                    , hasql-pool                >= 0.8.0.6 && < 0.9
+                    , hasql-pool                >= 0.9 && < 0.10
                    , hasql-transaction         >= 1.0.1 && < 1.1
                    , heredoc                   >= 0.2 && < 0.3
                    , http-types                >= 0.12.2 && < 0.13
@@ -98,11 +98,11 @@ library
                    , interpolatedstring-perl6  >= 1 && < 1.1
                    , jose                      >= 0.8.5.1 && < 0.11
                    , lens                      >= 4.14 && < 5.3
-                    , lens-aeson                >= 1.0.1 && < 1.2
+                    , lens-aeson                >= 1.0.1 && < 1.3
                    , mtl                       >= 2.2.2 && < 2.3
                    , network                   >= 2.6 && < 3.2
                    , network-uri               >= 2.6.1 && < 2.8
-                    , optparse-applicative      >= 0.13 && < 0.17
+                    , optparse-applicative      >= 0.13 && < 0.18
                    , parsec                    >= 3.1.11 && < 3.2
                    , protolude                 >= 0.3.1 && < 0.4
                    , regex-tdfa                >= 1.2.2 && < 1.4
@@ -228,69 +228,32 @@ test-suite spec
                    , bytestring        >= 0.10.8 && < 0.12
                    , case-insensitive  >= 1.2 && < 1.3
                    , containers        >= 0.5.7 && < 0.7
-                    , hasql-pool        >= 0.8.0.2 && < 0.9
+                    , hasql-pool        >= 0.9 && < 0.10
                    , hasql-transaction >= 1.0.1 && < 1.1
                    , heredoc           >= 0.2 && < 0.3
-                    , hspec             >= 2.3 && < 2.9
+                    , hspec             >= 2.3 && < 2.10
                    , hspec-wai         >= 0.10 && < 0.12
                    , hspec-wai-json    >= 0.10 && < 0.12
                    , http-types        >= 0.12.3 && < 0.13
                    , lens              >= 4.14 && < 5.3
-                    , lens-aeson        >= 1.0.1 && < 1.2
+                    , lens-aeson        >= 1.0.1 && < 1.3
                    , monad-control     >= 1.0.1 && < 1.1
                    , postgrest
                    , process           >= 1.4.2 && < 1.7
                    , protolude         >= 0.3.1 && < 0.4
                    , regex-tdfa        >= 1.2.2 && < 1.4
+                    , scientific        >= 0.3.4 && < 0.4
                    , text              >= 1.2.2 && < 1.3
                    , transformers-base >= 0.4.4 && < 0.5
                    , wai               >= 3.2.1 && < 3.3
                    , wai-extra         >= 3.0.19 && < 3.2
-  ghc-options:        -O0 -Werror -Wall -fwarn-identities
+  ghc-options:        -threaded -O0 -Werror -Wall -fwarn-identities
                      -fno-spec-constr -optP-Wno-nonportable-include-path
                      -fno-warn-missing-signatures
                      -fwrite-ide-info
                      -- https://github.com/PostgREST/postgrest/issues/387
                      -with-rtsopts=-K33K

-test-suite querycost
-  type:               exitcode-stdio-1.0
-  default-language:   Haskell2010
-  default-extensions: OverloadedStrings
-                      QuasiQuotes
-                      NoImplicitPrelude
-  hs-source-dirs:     test/spec
-  main-is:            QueryCost.hs
-  other-modules:      SpecHelper
-  build-depends:      base              >= 4.9 && < 4.17
-                    , aeson             >= 2.0.3 && < 2.2
-                    , base64-bytestring >= 1 && < 1.3
-                    , bytestring        >= 0.10.8 && < 0.12
-                    , case-insensitive  >= 1.2 && < 1.3
-                    , containers        >= 0.5.7 && < 0.7
-                    , contravariant     >= 1.4 && < 1.6
-                    , hasql             >= 1.6 && < 1.7
-                    , hasql-dynamic-statements >= 0.3.1 && < 0.4
-                    , hasql-pool        >= 0.8.0.2 && < 0.9
-                    , hasql-transaction >= 1.0.1 && < 1.1
-                    , heredoc           >= 0.2 && < 0.3
-                    , hspec             >= 2.3 && < 2.9
-                    , hspec-wai         >= 0.10 && < 0.12
-                    , hspec-wai-json    >= 0.10 && < 0.12
-                    , http-types        >= 0.12.3 && < 0.13
-                    , lens              >= 4.14 && < 5.3
-                    , lens-aeson        >= 1.0.1 && < 1.2
-                    , postgrest
-                    , process           >= 1.4.2 && < 1.7
-                    , protolude         >= 0.3.1 && < 0.4
-                    , regex-tdfa        >= 1.2.2 && < 1.4
-                    , wai-extra         >= 3.0.19 && < 3.2
-  ghc-options:        -O0 -Werror -Wall -fwarn-identities
-                      -fno-spec-constr -optP-Wno-nonportable-include-path
-                      -fwrite-ide-info
-                      -- https://github.com/PostgREST/postgrest/issues/387
-                      -with-rtsopts=-K1K
-
 test-suite doctests
  type:               exitcode-stdio-1.0
  default-language:   Haskell2010
@@ -139,7 +139,7 @@ parse qs =
    <*> (fmap snd <$> (pRequestFilter `traverse` filtersRoot))
    <*> pRequestFilter `traverse` filtersNotRoot
    <*> pure (S.fromList (fst <$> filters))
-    <*> sequenceA (pRequestOnConflict <$> onConflict)
+    <*> pRequestOnConflict `traverse` onConflict
  where
    logic = filter (endingIn ["and", "or"] . fst) nonemptyParams
    select = fromMaybe "*" $ lookupParam "select"
@@ -9,6 +9,7 @@ Some of its functionality includes:
 - Producing HTTP Headers according to RFCs.
 - Content Negotiation
 -}
+{-# LANGUAGE LambdaCase      #-}
 {-# LANGUAGE RecordWildCards #-}
 module PostgREST.App
  ( SignalHandlerInstaller
@@ -19,13 +20,14 @@ module PostgREST.App


 import Control.Monad.Except     (liftEither)
-import Data.Either.Combinators  (mapLeft)
+import Data.Either.Combinators  (mapLeft, whenLeft)
 import Data.Maybe               (fromJust)
 import Data.String              (IsString (..))
 import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
                                 setServerName)
 import System.Posix.Types       (FileMode)

+import qualified Hasql.Pool                 as SQL
 import qualified Hasql.Transaction.Sessions as SQL
 import qualified Network.Wai                as Wai
 import qualified Network.Wai.Handler.Warp   as Warp
@@ -153,9 +155,13 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jsonDbS pgVer aut

 runDbHandler :: AppState.AppState -> SQL.Mode -> Bool -> Bool -> DbHandler b -> Handler IO b
 runDbHandler appState mode authenticated prepared handler = do
-  dbResp <-
-    let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
-    lift . AppState.usePool appState . transaction SQL.ReadCommitted mode $ runExceptT handler
+  dbResp <- lift $ do
+    let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction
+    res <- AppState.usePool appState . transaction SQL.ReadCommitted mode $ runExceptT handler
+    whenLeft res (\case
+      SQL.AcquisitionTimeoutUsageError -> AppState.debounceLogAcquisitionTimeout appState -- this can happen rapidly for many requests, so we debounce
+      _ -> pure ())
+    return res

  resp <-
    liftEither . mapLeft Error.PgErr $
@@ -16,6 +16,7 @@ module PostgREST.AppState
  , init
  , initWithPool
  , logWithZTime
+  , logPgrstError
  , putConfig
  , putSchemaCache
  , putIsListenerOn
@@ -25,13 +26,18 @@ module PostgREST.AppState
  , signalListener
  , usePool
  , waitListener
+  , debounceLogAcquisitionTimeout
  ) where

-import qualified Hasql.Pool    as SQL
-import qualified Hasql.Session as SQL
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text.Encoding   as T
+import qualified Hasql.Pool           as SQL
+import qualified Hasql.Session        as SQL
+import qualified PostgREST.Error      as Error

 import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
                           updateAction)
+import Control.Debounce
 import Data.IORef         (IORef, atomicWriteIORef, newIORef,
                           readIORef)
 import Data.Time          (ZonedTime, defaultTimeLocale, formatTime,
@@ -47,29 +53,31 @@ import Protolude

 data AppState = AppState
  -- | Database connection pool
-  { statePool         :: SQL.Pool
+  { statePool                     :: SQL.Pool
  -- | Database server version, will be updated by the connectionWorker
-  , statePgVersion    :: IORef PgVersion
+  , statePgVersion                :: IORef PgVersion
  -- | No schema cache at the start. Will be filled in by the connectionWorker
-  , stateSchemaCache  :: IORef (Maybe SchemaCache)
+  , stateSchemaCache              :: IORef (Maybe SchemaCache)
  -- | Cached SchemaCache in json
-  , stateJsonDbS      :: IORef ByteString
+  , stateJsonDbS                  :: IORef ByteString
  -- | Binary semaphore to make sure just one connectionWorker can run at a time
-  , stateWorkerSem    :: MVar ()
+  , stateWorkerSem                :: MVar ()
  -- | Binary semaphore used to sync the listener(NOTIFY reload) with the connectionWorker.
-  , stateListener     :: MVar ()
+  , stateListener                 :: MVar ()
  -- | State of the LISTEN channel, used for the admin server checks
-  , stateIsListenerOn :: IORef Bool
+  , stateIsListenerOn             :: IORef Bool
  -- | Config that can change at runtime
-  , stateConf         :: IORef AppConfig
+  , stateConf                     :: IORef AppConfig
  -- | Time used for verifying JWT expiration
-  , stateGetTime      :: IO UTCTime
+  , stateGetTime                  :: IO UTCTime
  -- | Time with time zone used for worker logs
-  , stateGetZTime     :: IO ZonedTime
+  , stateGetZTime                 :: IO ZonedTime
  -- | Used for killing the main thread in case a subthread fails
-  , stateMainThreadId :: ThreadId
+  , stateMainThreadId             :: ThreadId
  -- | Keeps track of when the next retry for connecting to database is scheduled
-  , stateRetryNextIn  :: IORef Int
+  , stateRetryNextIn              :: IORef Int
+  -- | Logs a pool error with a debounce
+  , debounceLogAcquisitionTimeout :: IO ()
  }

 init :: AppConfig -> IO AppState
@@ -78,8 +86,8 @@ init conf = do
  initWithPool pool conf

 initWithPool :: SQL.Pool -> AppConfig -> IO AppState
-initWithPool pool conf =
-  AppState pool
+initWithPool pool conf = do
+  appState <- AppState pool
    <$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
    <*> newIORef Nothing
    <*> newIORef mempty
@@ -91,16 +99,28 @@ initWithPool pool conf =
    <*> mkAutoUpdate defaultUpdateSettings { updateAction = getZonedTime }
    <*> myThreadId
    <*> newIORef 0
+    <*> pure (pure ())
+
+  deb <-
+    let oneSecond = 1000000 in
+    mkDebounce defaultDebounceSettings
+       { debounceAction = logPgrstError appState SQL.AcquisitionTimeoutUsageError
+       , debounceFreq = 5*oneSecond
+       , debounceEdge = leadingEdge -- logs at the start and the end
+       }
+
+  return appState { debounceLogAcquisitionTimeout = deb }

 destroy :: AppState -> IO ()
 destroy = destroyPool

 initPool :: AppConfig -> IO SQL.Pool
 initPool AppConfig{..} =
-  SQL.acquire configDbPoolSize timeoutMilliseconds $ toUtf8 configDbUri
-  where
-    timeoutMilliseconds = (* oneSecond) <$> configDbPoolAcquisitionTimeout
-    oneSecond = 1000000
+  SQL.acquire
+    configDbPoolSize
+    (fromIntegral configDbPoolAcquisitionTimeout)
+    (fromIntegral configDbPoolMaxLifetime)
+    (toUtf8 configDbUri)

 -- | Run an action with a database connection.
 usePool :: AppState -> SQL.Session a -> IO (Either SQL.UsageError a)
@@ -157,6 +177,9 @@ logWithZTime appState txt = do
  zTime <- stateGetZTime appState
  hPutStrLn stderr $ toS (formatTime defaultTimeLocale "%d/%b/%Y:%T %z: " zTime) <> txt

+logPgrstError :: AppState -> SQL.UsageError -> IO ()
+logPgrstError appState e = logWithZTime appState . T.decodeUtf8 . LBS.toStrict $ Error.errorPayload $ Error.PgError False e
+
 getMainThreadId :: AppState -> ThreadId
 getMainThreadId = stateMainThreadId

@@ -151,6 +151,9 @@ exampleConfigFile =
      |## Time in seconds to wait to acquire a slot from the connection pool
      |# db-pool-acquisition-timeout = 10
      |
+      |## Time in seconds after which to recycle pool connections
+      |# db-pool-max-lifetime = 1800
+      |
      |## Stored proc to exec immediately after auth
      |# db-pre-request = "stored_proc_name"
      |
@@ -70,7 +70,8 @@ data AppConfig = AppConfig
  , configDbMaxRows                :: Maybe Integer
  , configDbPlanEnabled            :: Bool
  , configDbPoolSize               :: Int
-  , configDbPoolAcquisitionTimeout :: Maybe Int
+  , configDbPoolAcquisitionTimeout :: Int
+  , configDbPoolMaxLifetime        :: Int
  , configDbPreRequest             :: Maybe QualifiedIdentifier
  , configDbPreparedStatements     :: Bool
  , configDbRootSpec               :: Maybe QualifiedIdentifier
@@ -130,7 +131,8 @@ toText conf =
      ,("db-max-rows",                   maybe "\"\"" show . configDbMaxRows)
      ,("db-plan-enabled",               T.toLower . show . configDbPlanEnabled)
      ,("db-pool",                       show . configDbPoolSize)
-      ,("db-pool-acquisition-timeout",   maybe "\"\"" show . configDbPoolAcquisitionTimeout)
+      ,("db-pool-acquisition-timeout",   show . configDbPoolAcquisitionTimeout)
+      ,("db-pool-max-lifetime",          show . configDbPoolMaxLifetime)
      ,("db-pre-request",            q . maybe mempty dumpQi . configDbPreRequest)
      ,("db-prepared-statements",        T.toLower . show . configDbPreparedStatements)
      ,("db-root-spec",              q . maybe mempty dumpQi . configDbRootSpec)
@@ -219,7 +221,8 @@ parser optPath env dbSettings =
                     (optInt "max-rows")
    <*> (fromMaybe False <$> optBool "db-plan-enabled")
    <*> (fromMaybe 10 <$> optInt "db-pool")
-    <*> optInt "db-pool-acquisition-timeout"
+    <*> (fromMaybe 10 <$> optInt "db-pool-acquisition-timeout")
+    <*> (fromMaybe 1800 <$> optInt "db-pool-max-lifetime")
    <*> (fmap toQi <$> optWithAlias (optString "db-pre-request")
                                    (optString "pre-request"))
    <*> (fromMaybe True <$> optBool "db-prepared-statements")
@@ -355,7 +358,8 @@ parser optPath env dbSettings =
          let dbSettingName = T.pack $ dashToUnderscore <$> toS key in
          if dbSettingName `notElem` [
            "server_host", "server_port", "server_unix_socket", "server_unix_socket_mode", "admin_server_port", "log_level",
-            "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_acquisition_timeout", "db_config"]
+            "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_acquisition_timeout",
+            "db_pool_max_lifetime", "db_config"]
          then lookup dbSettingName dbSettings
          else Nothing

@@ -424,13 +424,13 @@ pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError

    _                       -> HTTP.status500

-checkIsFatal :: PgError -> Maybe Text
-checkIsFatal (PgError _ (SQL.ConnectionUsageError e))
+checkIsFatal :: SQL.UsageError -> Maybe Text
+checkIsFatal (SQL.ConnectionUsageError e)
  | isAuthFailureMessage = Just $ toS failureMessage
  | otherwise = Nothing
  where isAuthFailureMessage = "FATAL:  password authentication failed" `isInfixOf` failureMessage
        failureMessage = BS.unpack $ fromMaybe mempty e
-checkIsFatal (PgError _ (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError serverError))))
+checkIsFatal(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError serverError)))
  = case serverError of
      -- Check for a syntax error (42601 is the pg code). This would mean the error is on our part somehow, so we treat it as fatal.
      SQL.ServerError "42601" _ _ _ _
@@ -399,7 +399,7 @@ test         | personnages_view     | test       | actors_view      | personnage
 -}
 addViewM2OAndO2ORels :: [ViewKeyDependency] -> [Relationship] -> [Relationship]
 addViewM2OAndO2ORels keyDeps rels =
-  rels ++ concat (viewRels <$> rels)
+  rels ++ concatMap viewRels rels
  where
    isM2O card = case card of {M2O _ _ -> True; _ -> False;}
    isO2O card = case card of {O2O _ _ -> True; _ -> False;}
@@ -449,7 +449,7 @@ addViewM2OAndO2ORels keyDeps rels =
        , keyDepColsTblVw <- expandKeyDepCols $ keyDepCols tblVw ]
      else []
    viewRels _ = []
-    expandKeyDepCols kdc = zip (fst <$> kdc) <$> sequenceA (snd <$> kdc)
+    expandKeyDepCols kdc = zip (fst <$> kdc) <$> traverse snd kdc

 addInverseRels :: [Relationship] -> [Relationship]
 addInverseRels rels =
@@ -485,7 +485,7 @@ addViewPrimaryKeys tabs keyDeps =
    -- * We don't have any logic that requires the client to name a PK column (compared to the column hints in embedding for FKs),
    --   so we don't need to know about the other references.
    -- * We need to choose a single reference for each column, otherwise we'd output too many columns in location headers etc.
-    takeFirstPK pkCols = catMaybes $ head . snd <$> pkCols
+    takeFirstPK = mapMaybe (head . snd)

 allTables :: PgVersion -> Bool -> SQL.Statement [Schema] TablesMap
 allTables pgVer =
@@ -13,7 +13,6 @@ import qualified Data.Aeson                 as JSON
 import qualified Data.ByteString            as BS
 import qualified Data.ByteString.Lazy       as LBS
 import qualified Data.Text                  as T
-import qualified Data.Text.Encoding         as T
 import qualified Hasql.Notifications        as SQL
 import qualified Hasql.Session              as SQL
 import qualified Hasql.Transaction.Sessions as SQL
@@ -32,8 +31,7 @@ import PostgREST.AppState         (AppState)
 import PostgREST.Config           (AppConfig (..), readAppConfig)
 import PostgREST.Config.Database  (queryDbSettings, queryPgVersion)
 import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion)
-import PostgREST.Error            (PgError (PgError), checkIsFatal,
-                                   errorPayload)
+import PostgREST.Error            (checkIsFatal)
 import PostgREST.SchemaCache      (querySchemaCache)

 import qualified PostgREST.AppState as AppState
@@ -131,9 +129,8 @@ establishConnection appState =
      pgVersion <- AppState.usePool appState queryPgVersion
      case pgVersion of
        Left e -> do
-          let err = PgError False e
-          AppState.logWithZTime appState . T.decodeUtf8 . LBS.toStrict $ errorPayload err
-          case checkIsFatal err of
+          AppState.logPgrstError appState e
+          case checkIsFatal e of
            Just reason ->
              return $ FatalConnectionError reason
            Nothing ->
@@ -168,19 +165,16 @@ loadSchemaCache appState = do
      querySchemaCache (toList configDbSchemas) configDbExtraSearchPath configDbPreparedStatements
  case result of
    Left e -> do
-      let
-        err = PgError False e
-        putErr = AppState.logWithZTime appState . T.decodeUtf8 . LBS.toStrict $ errorPayload err
-      case checkIsFatal err of
+      case checkIsFatal e of
        Just hint -> do
          AppState.logWithZTime appState "A fatal error ocurred when loading the schema cache"
-          putErr
+          AppState.logPgrstError appState e
          AppState.logWithZTime appState hint
          return SCFatalFail
        Nothing -> do
          AppState.putSchemaCache appState Nothing
          AppState.logWithZTime appState "An error ocurred when loading the schema cache"
-          putErr
+          AppState.logPgrstError appState e
          return SCOnRetry

    Right sCache -> do
@@ -249,18 +243,15 @@ reReadConfig startingUp appState = do
      qDbSettings <- AppState.usePool appState $ queryDbSettings configDbPreparedStatements
      case qDbSettings of
        Left e -> do
-          let
-            err = PgError False e
-            putErr = AppState.logWithZTime appState . T.decodeUtf8 . LBS.toStrict $ errorPayload err
          AppState.logWithZTime appState
            "An error ocurred when trying to query database settings for the config parameters"
-          case checkIsFatal err of
+          case checkIsFatal e of
            Just hint -> do
-              putErr
+              AppState.logPgrstError appState e
              AppState.logWithZTime appState hint
              killThread (AppState.getMainThreadId appState)
            Nothing -> do
-              putErr
+              AppState.logPgrstError appState e
          pure []
        Right x -> pure x
    else
@@ -1,4 +1,4 @@
-resolver: lts-19.14 # 2022-07-01, GHC 9.0.2
+resolver: lts-20.6 # 2023-01-09, GHC 9.2.5

 nix:
  packages:
@@ -10,23 +10,7 @@ nix:
  pure: false

 extra-deps:
-  - HTTP-4000.3.16
-  - configurator-pg-0.2.6
-  - hashable-1.4.1.0
-  - hashtables-1.3
-  - hasql-1.6.1.1
-  - hasql-dynamic-statements-0.3.1.2
-  - hasql-implicits-0.1.0.5
-  - hasql-notifications-0.2.0.3
-  - hasql-pool-0.8.0.6
-  - hasql-transaction-1.0.1.2
-  - isomorphism-class-0.1.0.6
-  - lens-aeson-1.1.3
-  - optparse-applicative-0.16.1.0
-  - postgresql-binary-0.12.5
-  - protolude-0.3.2
-  - ptr-0.16.8.2
-  - text-builder-0.6.7
-  - text-builder-dev-0.3.3
  - git: https://github.com/PostgREST/postgresql-libpq.git
-    commit: 33ff97db570b5b432255f5f24a68db51453f6eb8
+    commit: 890a0a16cf57dd401420fdc6c7d576fb696003bc
+  - hasql-notifications-0.2.0.4
+  - hasql-pool-0.9
@@ -5,145 +5,33 @@

 packages:
 - completed:
-    hackage: HTTP-4000.3.16@sha256:6042643c15a0b43e522a6693f1e322f05000d519543a84149cb80aeffee34f71,5947
-    pantry-tree:
-      size: 1428
-      sha256: b73a7f6d21cf20bbf819e19039409c9010efb5000d2b72cdd8fd67a9027c14e8
-  original:
-    hackage: HTTP-4000.3.16
- completed:
-    hackage: configurator-pg-0.2.6@sha256:cd9b06a458428e493a4d6def725af7ab1ab0fef678fbd871f9586fc7f9aa70be,2849
-    pantry-tree:
-      size: 2463
-      sha256: 97efe7a22afc93033bda5adcffdabc0f1c30dc32b2c3ba02114ce7cd74c942fd
-  original:
-    hackage: configurator-pg-0.2.6
- completed:
-    hackage: hashable-1.4.1.0@sha256:50b2f002c68fe67730ee7a3cd8607486197dd99b084255005ad51ecd6970a41b,5019
-    pantry-tree:
-      size: 1248
-      sha256: 9af2f7a42674f7effcabbebc043f97057240783f1709338a77f58216f4a5f18c
-  original:
-    hackage: hashable-1.4.1.0
- completed:
-    hackage: hashtables-1.3@sha256:ab21804fdafbbd8ad918b2911dabb729ae0ea891780fe66bf7804cbcd07edadf,10379
-    pantry-tree:
-      size: 2895
-      sha256: e71f113ad989dbc994e0fb52bcc219d62930de9afa8b3441bf7909e864481b33
-  original:
-    hackage: hashtables-1.3
- completed:
-    hackage: hasql-1.6.1.1@sha256:948a2137308cc5354e4997bc3666753867124cd25db792424cb9614b1c1b44cf,6626
-    pantry-tree:
-      size: 2622
-      sha256: 28d21bf061522fc513f040e9c383b90532222b7258216cc094e07736add8be10
-  original:
-    hackage: hasql-1.6.1.1
- completed:
-    hackage: hasql-dynamic-statements-0.3.1.2@sha256:417aa533c84f074e2fa16bb2c4d4231326aa512097dd1025d915388e56acd1eb,2675
-    pantry-tree:
-      size: 595
-      sha256: 91696d3f3e0ef3254772ae5a8e4e89be68285febb49b302ed83d85ac4037a417
-  original:
-    hackage: hasql-dynamic-statements-0.3.1.2
- completed:
-    hackage: hasql-implicits-0.1.0.5@sha256:d16aacad6dc21428d72447d3ae8bcc03839a2f0aa1ec29c797ed9aca4609f9af,1361
-    pantry-tree:
-      size: 264
-      sha256: 0451b99a0a1d02db673d0c40acdf60d4e769e15852eed9e8dc05bffaf43efb70
-  original:
-    hackage: hasql-implicits-0.1.0.5
- completed:
-    hackage: hasql-notifications-0.2.0.3@sha256:aca3f7ee847a8f0b7ef6f989dc48f4a094a06c1a34e92aa3c8bb230085966ea6,2027
-    pantry-tree:
-      size: 452
-      sha256: 999f0f2856a00d21f4498a8a58452bbefc4ea972fe2984fd234a68a5fe61d98b
-  original:
-    hackage: hasql-notifications-0.2.0.3
- completed:
-    hackage: hasql-pool-0.8.0.6@sha256:b63bb83409bab5bc20ff24f5d62205e9b117701a0fc24531ddeac20ab8c2a42c,1818
-    pantry-tree:
-      size: 346
-      sha256: c4100946b7eae44375511e35a393abe2e1db0e5637c68cea8f53176b796bfd5b
-  original:
-    hackage: hasql-pool-0.8.0.6
- completed:
-    hackage: hasql-transaction-1.0.1.2@sha256:297b158cd1f0727f9b0e175bd7d3741c1bcb725a8094956d0ee79b41aafdb30a,2890
-    pantry-tree:
-      size: 983
-      sha256: 3679e6d5c835cc17a8fa0c252b8221e282880044b7219aa1de2531bbd5c40691
-  original:
-    hackage: hasql-transaction-1.0.1.2
- completed:
-    hackage: isomorphism-class-0.1.0.6@sha256:d93da31287359c761953b876354de28381f409c5c50e3241c572a443e50c553d,1703
-    pantry-tree:
-      size: 465
-      sha256: c97f922d1ae8f1a0db4c28fac9383d2716934879e95ff0b2b88ebb861d6fba14
-  original:
-    hackage: isomorphism-class-0.1.0.6
- completed:
-    hackage: lens-aeson-1.1.3@sha256:52c8eaecd2d1c2a969c0762277c4a8ee72c339a686727d5785932e72ef9c3050,1764
-    pantry-tree:
-      size: 541
-      sha256: b31392b78f2a03111c805f4400007778eb93b49f998ab41dfbebaaf9b5526bad
-  original:
-    hackage: lens-aeson-1.1.3
- completed:
-    hackage: optparse-applicative-0.16.1.0@sha256:418c22ed6a19124d457d96bc66bd22c93ac22fad0c7100fe4972bbb4ac989731,4982
-    pantry-tree:
-      size: 2979
-      sha256: dd092d843091c08691485d68a1908517079b1bc6f3d73928f37635a19dc27fc1
-  original:
-    hackage: optparse-applicative-0.16.1.0
- completed:
-    hackage: postgresql-binary-0.12.5@sha256:de9da3cba9be541d6c75ae8da2858c33d83dc1b2e0c639b0b9781816b78a91f4,5594
-    pantry-tree:
-      size: 1619
-      sha256: b392337f91031a5b3407393e2f04dfe4e7a28019e88eae6a9370538b90e28c51
-  original:
-    hackage: postgresql-binary-0.12.5
- completed:
-    hackage: protolude-0.3.2@sha256:2a38b3dad40d238ab644e234b692c8911423f9d3ed0e36b62287c4a698d92cd1,2240
-    pantry-tree:
-      size: 1594
-      sha256: a36d2912ac552d950ba4476de7d950b56b82dd28e48b9f4d0efee938f10bc525
-  original:
-    hackage: protolude-0.3.2
- completed:
-    hackage: ptr-0.16.8.2@sha256:708ebb95117f2872d2c5a554eb6804cf1126e86abe793b2673f913f14e5eb1ac,3959
-    pantry-tree:
-      size: 1303
-      sha256: 557c438345de19f82bf01d676100da2a191ef06f624e7a4b90b09ac17cbb52a5
-  original:
-    hackage: ptr-0.16.8.2
- completed:
-    hackage: text-builder-0.6.7@sha256:efbb3e06107e9c8d1cfe85c963938ca9f375a74379af03da3173be4ef5c37bcf,2364
-    pantry-tree:
-      size: 425
-      sha256: cd0ae197e6f9f3860a8ab71f5b87c4a8452ed1fce2fdfd35e36d68ded6e6648e
-  original:
-    hackage: text-builder-0.6.7
- completed:
-    hackage: text-builder-dev-0.3.3@sha256:79ec422defcc2e5b34f94129c72b98d34b2efc1ed8bbd945ccb8f4f535a892c3,2784
-    pantry-tree:
-      size: 724
-      sha256: 8883631a132438e7892fcb13e89d6bbcdc0ac76c56fbea8df8d7aa482ce81f73
-  original:
-    hackage: text-builder-dev-0.3.3
- completed:
+    commit: 890a0a16cf57dd401420fdc6c7d576fb696003bc
+    git: https://github.com/PostgREST/postgresql-libpq.git
    name: postgresql-libpq
-    version: 0.9.4.3
-    git: https://github.com/PostgREST/postgresql-libpq.git
    pantry-tree:
-      size: 1081
-      sha256: 0df271e48af32eb8292a45301af45e114110d54099ee73dbc609d39770e8175e
-    commit: 33ff97db570b5b432255f5f24a68db51453f6eb8
+      sha256: 074668b9669b9c49f3c522c8af5c608799a1965e203c463b188b2632995beac2
+      size: 1414
+    version: 0.9.4.3
  original:
+    commit: 890a0a16cf57dd401420fdc6c7d576fb696003bc
    git: https://github.com/PostgREST/postgresql-libpq.git
-    commit: 33ff97db570b5b432255f5f24a68db51453f6eb8
+- completed:
+    hackage: hasql-notifications-0.2.0.4@sha256:9a09fa9b97feadd9492c8bd8bc6b9cffe0513510102f08374b0c45ecd479ed67,2028
+    pantry-tree:
+      sha256: 56f9e240728e7a65711dde45fa2e2075b914e32cd370424aaa4572392378a60e
+      size: 452
+  original:
+    hackage: hasql-notifications-0.2.0.4
+- completed:
+    hackage: hasql-pool-0.9@sha256:db7a37f6b3a922c37adc3c7ced47a7c10786d1f171e47a735a6e812a587ba44c,2111
+    pantry-tree:
+      sha256: 49b1181d28c6f5317e794671c2dae155754b834bdcfa30f7e5dbad28e4cf0249
+      size: 346
+  original:
+    hackage: hasql-pool-0.9
 snapshots:
 - completed:
-    size: 618951
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/14.yaml
-    sha256: 4c31d4ef975b0211078862566aedf3b82b6cea569fc2cde4c72a51e5a8d236ce
-  original: lts-19.14
+    sha256: 4905c93319aa94aa53da8f41d614d7bacdbfe6c63a8c6132d32e6e62f24a9af4
+    size: 649315
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/6.yaml
+  original: lts-20.6
@@ -5,7 +5,8 @@ db-extra-search-path = "public"
 db-max-rows = 1000
 db-plan-enabled = false
 db-pool = 10
-db-pool-acquisition-timeout = ""
+db-pool-acquisition-timeout = 10
+db-pool-max-lifetime = 1800
 db-pre-request = "check_alias"
 db-prepared-statements = true
 db-root-spec = "open_alias"
@@ -5,7 +5,8 @@ db-extra-search-path = "public"
 db-max-rows = ""
 db-plan-enabled = false
 db-pool = 10
-db-pool-acquisition-timeout = ""
+db-pool-acquisition-timeout = 10
+db-pool-max-lifetime = 1800
 db-pre-request = ""
 db-prepared-statements = false
 db-root-spec = ""
@@ -5,7 +5,8 @@ db-extra-search-path = "public"
 db-max-rows = ""
 db-plan-enabled = false
 db-pool = 10
-db-pool-acquisition-timeout = ""
+db-pool-acquisition-timeout = 10
+db-pool-max-lifetime = 1800
 db-pre-request = ""
 db-prepared-statements = false
 db-root-spec = ""
@@ -5,7 +5,8 @@ db-extra-search-path = "public"
 db-max-rows = ""
 db-plan-enabled = false
 db-pool = 10
-db-pool-acquisition-timeout = ""
+db-pool-acquisition-timeout = 10
+db-pool-max-lifetime = 1800
 db-pre-request = ""
 db-prepared-statements = true
 db-root-spec = ""
@@ -5,7 +5,8 @@ db-extra-search-path = "public,extensions,other"
 db-max-rows = 100
 db-plan-enabled = true
 db-pool = 1
-db-pool-acquisition-timeout = 10
+db-pool-acquisition-timeout = 30
+db-pool-max-lifetime = 3600
 db-pre-request = "test.other_custom_headers"
 db-prepared-statements = false
 db-root-spec = "other_root"
@@ -5,7 +5,8 @@ db-extra-search-path = "public,extensions,private"
 db-max-rows = 1000
 db-plan-enabled = true
 db-pool = 1
-db-pool-acquisition-timeout = 10
+db-pool-acquisition-timeout = 30
+db-pool-max-lifetime = 3600
 db-pre-request = "test.custom_headers"
 db-prepared-statements = false
 db-root-spec = "root"
@@ -5,7 +5,8 @@ db-extra-search-path = "public,test"
 db-max-rows = 1000
 db-plan-enabled = true
 db-pool = 1
-db-pool-acquisition-timeout = 10
+db-pool-acquisition-timeout = 30
+db-pool-max-lifetime = 3600
 db-pre-request = "please_run_fast"
 db-prepared-statements = false
 db-root-spec = "openapi_v3"
@@ -5,7 +5,8 @@ db-extra-search-path = "public"
 db-max-rows = ""
 db-plan-enabled = false
 db-pool = 10
-db-pool-acquisition-timeout = ""
+db-pool-acquisition-timeout = 10
+db-pool-max-lifetime = 1800
 db-pre-request = ""
 db-prepared-statements = true
 db-root-spec = ""
@@ -7,7 +7,8 @@ PGRST_DB_EXTRA_SEARCH_PATH: public, test
 PGRST_DB_MAX_ROWS: 1000
 PGRST_DB_PLAN_ENABLED: true
 PGRST_DB_POOL: 1
-PGRST_DB_POOL_ACQUISITION_TIMEOUT: 10
+PGRST_DB_POOL_ACQUISITION_TIMEOUT: 30
+PGRST_DB_POOL_MAX_LIFETIME: 3600
 PGRST_DB_PREPARED_STATEMENTS: false
 PGRST_DB_PRE_REQUEST: please_run_fast
 PGRST_DB_ROOT_SPEC: openapi_v3
@@ -5,7 +5,8 @@ db-extra-search-path = "public, test"
 db-max-rows = 1000
 db-plan-enabled = true
 db-pool = 1
-db-pool-acquisition-timeout = 10
+db-pool-acquisition-timeout = 30
+db-pool-max-lifetime = 3600
 db-pre-request = "please_run_fast"
 db-prepared-statements = false
 db-root-spec = "openapi_v3"
@@ -572,6 +572,16 @@ def test_pool_acquisition_timeout(defaultenv, metapostgrest):
        data = response.json()
        assert data["message"] == "Timed out acquiring connection from connection pool."

+        # ensure the message appears on the logs as well
+        output = None
+        for _ in range(10):
+            output = postgrest.process.stdout.readline()
+            if output:
+                break
+            time.sleep(0.1)
+
+        assert "Timed out acquiring connection from connection pool." in output.decode()
+

 def test_change_statement_timeout_held_connection(defaultenv, metapostgrest):
    "Statement timeout changes take effect immediately, even with a request outliving the reconfiguration"
@@ -13,9 +13,10 @@ import           Network.HTTP.Types
 import           Test.Hspec           hiding (pendingWith)
 import           Test.Hspec.Wai
 import           Test.Hspec.Wai.JSON
+import           Text.Heredoc

-import PostgREST.Config.PgVersion (PgVersion, pgVersion100,
-                                   pgVersion120, pgVersion130)
+import PostgREST.Config.PgVersion (PgVersion, pgVersion120,
+                                   pgVersion130)
 import Protolude                  hiding (get)
 import SpecHelper

@@ -26,7 +27,7 @@ spec actualPgVersion = do
      r <- request methodGet "/projects?id=in.(1,2,3)"
             (acceptHdrs "application/vnd.pgrst.plan+json") ""

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
+      let totalCost  = planCost r
          resHeaders = simpleHeaders r
          resStatus  = simpleStatus r

@@ -35,14 +36,14 @@ spec actualPgVersion = do
        resStatus `shouldBe` Status { statusCode = 200, statusMessage="OK" }
        totalCost `shouldBe`
          if actualPgVersion > pgVersion120
-            then Just [aesonQQ|15.63|]
-            else Just [aesonQQ|15.69|]
+            then 15.63
+            else 15.69

    it "outputs the total cost for a single filter on a view" $ do
      r <- request methodGet "/projects_view?id=gt.2"
             (acceptHdrs "application/vnd.pgrst.plan+json") ""

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
+      let totalCost  = planCost r
          resHeaders = simpleHeaders r
          resStatus  = simpleStatus r

@@ -51,8 +52,8 @@ spec actualPgVersion = do
        resStatus `shouldBe` Status { statusCode = 200, statusMessage="OK" }
        totalCost `shouldBe`
          if actualPgVersion > pgVersion120
-            then Just [aesonQQ|24.28|]
-            else Just [aesonQQ|32.28|]
+            then 24.28
+            else 32.28

    it "outputs blocks info when using the buffers option" $
      if actualPgVersion >= pgVersion130
@@ -158,7 +159,7 @@ spec actualPgVersion = do
      r <- request methodPost "/projects"
             (acceptHdrs "application/vnd.pgrst.plan+json") [json|{"id":100, "name": "Project 100"}|]

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
+      let totalCost  = planCost r
          resHeaders = simpleHeaders r
          resStatus  = simpleStatus r

@@ -167,14 +168,14 @@ spec actualPgVersion = do
        resStatus `shouldBe` Status { statusCode = 200, statusMessage="OK" }
        totalCost `shouldBe`
          if actualPgVersion > pgVersion120
-            then Just [aesonQQ|3.28|]
-            else Just [aesonQQ|3.33|]
+            then 3.28
+            else 3.33

    it "outputs the total cost for an update" $ do
      r <- request methodPatch "/projects?id=eq.3"
             (acceptHdrs "application/vnd.pgrst.plan+json") [json|{"name": "Patched Project"}|]

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
+      let totalCost  = planCost r
          resHeaders = simpleHeaders r
          resStatus  = simpleStatus r

@@ -183,28 +184,28 @@ spec actualPgVersion = do
        resStatus `shouldBe` Status { statusCode = 200, statusMessage="OK" }
        totalCost `shouldBe`
          if actualPgVersion > pgVersion120
-            then Just [aesonQQ|12.45|]
-            else Just [aesonQQ|12.5|]
+            then 12.45
+            else 12.5

    it "outputs the total cost for a delete" $ do
      r <- request methodDelete "/projects?id=in.(1,2,3)"
             (acceptHdrs "application/vnd.pgrst.plan+json") ""

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
+      let totalCost  = planCost r
          resHeaders = simpleHeaders r
          resStatus  = simpleStatus r

      liftIO $ do
        resHeaders `shouldSatisfy` elem ("Content-Type", "application/vnd.pgrst.plan+json; charset=utf-8")
        resStatus `shouldBe` Status { statusCode = 200, statusMessage="OK" }
-        totalCost `shouldBe` Just [aesonQQ|15.68|]
+        totalCost `shouldBe` 15.68

    it "outputs the total cost for a single upsert" $ do
      r <- request methodPut "/tiobe_pls?name=eq.Go"
            (acceptHdrs "application/vnd.pgrst.plan+json")
            [json| [ { "name": "Go", "rank": 19 } ]|]

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
+      let totalCost  = planCost r
          resHeaders = simpleHeaders r
          resStatus  = simpleStatus r

@@ -213,8 +214,8 @@ spec actualPgVersion = do
        resStatus `shouldBe` Status { statusCode = 200, statusMessage="OK" }
        totalCost `shouldBe`
          if actualPgVersion >= pgVersion120
-            then Just [aesonQQ|1.3|]
-            else Just [aesonQQ|1.35|]
+            then 1.3
+            else 1.35

    it "outputs the plan for application/vnd.pgrst.object" $ do
      r <- request methodDelete "/projects?id=eq.6"
@@ -232,14 +233,14 @@ spec actualPgVersion = do
      r <- request methodGet "/rpc/getallprojects?id=in.(1,2,3)"
             (acceptHdrs "application/vnd.pgrst.plan+json") ""

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
+      let totalCost  = planCost r
          resHeaders = simpleHeaders r
          resStatus  = simpleStatus r

      liftIO $ do
        resHeaders `shouldSatisfy` elem ("Content-Type", "application/vnd.pgrst.plan+json; charset=utf-8")
        resStatus `shouldBe` Status { statusCode = 200, statusMessage="OK" }
-        totalCost `shouldBe` Just [aesonQQ|68.57|]
+        totalCost `shouldBe` 68.57

    it "outputs the plan for text/xml" $ do
      r <- request methodGet "/rpc/return_scalar_xml"
@@ -282,33 +283,56 @@ spec actualPgVersion = do
  describe "resource embedding costs" $ do
    it "a one to many doesn't surpass a threshold" $ do
      r <- request methodGet "/clients?select=*,projects(*)&id=eq.1"
-             (acceptHdrs "application/vnd.pgrst.plan+json") ""
+             [planHdr] ""

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
-      liftIO $ totalCost `shouldBe`
-          if actualPgVersion > pgVersion120
-            then Just [aesonQQ|33.25|]
-            else Just [aesonQQ|33.27|]
+      liftIO $ planCost r `shouldSatisfy` (< 33.3)

    it "a many to one doesn't surpass a threshold" $ do
      r <- request methodGet "/projects?select=*,clients(*)&id=eq.1"
-             (acceptHdrs "application/vnd.pgrst.plan+json") ""
+             [planHdr] ""

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
-      liftIO $ totalCost `shouldBe`
-          if actualPgVersion > pgVersion120
-            then Just [aesonQQ|16.39|]
-            else Just [aesonQQ|16.41|]
+      liftIO $ planCost r `shouldSatisfy` (< 16.5)

    it "a many to many doesn't surpass a threshold" $ do
      r <- request methodGet "/users?select=*,tasks(*)&id=eq.1"
             (acceptHdrs "application/vnd.pgrst.plan+json") ""

-      let totalCost  = simpleBody r ^? nth 0 . key "Plan" . key "Total Cost"
-      liftIO $ totalCost `shouldBe`
-          if | actualPgVersion > pgVersion120 -> Just [aesonQQ|69.34|]
-             | actualPgVersion > pgVersion100 -> Just [aesonQQ|69.36|]
-             | otherwise                      -> Just [aesonQQ|70.81|]
+      liftIO $ planCost r `shouldSatisfy` (< 70.9)
+
+
+  describe "function call costs" $ do
+    it "should not exceed cost when calling setof composite proc" $ do
+      r <- request methodGet "/rpc/get_projects_below?id=3"
+             [planHdr] ""
+
+      liftIO $ planCost r `shouldSatisfy` (< 36.4)
+
+    it "should not exceed cost when calling setof composite proc with empty params" $ do
+      r <- request methodGet "/rpc/getallprojects"
+             [planHdr] ""
+
+      liftIO $ planCost r `shouldSatisfy` (< 71.0)
+
+    it "should not exceed cost when calling scalar proc" $ do
+      r <- request methodGet "/rpc/add_them?a=3&b=4"
+             [planHdr] ""
+
+      liftIO $ planCost r `shouldSatisfy` (< 1.18)
+
+    context "params=multiple-objects" $ do
+      it "should not exceed cost when calling setof composite proc" $ do
+        r <- request methodPost "/rpc/get_projects_below"
+               [planHdr, ("Prefer", "params=multiple-objects")]
+               [str| [{"id": 1}, {"id": 4}] |]
+
+        liftIO $ planCost r `shouldSatisfy` (< 4503.4)
+
+      it "should not exceed cost when calling scalar proc" $ do
+        r <- request methodPost "/rpc/add_them"
+               [planHdr, ("Prefer", "params=multiple-objects")]
+               [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |]
+
+        liftIO $ planCost r `shouldSatisfy` (< 5.85)

 disabledSpec :: SpecWith ((), Application)
 disabledSpec =
@@ -64,7 +64,7 @@ import qualified Feature.RpcPreRequestGucsSpec

 main :: IO ()
 main = do
-  pool <- P.acquire 3 Nothing $ toUtf8 $ configDbUri testCfg
+  pool <- P.acquire 3 10 60 $ toUtf8 $ configDbUri testCfg

  actualPgVersion <- either (panic . show) id <$> P.use pool queryPgVersion

@@ -1,86 +0,0 @@
-- TODO Can be replaced now by obtaining the EXPLAIN plan and adding the cost tests on PlanSpec.hs
-module Main where
-
-import           Control.Lens                      ((^?))
-import qualified Data.Aeson.Lens                   as L
-import qualified Hasql.Decoders                    as HD
-import qualified Hasql.DynamicStatements.Snippet   as H
-import qualified Hasql.DynamicStatements.Statement as H
-import qualified Hasql.Pool                        as P
-import qualified Hasql.Statement                   as H
-import qualified Hasql.Transaction                 as HT
-import qualified Hasql.Transaction.Sessions        as HT
-import           Text.Heredoc
-
-import Protolude hiding (get, toS)
-
-import PostgREST.Plan.CallPlan
-import PostgREST.Query.QueryBuilder (callPlanToQuery)
-
-import PostgREST.SchemaCache.Identifiers
-import PostgREST.SchemaCache.Proc
-
-import Test.Hspec
-
-main :: IO ()
-main = do
-  pool <- P.acquire 3 Nothing "postgresql://"
-
-  hspec $ describe "QueryCost" $
-    context "call proc query" $ do
-      it "should not exceed cost when calling setof composite proc" $ do
-        cost <- exec pool $
-          callPlanToQuery (FunctionCall (QualifiedIdentifier "test" "get_projects_below")
-          (KeyParams [ProcParam "id" "int" True False])
-          (Just [str| {"id": 3} |]) False False [])
-        liftIO $
-          cost `shouldSatisfy` (< Just 40)
-
-      it "should not exceed cost when calling setof composite proc with empty params" $ do
-        cost <- exec pool $
-          callPlanToQuery (FunctionCall (QualifiedIdentifier "test" "getallprojects") (KeyParams []) Nothing False False [])
-        liftIO $
-          cost `shouldSatisfy` (< Just 30)
-
-      it "should not exceed cost when calling scalar proc" $ do
-        cost <- exec pool $
-          callPlanToQuery (FunctionCall (QualifiedIdentifier "test" "add_them")
-          (KeyParams [ProcParam "a" "int" True False, ProcParam "b" "int" True False])
-          (Just [str| {"a": 3, "b": 4} |]) True False [])
-        liftIO $
-          cost `shouldSatisfy` (< Just 10)
-
-      context "params=multiple-objects" $ do
-        it "should not exceed cost when calling setof composite proc" $ do
-          cost <- exec pool $
-            callPlanToQuery (FunctionCall (QualifiedIdentifier "test" "get_projects_below")
-            (KeyParams [ProcParam "id" "int" True False])
-            (Just [str| [{"id": 1}, {"id": 4}] |]) False True [])
-          liftIO $ do
-            -- lower bound needed for now to make sure that cost is not Nothing
-            cost `shouldSatisfy` (> Just 2000)
-            cost `shouldSatisfy` (< Just 2100)
-
-        it "should not exceed cost when calling scalar proc" $ do
-          cost <- exec pool $
-            callPlanToQuery (FunctionCall (QualifiedIdentifier "test" "add_them")
-            (KeyParams [ProcParam "a" "int" True False, ProcParam "b" "int" True False])
-            (Just [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |]) True False [])
-          liftIO $
-            cost `shouldSatisfy` (< Just 10)
-
-
-exec :: P.Pool -> H.Snippet -> IO (Maybe Int64)
-exec pool query =
-  join . rightToMaybe <$>
-  P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement mempty $ explainCost query)
-
-explainCost :: H.Snippet -> H.Statement () (Maybe Int64)
-explainCost query =
-  H.dynamicallyParameterized snippet decodeExplain False
- where
-   snippet = "EXPLAIN (FORMAT JSON) " <> query
-   decodeExplain :: HD.Result (Maybe Int64)
-   decodeExplain =
-     let row = HD.singleRow $ HD.column $ HD.nonNullable HD.bytea in
-     (^? L.nth 0 . L.key "Plan" .  L.key "Total Cost" . L._Integral) <$> row
@@ -1,9 +1,12 @@
 module SpecHelper where

+import           Control.Lens           ((^?))
+import           Data.Aeson.Lens
 import qualified Data.ByteString.Base64 as B64 (decodeLenient)
 import qualified Data.ByteString.Char8  as BS
 import qualified Data.ByteString.Lazy   as BL
 import qualified Data.Map.Strict        as M
+import           Data.Scientific        (toRealFloat)
 import qualified Data.Set               as S

 import Data.Aeson           (Value (..), decode, encode)
@@ -79,7 +82,8 @@ baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in
  , configDbMaxRows             = Nothing
  , configDbPlanEnabled         = False
  , configDbPoolSize            = 10
-  , configDbPoolAcquisitionTimeout = Nothing
+  , configDbPoolAcquisitionTimeout = 10
+  , configDbPoolMaxLifetime     = 1800
  , configDbPreRequest          = Just $ QualifiedIdentifier "test" "switch_role"
  , configDbPreparedStatements  = True
  , configDbRootSpec            = Nothing
@@ -213,6 +217,9 @@ rangeHdrsWithCount r = ("Prefer", "count=exact") : rangeHdrs r
 acceptHdrs :: BS.ByteString -> [Header]
 acceptHdrs mime = [(hAccept, mime)]

+planHdr :: Header
+planHdr = (hAccept, "application/vnd.pgrst.plan+json")
+
 rangeUnit :: Header
 rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items")

@@ -276,3 +283,13 @@ requestMutation method path body =

 data BaseTable = BaseTable ByteString ByteString Value
 data MutationCheck = MutationCheck BaseTable (WaiExpectation ())
+
+planCost :: SResponse -> Float
+planCost resp =
+  let res = simpleBody resp ^? nth 0 . key "Plan" . key "Total Cost" in
+  -- big value in case parsing fails
+  fromMaybe 1000000000.0 $ unbox =<< res
+  where
+    unbox :: Value -> Maybe Float
+    unbox (Number n) = Just $ toRealFloat n
+    unbox _          = Nothing
Author	SHA1	Message	Date
Laurence Islaandsteve-chavez	e07807deab	bump version to 10.2.0	2023-04-12 12:49:39 -05:00
steve-chavez	bd50b1e4d3	ci: pin Nix version to avoid error To 2.13.3	2023-04-12 12:49:39 -05:00
Robert Vollmertandsteve-chavez	f26cdd5151	feat: use hasql-pool-0.9, add db-pool-max-lifetime (fixes #2638 ) - db-pool-acquisition-timeout is no longer optional, defaults to 10s - new option db-pool-max-lifetime limits the maximal lifetime of a postgresql connection, defaults to 30m	2023-04-12 12:49:36 -05:00
Steve Chavez	b869dd7be9	fix: log to stderr on AcquisitionTimeoutUsageError (#2667 ) * refactor: remove uneeded type on checkIsFatal * dry with a logPgrstError function	2023-04-12 12:49:04 -05:00
RobertandLaurence Isla	97a4402911	Update nixpkgs, dependencies (#2612 ) * relax upper bounds on HTTP, hspec, lens-aeson, optparse-applicative (fixes #2580) * upgrade stackage snapshot to latest LTS, with GHC 9.2.5 * bump nixpkgs to 2023-01-12 * fix complaints due to updated linters	2023-04-12 09:52:08 -05:00
RobertandLaurence Isla	a101d27c9c	bump postgresql-libpq (#2599 ) For https://github.com/PostgREST/postgresql-libpq/pull/2.	2023-04-12 09:52:08 -05:00
steve-chavezandLaurence Isla	519dbc75f3	refactor: delete QueryCost, instead use PlanSpec	2023-04-12 09:52:08 -05:00
steve-chavezandLaurence Isla	ae3c784921	refactor: add planCost and planHdr for tests	2023-04-12 09:52:08 -05:00