fix: do not retry transactions on any error

default.nix

@@ -1,6 +1,6 @@
 { system ? builtins.currentSystem
 
-, compiler ? "ghc948"
+, compiler ? "ghc967"
 
 , # Commit of the Nixpkgs repository that we want to use.
   # It defaults to reading the inputs from flake.lock, which serves
@@ -104,9 +104,7 @@ rec {
 
   # Tooling for analyzing Haskell imports and exports.
   hsie =
-    pkgs.callPackage nix/hsie {
-      inherit (pkgs.haskell.packages."${compiler}") ghcWithPackages;
-    };
+    pkgs.callPackage nix/hsie { };
 
   ### Tools
 

nix/hsie/default.nix

@@ -1,4 +1,4 @@
-{ ghcWithPackages
+{ haskell
 , runCommand
 }:
 let
@@ -14,7 +14,7 @@ let
     ps.ghc-paths
     ps.optparse-applicative
   ];
-  ghc = ghcWithPackages modules;
+  ghc = haskell.packages.ghc94.ghcWithPackages modules;
   hsie =
     runCommand "haskellimports" { inherit name src; }
       ''

nix/overlays/haskell-packages.nix

@@ -50,14 +50,25 @@ let
       # jailbreak, because hspec limit for tests
       fuzzyset = prev.fuzzyset_0_2_4;
 
-      # Downgrade hasql and related packages while we are still on GHC 9.4 for the static build.
-      hasql = lib.dontCheck (lib.doJailbreak prev.hasql_1_6_4_4);
-      hasql-dynamic-statements = lib.dontCheck prev.hasql-dynamic-statements_0_3_1_5;
-      hasql-implicits = lib.dontCheck prev.hasql-implicits_0_1_1_3;
-      hasql-notifications = lib.dontCheck prev.hasql-notifications_0_2_2_2;
-      hasql-pool = lib.dontCheck prev.hasql-pool_1_0_1;
-      hasql-transaction = lib.dontCheck prev.hasql-transaction_1_1_0_1;
-      postgresql-binary = lib.dontCheck (lib.doJailbreak prev.postgresql-binary_0_13_1_3);
+      hasql = lib.dontCheck prev.hasql_1_9_1_2;
+      hasql-pool = lib.dontCheck prev.hasql-pool_1_3_0_1;
+      hasql-notifications = lib.dontCheck (prev.callHackageDirect
+        {
+          pkg = "hasql-notifications";
+          ver = "0.2.4.0";
+          sha256 = "sha256-5NsF0WyiZuqkZemlQfA/J7rAJttkE56oPJK4zgqMbZ4=";
+        }
+        { });
+      hasql-transaction = lib.dontCheck (prev.callHackageDirect
+        {
+          pkg = "hasql-transaction";
+          ver = "1.2.1";
+          sha256 = "sha256-7Q7gt5ts4OoGU58dp6PJFZmVjfwjozANHNg2u1PJf6Q=";
+        }
+        { });
+
+      # Needed for hasql 1.9
+      text-builder = lib.dontCheck prev.text-builder_1_0_0_3;
     };
 in
 {

nix/tools/withTools.nix

@@ -85,7 +85,7 @@ let
           >&2 echo "${commandName}: You can tail the logs with: tail -f $tmpdir/db.log"
 
           if test "$_arg_replica" = "on"; then
-            replica_slot="replica_$RANDOM"
+            replica_slot="rr_$RANDOM"
             replica_dir="$tmpdir/$replica_slot"
             replica_host="$tmpdir/socket_$replica_slot"
 
@@ -100,7 +100,7 @@ let
 
             log "Starting replica on $replica_host"
 
-            pg_ctl -D "$replica_dir" -l "$replica_dblog" -w start -o "-F -c listen_addresses=\"\" -c hba_file=$HBA_FILE -k $replica_host -c log_statement=\"all\" " \
+            pg_ctl -D "$replica_dir" -l "$replica_dblog" -w start -o "-F -c listen_addresses=\"\" -c hba_file=$HBA_FILE -k $replica_host -c log_statement=\"all\" -c max_standby_streaming_delay=\"3s\"" \
               >> "$setuplog"
 
             >&2 echo "${commandName}: Replica enabled. You can connect to it with: psql 'postgres:///$PGDATABASE?host=$replica_host' -U postgres"

postgrest.cabal

@@ -16,11 +16,10 @@ extra-source-files: CHANGELOG.md
 cabal-version:      >= 1.10
 
 tested-with:
-    -- nix
-    GHC == 9.4.8
     -- cabal on Ubuntu
+    -- nix
     -- stack on FreeBSD, MacOS, Ubuntu, Windows
-  , GHC == 9.6.7
+    GHC == 9.6.7
     -- cabal on Ubuntu
   , GHC == 9.8.4
 
@@ -111,11 +110,11 @@ library
                     , either                    >= 4.4.1 && < 5.1
                     , extra                     >= 1.7.0 && < 2.0
                     , fuzzyset                  >= 0.2.4 && < 0.3
-                    , hasql                     >= 1.6.1.1 && < 1.7
+                    , hasql                     >= 1.9.1.2 && < 1.10
                     , hasql-dynamic-statements  >= 0.3.1 && < 0.4
-                    , hasql-notifications       >= 0.2.2.2 && < 0.2.3
-                    , hasql-pool                >= 1.0.1 && < 1.1
-                    , hasql-transaction         >= 1.0.1 && < 1.2
+                    , hasql-notifications       >= 0.2.4.0 && < 0.3
+                    , hasql-pool                >= 1.3.0.1 && < 1.4
+                    , hasql-transaction         >= 1.2.1 && < 1.3
                     , heredoc                   >= 0.2 && < 0.3
                     , http-types                >= 0.12.2 && < 0.13
                     , insert-ordered-containers >= 0.2.2 && < 0.3
@@ -129,8 +128,6 @@ library
                     , network-uri               >= 2.6.1 && < 2.8
                     , optparse-applicative      >= 0.13 && < 0.19
                     , parsec                    >= 3.1.11 && < 3.2
-                    -- Technically unused, can be removed after updating to hasql >= 1.7
-                    , postgresql-libpq          >= 0.10
                     , prometheus-client         >= 1.1.1 && < 1.2.0
                     , protolude                 >= 0.3.1 && < 0.4
                     , regex-tdfa                >= 1.2.2 && < 1.4
@@ -266,8 +263,9 @@ test-suite spec
                     , bytestring        >= 0.10.8 && < 0.13
                     , case-insensitive  >= 1.2 && < 1.3
                     , containers        >= 0.5.7 && < 0.7
-                    , hasql-pool        >= 1.0.1 && < 1.1
-                    , hasql-transaction >= 1.0.1 && < 1.2
+                    , hasql             >= 1.9.1.2 && < 1.10
+                    , hasql-pool        >= 1.3.0.1 && < 1.4
+                    , hasql-transaction >= 1.2.1 && < 1.3
                     , heredoc           >= 0.2 && < 0.3
                     , hspec             >= 2.3 && < 2.12
                     , hspec-expectations >= 0.8.4 && < 0.9

src/PostgREST/AppState.hs

@@ -30,22 +30,24 @@ module PostgREST.AppState
   , isPending
   ) where
 
-import qualified Data.ByteString.Char8      as BS
-import           Data.Either.Combinators    (whenLeft)
-import qualified Data.Text                  as T (unpack)
-import qualified Hasql.Pool                 as SQL
-import qualified Hasql.Pool.Config          as SQL
-import qualified Hasql.Session              as SQL
-import qualified Hasql.Transaction.Sessions as SQL
-import qualified Network.HTTP.Types.Status  as HTTP
-import qualified Network.Socket             as NS
-import qualified PostgREST.Auth.JwtCache    as JwtCache
-import qualified PostgREST.Error            as Error
-import qualified PostgREST.Logger           as Logger
-import qualified PostgREST.Metrics          as Metrics
+import qualified Data.ByteString.Char8               as BS
+import           Data.Either.Combinators             (whenLeft)
+import qualified Data.Text                           as T (unpack)
+import qualified Hasql.Connection.Setting            as SQL
+import qualified Hasql.Connection.Setting.Connection as SQL
+import qualified Hasql.Pool                          as SQL
+import qualified Hasql.Pool.Config                   as SQL
+import qualified Hasql.Session                       as SQL
+import qualified Hasql.Transaction.Sessions          as SQL
+import qualified Network.HTTP.Types.Status           as HTTP
+import qualified Network.Socket                      as NS
+import qualified PostgREST.Auth.JwtCache             as JwtCache
+import qualified PostgREST.Error                     as Error
+import qualified PostgREST.Logger                    as Logger
+import qualified PostgREST.Metrics                   as Metrics
 import           PostgREST.Observation
-import           PostgREST.Version          (prettyVersion)
-import           System.TimeIt              (timeItT)
+import           PostgREST.Version                   (prettyVersion)
+import           System.TimeIt                       (timeItT)
 
 import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
                            updateAction)
@@ -207,28 +209,40 @@ initPool AppConfig{..} observer = do
     , SQL.acquisitionTimeout $ fromIntegral configDbPoolAcquisitionTimeout
     , SQL.agingTimeout $ fromIntegral configDbPoolMaxLifetime
     , SQL.idlenessTimeout $ fromIntegral configDbPoolMaxIdletime
-    , SQL.staticConnectionSettings (toUtf8 $ addFallbackAppName prettyVersion configDbUri)
+    , SQL.staticConnectionSettings [
+        SQL.connection $ SQL.string (addFallbackAppName prettyVersion configDbUri),
+        SQL.usePreparedStatements configDbPreparedStatements
+      ]
     , SQL.observationHandler $ observer . HasqlPoolObs
     ]
 
 -- | Run an action with a database connection.
 usePool :: AppState -> SQL.Session a -> IO (Either SQL.UsageError a)
 usePool AppState{stateObserver=observer, stateMainThreadId=mainThreadId, ..} sess = do
-  observer PoolRequest
+    observer PoolRequest
 
-  res <- SQL.use statePool sess
+    res <- SQL.use statePool sess
 
-  observer PoolRequestFullfilled
+    observer PoolRequestFullfilled
 
-  whenLeft res (\case
-    SQL.AcquisitionTimeoutUsageError ->
-      observer $ PoolAcqTimeoutObs SQL.AcquisitionTimeoutUsageError
-    err@(SQL.ConnectionUsageError e) ->
-      let failureMessage = BS.unpack $ fromMaybe mempty e in
-      when (("FATAL:  password authentication failed" `isInfixOf` failureMessage) || ("no password supplied" `isInfixOf` failureMessage)) $ do
-        observer $ ExitDBFatalError ServerAuthError err
-        killThread mainThreadId
-    err@(SQL.SessionUsageError (SQL.QueryError tpl _ (SQL.ResultError resultErr))) -> do
+    whenLeft res (\case
+      SQL.AcquisitionTimeoutUsageError ->
+        observer $ PoolAcqTimeoutObs SQL.AcquisitionTimeoutUsageError
+      err@(SQL.ConnectionUsageError e) ->
+        let failureMessage = BS.unpack $ fromMaybe mempty e in
+        when (("FATAL:  password authentication failed" `isInfixOf` failureMessage) || ("no password supplied" `isInfixOf` failureMessage)) $ do
+          observer $ ExitDBFatalError ServerAuthError err
+          killThread mainThreadId
+      err@(SQL.SessionUsageError (SQL.QueryError tpl _ (SQL.ResultError resultErr))) -> handleResultError err tpl resultErr
+      -- Passing the empty template will not work for schema cache queries, see TODO further below.
+      err@(SQL.SessionUsageError (SQL.PipelineError (SQL.ResultError resultErr)))    -> handleResultError err mempty resultErr
+      err@(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _)))           -> observer $ QueryErrorCodeHighObs err
+      SQL.SessionUsageError (SQL.PipelineError (SQL.ClientError _))  -> pure ()
+      )
+
+    return res
+  where
+    handleResultError err tpl resultErr = do
       case resultErr of
         SQL.UnexpectedResult{} -> do
           observer $ ExitDBFatalError ServerPgrstBug err
@@ -261,12 +275,6 @@ usePool AppState{stateObserver=observer, stateMainThreadId=mainThreadId, ..} ses
         SQL.ServerError{} ->
           when (Error.status (Error.PgError False err) >= HTTP.status500) $
             observer $ QueryErrorCodeHighObs err
-    err@(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _))) ->
-      -- An error on the client-side, usually indicates problems wth connection
-        observer $ QueryErrorCodeHighObs err
-    )
-
-  return res
 
 -- | Flush the connection pool so that any future use of the pool will
 -- use connections freshly established after this call.
@@ -400,8 +408,7 @@ retryingSchemaCacheLoad appState@AppState{stateObserver=observer, stateMainThrea
     qSchemaCache = do
       conf@AppConfig{..} <- getConfig appState
       (resultTime, result) <-
-        let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
-        timeItT $ usePool appState (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
+        timeItT $ usePool appState (SQL.transactionNoRetry SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
       case result of
         Left e -> do
           putSCacheStatus appState SCPending

src/PostgREST/CLI.hs

@@ -53,10 +53,7 @@ main CLI{cliCommand, cliPath} = do
 dumpSchema :: AppState -> IO LBS.ByteString
 dumpSchema appState = do
   conf@AppConfig{..} <- AppState.getConfig appState
-  result <-
-    let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
-    AppState.usePool appState
-      (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
+  result <- AppState.usePool appState (SQL.transactionNoRetry SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
   case result of
     Left e -> do
       let observer = AppState.getObserver appState

src/PostgREST/Config/Database.hs

@@ -92,8 +92,7 @@ pgVersionStatement = SQL.Statement sql HE.noParams versionRow
 -- A setting on the database only will have no effect: ALTER DATABASE postgres SET <prefix>jwt_aud = 'xx'
 queryDbSettings :: Maybe Text -> Bool -> Session [(Text, Text)]
 queryDbSettings preConfFunc prepared =
-  let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
-  transaction SQL.ReadCommitted SQL.Read $ SQL.statement dbSettingsNames $ SQL.Statement sql (arrayParam HE.text) decodeSettings prepared
+  SQL.transactionNoRetry SQL.ReadCommitted SQL.Read $ SQL.statement dbSettingsNames $ SQL.Statement sql (arrayParam HE.text) decodeSettings prepared
   where
     sql = encodeUtf8 [trimming|
       WITH
@@ -133,8 +132,7 @@ queryDbSettings preConfFunc prepared =
 
 queryRoleSettings :: PgVersion -> Bool -> Session (RoleSettings, RoleIsolationLvl)
 queryRoleSettings pgVer prepared =
-  let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
-  transaction SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.Statement sql HE.noParams (processRows <$> rows) prepared
+  SQL.transactionNoRetry SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.Statement sql HE.noParams (processRows <$> rows) prepared
   where
     sql = encodeUtf8 [trimming|
       with

src/PostgREST/Error.hs

@@ -526,18 +526,22 @@ instance JSON.ToJSON SQL.UsageError where
 
 instance ErrorBody SQL.UsageError where
   code    (SQL.ConnectionUsageError _)                   = "PGRST000"
+  code    (SQL.SessionUsageError (SQL.PipelineError e))  = code e
   code    (SQL.SessionUsageError (SQL.QueryError _ _ e)) = code e
   code    SQL.AcquisitionTimeoutUsageError               = "PGRST003"
 
   message (SQL.ConnectionUsageError _) = "Database connection error. Retrying the connection."
+  message (SQL.SessionUsageError (SQL.PipelineError e))  = message e
   message (SQL.SessionUsageError (SQL.QueryError _ _ e)) = message e
   message SQL.AcquisitionTimeoutUsageError = "Timed out acquiring connection from connection pool."
 
   details (SQL.ConnectionUsageError e) = JSON.String . T.decodeUtf8 <$> e
+  details (SQL.SessionUsageError (SQL.PipelineError e))  = details e
   details (SQL.SessionUsageError (SQL.QueryError _ _ e)) = details e
   details SQL.AcquisitionTimeoutUsageError               = Nothing
 
   hint    (SQL.ConnectionUsageError _)                   = Nothing
+  hint    (SQL.SessionUsageError (SQL.PipelineError e))  = hint e
   hint    (SQL.SessionUsageError (SQL.QueryError _ _ e)) = hint e
   hint    SQL.AcquisitionTimeoutUsageError               = Nothing
 
@@ -586,8 +590,13 @@ instance ErrorBody SQL.CommandError where
 pgErrorStatus :: Bool -> SQL.UsageError -> HTTP.Status
 pgErrorStatus _      (SQL.ConnectionUsageError _) = HTTP.status503
 pgErrorStatus _      SQL.AcquisitionTimeoutUsageError = HTTP.status504
+pgErrorStatus _      (SQL.SessionUsageError (SQL.PipelineError (SQL.ClientError _)))       = HTTP.status503
 pgErrorStatus _      (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _)))      = HTTP.status503
-pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError rError))) =
+pgErrorStatus authed (SQL.SessionUsageError (SQL.PipelineError (SQL.ResultError rError)))  = mapSQLtoHTTP authed rError
+pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError rError))) = mapSQLtoHTTP authed rError
+
+mapSQLtoHTTP :: Bool -> SQL.ResultError -> HTTP.Status
+mapSQLtoHTTP authed rError =
   case rError of
     (SQL.ServerError c m d _ _) ->
       case BS.unpack c of

src/PostgREST/Listener.hs

@@ -5,12 +5,15 @@ module PostgREST.Listener (runListener) where
 
 import qualified Data.ByteString.Char8 as BS
 
-import qualified Hasql.Connection      as SQL
-import qualified Hasql.Notifications   as SQL
-import           PostgREST.AppState    (AppState, getConfig)
-import           PostgREST.Config      (AppConfig (..))
-import           PostgREST.Observation (Observation (..))
-import           PostgREST.Version     (prettyVersion)
+import qualified Hasql.Connection                    as SQL
+import qualified Hasql.Connection.Setting            as SQL
+import qualified Hasql.Connection.Setting.Connection as SQL
+import qualified Hasql.Notifications                 as SQL
+import           PostgREST.AppState                  (AppState,
+                                                      getConfig)
+import           PostgREST.Config                    (AppConfig (..))
+import           PostgREST.Observation               (Observation (..))
+import           PostgREST.Version                   (prettyVersion)
 
 import qualified PostgREST.AppState as AppState
 import qualified PostgREST.Config   as Config
@@ -29,6 +32,7 @@ retryingListen :: AppState -> IO ()
 retryingListen appState = do
   AppConfig{..} <- AppState.getConfig appState
   let
+    connectionString = Config.addTargetSessionAttrs $ Config.addFallbackAppName prettyVersion configDbUri
     dbChannel = toS configDbChannel
     handleFinally err = do
       AppState.putIsListenerOn appState False
@@ -46,7 +50,7 @@ retryingListen appState = do
 
   -- forkFinally allows to detect if the thread dies
   void . flip forkFinally handleFinally $ do
-    dbOrError <- SQL.acquire $ toUtf8 (Config.addTargetSessionAttrs $ Config.addFallbackAppName prettyVersion configDbUri)
+    dbOrError <- SQL.acquire [ SQL.connection $ SQL.string connectionString ]
     case dbOrError of
       Right db -> do
         SQL.listen db $ SQL.toPgIdentifier dbChannel

src/PostgREST/Metrics.hs

@@ -53,7 +53,7 @@ observationMetrics MetricsState{..} obs = case obs of
   (PoolAcqTimeoutObs _) -> do
     incCounter poolTimeouts
   (HasqlPoolObs (SQL.ConnectionObservation _ status)) -> case status of
-     SQL.ReadyForUseConnectionStatus  -> do
+     SQL.ReadyForUseConnectionStatus _ -> do
       incGauge poolAvailable
      SQL.InUseConnectionStatus        -> do
       decGauge poolAvailable

src/PostgREST/Observation.hs

@@ -141,13 +141,17 @@ observationMessage = \case
     "Connection " <> show uuid <> (
       case status of
         SQL.ConnectingConnectionStatus   -> " is being established"
-        SQL.ReadyForUseConnectionStatus  -> " is available"
+        SQL.ReadyForUseConnectionStatus reason -> " is available due to " <> case reason of
+          SQL.EstablishedConnectionReadyForUseReason      -> "connection establishment"
+          SQL.SessionFailedConnectionReadyForUseReason _  -> "session failure"
+          SQL.SessionSucceededConnectionReadyForUseReason -> "session success"
         SQL.InUseConnectionStatus        -> " is used"
         SQL.TerminatedConnectionStatus reason -> " is terminated due to " <> case reason of
           SQL.AgingConnectionTerminationReason          -> "max lifetime"
           SQL.IdlenessConnectionTerminationReason       -> "max idletime"
           SQL.ReleaseConnectionTerminationReason        -> "release"
           SQL.NetworkErrorConnectionTerminationReason _ -> "network error" -- usage error is already logged, no need to repeat the same message.
+          SQL.InitializationErrorTerminationReason _    -> "init failure"
     )
   PoolRequest ->
     "Trying to borrow a connection from pool"