Upgrade hasql-pool

CHANGELOG.md

@@ -70,6 +70,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
  - #2410, Fix loop crash error on startup in Postgres 15 beta 3. Log: "UNION types \"char\" and text cannot be matched". - @yevon
  - #2397, Fix race conditions managing database connection helper - @robx
  - #2269, Allow `limit=0` in the request query to return an empty array - @gautam1168, @laurenceisla
+ - #2401, Ensure database connections can't outlive SIGUSR1 - @robx
 
 ### Changed
 

nix/overlays/haskell-packages.nix

@@ -31,6 +31,15 @@ let
       #
       # To get the sha256:
       #   nix-prefetch-url --unpack https://github.com/<owner>/<repo>/archive/<commit>.tar.gz
+
+      hasql-pool = lib.dontCheck (
+        prev.callHackageDirect
+          {
+            pkg = "hasql-pool";
+            ver = "0.7.2";
+            sha256 = "sha256-JHTYBmghCb4fhoAoU6TBu8otSOiHrsdyHi/TDAittZY=";
+          }
+          { });
     } // extraOverrides final prev;
 in
 {

postgrest.cabal

@@ -88,7 +88,7 @@ library
                     , hasql                     >= 1.4 && < 1.6
                     , hasql-dynamic-statements  >= 0.3.1 && < 0.4
                     , hasql-notifications       >= 0.1 && < 0.3
-                    , hasql-pool                >= 0.5 && < 0.6
+                    , hasql-pool                >= 0.7.2 && < 0.8
                     , hasql-transaction         >= 1.0.1 && < 1.1
                     , heredoc                   >= 0.2 && < 0.3
                     , http-types                >= 0.12.2 && < 0.13
@@ -226,7 +226,7 @@ test-suite spec
                     , bytestring        >= 0.10.8 && < 0.12
                     , case-insensitive  >= 1.2 && < 1.3
                     , containers        >= 0.5.7 && < 0.7
-                    , hasql-pool        >= 0.5 && < 0.6
+                    , hasql-pool        >= 0.7.2 && < 0.8
                     , hasql-transaction >= 1.0.1 && < 1.1
                     , heredoc           >= 0.2 && < 0.3
                     , hspec             >= 2.3 && < 2.9
@@ -269,7 +269,7 @@ test-suite querycost
                     , contravariant     >= 1.4 && < 1.6
                     , hasql             >= 1.4 && < 1.6
                     , hasql-dynamic-statements >= 0.3.1 && < 0.4
-                    , hasql-pool        >= 0.5 && < 0.6
+                    , hasql-pool        >= 0.7.2 && < 0.8
                     , hasql-transaction >= 1.0.1 && < 1.1
                     , heredoc           >= 0.2 && < 0.3
                     , hspec             >= 2.3 && < 2.9

src/PostgREST/AppState.hs

@@ -3,6 +3,7 @@
 module PostgREST.AppState
   ( AppState
   , destroy
+  , flushPool
   , getConfig
   , getDbStructure
   , getIsListenerOn
@@ -21,7 +22,6 @@ module PostgREST.AppState
   , putJsonDbS
   , putPgVersion
   , putRetryNextIn
-  , releasePool
   , signalListener
   , usePool
   , waitListener
@@ -32,8 +32,8 @@ import qualified Hasql.Session as SQL
 
 import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
                            updateAction)
-import Data.IORef         (IORef, atomicWriteIORef, newIORef,
-                           readIORef)
+import Data.IORef         (IORef, atomicModifyIORef, atomicWriteIORef,
+                           newIORef, readIORef)
 import Data.Time          (ZonedTime, defaultTimeLocale, formatTime,
                            getZonedTime)
 import Data.Time.Clock    (UTCTime, getCurrentTime)
@@ -46,7 +46,9 @@ import Protolude
 
 
 data AppState = AppState
-  { statePool         :: SQL.Pool -- | Connection pool, either a 'Connection' or a 'ConnectionError'
+  -- | Database connection pool; 'Nothing' indicates the pool has been destroyed
+  { statePool         :: IORef (Maybe SQL.Pool)
+  -- | Database server version, will be updated by the connectionWorker
   , statePgVersion    :: IORef PgVersion
   -- | No schema cache at the start. Will be filled in by the connectionWorker
   , stateDbStructure  :: IORef (Maybe DbStructure)
@@ -72,13 +74,14 @@ data AppState = AppState
 
 init :: AppConfig -> IO AppState
 init conf = do
-  newPool <- initPool conf
-  initWithPool newPool conf
+  pool <- initPool conf
+  initWithPool pool conf
 
 initWithPool :: SQL.Pool -> AppConfig -> IO AppState
-initWithPool newPool conf =
-  AppState newPool
-    <$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
+initWithPool pool conf =
+  AppState
+    <$> newIORef (Just pool)
+    <*> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
     <*> newIORef Nothing
     <*> newIORef mempty
     <*> newEmptyMVar
@@ -91,17 +94,58 @@ initWithPool newPool conf =
     <*> newIORef 0
 
 destroy :: AppState -> IO ()
-destroy = releasePool
+destroy = destroyPool
 
 initPool :: AppConfig -> IO SQL.Pool
 initPool AppConfig{..} =
-  SQL.acquire (configDbPoolSize, configDbPoolTimeout, toUtf8 configDbUri)
-
+  SQL.acquire configDbPoolSize $ toUtf8 configDbUri
+
+-- | Run an action with a database connection.
+--
+-- This is a thin wrapper around 'SQL.use', which deals with a
+-- race on flushing the pool: The pool read via 'readIORef'
+-- might be released via 'flushPool' by the time we call 'SQL.use',
+-- so we catch that 'SQL.PoolIsReleasedUsageError' and retry.
+--
+-- If on the other hand the pool has been (permanently) destroyed,
+-- we re-use 'SQL.PoolIsReleasedUsageError' to convey this to the
+-- caller.
 usePool :: AppState -> SQL.Session a -> IO (Either SQL.UsageError a)
-usePool AppState{..} = SQL.use statePool
-
-releasePool :: AppState -> IO ()
-releasePool AppState{..} = SQL.release statePool
+usePool appState@AppState{..} session = do
+  pool <- readIORef statePool
+  case pool of
+    Nothing -> return $ Left SQL.PoolIsReleasedUsageError
+    Just p -> do
+      res <- SQL.use p session
+      case res of
+        Left SQL.PoolIsReleasedUsageError -> do
+          logWithZTime appState "Attempted to used flushed pool, retrying"
+          usePool appState session
+        _                                 -> return res
+
+-- | Flush the connection pool so that any future use of the pool will
+-- use connections freshly established after this call. In-use
+-- connections aren't affected, they just won't be reused anymore.
+--
+-- Does nothing if the pool has been destroyed.
+flushPool :: AppState -> IO ()
+flushPool appState@AppState{..} = do
+  conf <- getConfig appState
+
+  -- create a new pool; this is discarded if the pool has been destroyed,
+  -- but it's not a huge waste
+  newPool <- initPool conf
+  oldPool <- atomicModifyIORef statePool $ \old ->
+    case old of
+      Nothing -> (Nothing, old)
+      _       -> (Just newPool, old)
+  mapM_ SQL.release oldPool
+
+-- | Destroy the pool on shutdown.
+-- This doesn't interrupt in-use connections.
+destroyPool :: AppState -> IO ()
+destroyPool AppState{..} =
+  readIORef statePool >>= mapM_ SQL.release
 
 getPgVersion :: AppState -> IO PgVersion
 getPgVersion = readIORef . statePgVersion

src/PostgREST/CLI.hs

@@ -148,9 +148,6 @@ exampleConfigFile =
       |## Number of open connections in the pool
       |db-pool = 10
       |
-      |## Time to live, in seconds, for an idle database pool connection
-      |db-pool-timeout = 3600
-      |
       |## Stored proc to exec immediately after auth
       |# db-pre-request = "stored_proc_name"
       |

src/PostgREST/Config.hs

@@ -46,7 +46,6 @@ import Data.List               (lookup)
 import Data.List.NonEmpty      (fromList, toList)
 import Data.Maybe              (fromJust)
 import Data.Scientific         (floatingOrInteger)
-import Data.Time.Clock         (NominalDiffTime)
 import Numeric                 (readOct, showOct)
 import System.Environment      (getEnvironment)
 import System.Posix.Types      (FileMode)
@@ -71,7 +70,6 @@ data AppConfig = AppConfig
   , configDbMaxRows             :: Maybe Integer
   , configDbPlanEnabled         :: Bool
   , configDbPoolSize            :: Int
-  , configDbPoolTimeout         :: NominalDiffTime
   , configDbPreRequest          :: Maybe QualifiedIdentifier
   , configDbPreparedStatements  :: Bool
   , configDbRootSpec            :: Maybe QualifiedIdentifier
@@ -131,7 +129,6 @@ toText conf =
       ,("db-max-rows",                   maybe "\"\"" show . configDbMaxRows)
       ,("db-plan-enabled",               T.toLower . show . configDbPlanEnabled)
       ,("db-pool",                       show . configDbPoolSize)
-      ,("db-pool-timeout",               show . floor . configDbPoolTimeout)
       ,("db-pre-request",            q . maybe mempty dumpQi . configDbPreRequest)
       ,("db-prepared-statements",        T.toLower . show . configDbPreparedStatements)
       ,("db-root-spec",              q . maybe mempty dumpQi . configDbRootSpec)
@@ -220,7 +217,6 @@ parser optPath env dbSettings =
                      (optInt "max-rows")
     <*> (fromMaybe False <$> optBool "db-plan-enabled")
     <*> (fromMaybe 10 <$> optInt "db-pool")
-    <*> (fromIntegral . fromMaybe 3600 <$> optInt "db-pool-timeout")
     <*> (fmap toQi <$> optWithAlias (optString "db-pre-request")
                                     (optString "pre-request"))
     <*> (fromMaybe True <$> optBool "db-prepared-statements")

src/PostgREST/Error.hs

@@ -225,12 +225,17 @@ instance JSON.ToJSON PgError where
   toJSON (PgError _ usageError) = JSON.toJSON usageError
 
 instance JSON.ToJSON SQL.UsageError where
-  toJSON (SQL.ConnectionError e) = JSON.object [
+  toJSON (SQL.ConnectionUsageError e) = JSON.object [
     "code"    .= ConnectionErrorCode00,
     "message" .= ("Database connection error. Retrying the connection." :: Text),
     "details" .= (T.decodeUtf8With T.lenientDecode $ fromMaybe "" e :: Text),
     "hint"    .= JSON.Null]
-  toJSON (SQL.SessionError e) = JSON.toJSON e -- SQL.Error
+  toJSON (SQL.SessionUsageError e) = JSON.toJSON e -- SQL.Error
+  toJSON SQL.PoolIsReleasedUsageError = JSON.object [
+    "code"    .= InternalErrorCode00,
+    "message" .= ("Use of released pool" :: Text),
+    "details" .= JSON.Null,
+    "hint"    .= JSON.Null]
 
 instance JSON.ToJSON SQL.QueryError where
   toJSON (SQL.QueryError _ _ e) = JSON.toJSON e
@@ -255,9 +260,10 @@ instance JSON.ToJSON SQL.CommandError where
     "hint"    .= JSON.Null]
 
 pgErrorStatus :: Bool -> SQL.UsageError -> HTTP.Status
-pgErrorStatus _      (SQL.ConnectionError _)                                      = HTTP.status503
-pgErrorStatus _      (SQL.SessionError (SQL.QueryError _ _ (SQL.ClientError _)))      = HTTP.status503
-pgErrorStatus authed (SQL.SessionError (SQL.QueryError _ _ (SQL.ResultError rError))) =
+pgErrorStatus _      (SQL.ConnectionUsageError _) = HTTP.status503
+pgErrorStatus _      SQL.PoolIsReleasedUsageError = HTTP.status500
+pgErrorStatus _      (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _)))      = HTTP.status503
+pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError rError))) =
   case rError of
     (SQL.ServerError c m _ _) ->
       case BS.unpack c of
@@ -296,12 +302,12 @@ pgErrorStatus authed (SQL.SessionError (SQL.QueryError _ _ (SQL.ResultError rErr
     _                       -> HTTP.status500
 
 checkIsFatal :: PgError -> Maybe Text
-checkIsFatal (PgError _ (SQL.ConnectionError e))
+checkIsFatal (PgError _ (SQL.ConnectionUsageError e))
   | isAuthFailureMessage = Just $ toS failureMessage
   | otherwise = Nothing
   where isAuthFailureMessage = "FATAL:  password authentication failed" `isPrefixOf` failureMessage
         failureMessage = BS.unpack $ fromMaybe mempty e
-checkIsFatal (PgError _ (SQL.SessionError (SQL.QueryError _ _ (SQL.ResultError serverError))))
+checkIsFatal (PgError _ (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" _ _ _

src/PostgREST/Workers.hs

@@ -68,13 +68,13 @@ connectionWorker appState = do
     work = do
       AppConfig{..} <- AppState.getConfig appState
       AppState.logWithZTime appState "Attempting to connect to the database..."
-      connected <- connectionStatus appState
+      connected <- establishConnection appState
       case connected of
         FatalConnectionError reason ->
           -- Fatal error when connecting
           AppState.logWithZTime appState reason >> killThread (AppState.getMainThreadId appState)
         NotConnected ->
-          -- Unreachable because connectionStatus will keep trying to connect
+          -- Unreachable because establishConnection will keep trying to connect
           return ()
         Connected actualPgVersion -> do
           -- Procede with initialization
@@ -97,19 +97,20 @@ connectionWorker appState = do
               -- die if our schema cache query has an error
               killThread $ AppState.getMainThreadId appState
 
--- | Check if a connection from the pool allows access to the PostgreSQL
--- database.  If not, the pool connections are released and a new connection is
--- tried.  Releasing the pool is key for rapid recovery. Otherwise, the pool
+-- | Repeatedly flush the pool, and check if a connection from the
+-- pool allows access to the PostgreSQL database.
+--
+-- Releasing the pool is key for rapid recovery. Otherwise, the pool
 -- timeout would have to be reached for new healthy connections to be acquired.
 -- Which might not happen if the server is busy with requests. No idle
 -- connection, no pool timeout.
 --
 -- The connection tries are capped, but if the connection times out no error is
 -- thrown, just 'False' is returned.
-connectionStatus :: AppState -> IO ConnectionStatus
-connectionStatus appState =
+establishConnection :: AppState -> IO ConnectionStatus
+establishConnection appState =
   retrying retrySettings shouldRetry $
-    const $ AppState.releasePool appState >> getConnectionStatus
+    const $ AppState.flushPool appState >> getConnectionStatus
   where
     retrySettings = capDelay delayMicroseconds $ exponentialBackoff backoffMicroseconds
     delayMicroseconds = 32000000 -- 32 seconds

stack.yaml

@@ -14,7 +14,7 @@ extra-deps:
   - configurator-pg-0.2.6@sha256:cd9b06a458428e493a4d6def725af7ab1ab0fef678fbd871f9586fc7f9aa70be,2849
   - hasql-dynamic-statements-0.3.1.1@sha256:2cfe6e75990e690f595a87cbe553f2e90fcd738610f6c66749c81cc4396b2cc4,2675
   - hasql-implicits-0.1.0.4@sha256:0848d3cbc9d94e1e539948fa0be4d0326b26335034161bf8076785293444ca6f,1361
-  - hasql-pool-0.5.2.2@sha256:b56d4dea112d97a2ef4b2749508c0ca646828cb2d77b827e8dc433d249bb2062,2438
+  - hasql-pool-0.7.2@sha256:3f9178ab710e71e241617158c7d8e96a6c27de8e5bc8d140885dd13667899467,2414
   - lens-aeson-1.1.3@sha256:52c8eaecd2d1c2a969c0762277c4a8ee72c339a686727d5785932e72ef9c3050,1764
   - optparse-applicative-0.16.1.0@sha256:418c22ed6a19124d457d96bc66bd22c93ac22fad0c7100fe4972bbb4ac989731,4982
   - protolude-0.3.2@sha256:2a38b3dad40d238ab644e234b692c8911423f9d3ed0e36b62287c4a698d92cd1,2240

stack.yaml.lock

@@ -33,12 +33,12 @@ packages:
   original:
     hackage: hasql-implicits-0.1.0.4@sha256:0848d3cbc9d94e1e539948fa0be4d0326b26335034161bf8076785293444ca6f,1361
 - completed:
-    hackage: hasql-pool-0.5.2.2@sha256:b56d4dea112d97a2ef4b2749508c0ca646828cb2d77b827e8dc433d249bb2062,2438
+    hackage: hasql-pool-0.7.2@sha256:3f9178ab710e71e241617158c7d8e96a6c27de8e5bc8d140885dd13667899467,2414
     pantry-tree:
-      size: 412
-      sha256: 2741a33f947d28b4076c798c20c1f646beecd21f5eaf522c8256cbeb34d4d6d0
+      size: 345
+      sha256: 70142f456d6613f8e0465321fdaa25811c013eca96c240501a490cbdb47d1c4a
   original:
-    hackage: hasql-pool-0.5.2.2@sha256:b56d4dea112d97a2ef4b2749508c0ca646828cb2d77b827e8dc433d249bb2062,2438
+    hackage: hasql-pool-0.7.2@sha256:3f9178ab710e71e241617158c7d8e96a6c27de8e5bc8d140885dd13667899467,2414
 - completed:
     hackage: lens-aeson-1.1.3@sha256:52c8eaecd2d1c2a969c0762277c4a8ee72c339a686727d5785932e72ef9c3050,1764
     pantry-tree:

test/io/configs/expected/aliases.config

@@ -5,7 +5,6 @@ db-extra-search-path = "public"
 db-max-rows = 1000
 db-plan-enabled = false
 db-pool = 10
-db-pool-timeout = 3600
 db-pre-request = "check_alias"
 db-prepared-statements = true
 db-root-spec = "open_alias"

test/io/configs/expected/boolean-numeric.config

@@ -5,7 +5,6 @@ db-extra-search-path = "public"
 db-max-rows = ""
 db-plan-enabled = false
 db-pool = 10
-db-pool-timeout = 3600
 db-pre-request = ""
 db-prepared-statements = false
 db-root-spec = ""

test/io/configs/expected/boolean-string.config

@@ -5,7 +5,6 @@ db-extra-search-path = "public"
 db-max-rows = ""
 db-plan-enabled = false
 db-pool = 10
-db-pool-timeout = 3600
 db-pre-request = ""
 db-prepared-statements = false
 db-root-spec = ""

test/io/configs/expected/defaults.config

@@ -5,7 +5,6 @@ db-extra-search-path = "public"
 db-max-rows = ""
 db-plan-enabled = false
 db-pool = 10
-db-pool-timeout = 3600
 db-pre-request = ""
 db-prepared-statements = true
 db-root-spec = ""

test/io/configs/expected/no-defaults-with-db-other-authenticator.config

@@ -5,7 +5,6 @@ db-extra-search-path = "public,extensions,other"
 db-max-rows = 100
 db-plan-enabled = true
 db-pool = 1
-db-pool-timeout = 100
 db-pre-request = "test.other_custom_headers"
 db-prepared-statements = false
 db-root-spec = "other_root"

test/io/configs/expected/no-defaults-with-db.config

@@ -5,7 +5,6 @@ db-extra-search-path = "public,extensions,private"
 db-max-rows = 1000
 db-plan-enabled = true
 db-pool = 1
-db-pool-timeout = 100
 db-pre-request = "test.custom_headers"
 db-prepared-statements = false
 db-root-spec = "root"

test/io/configs/expected/no-defaults.config

@@ -5,7 +5,6 @@ db-extra-search-path = "public,test"
 db-max-rows = 1000
 db-plan-enabled = true
 db-pool = 1
-db-pool-timeout = 100
 db-pre-request = "please_run_fast"
 db-prepared-statements = false
 db-root-spec = "openapi_v3"

test/io/configs/expected/types.config

@@ -5,7 +5,6 @@ db-extra-search-path = "public"
 db-max-rows = ""
 db-plan-enabled = false
 db-pool = 10
-db-pool-timeout = 3600
 db-pre-request = ""
 db-prepared-statements = true
 db-root-spec = ""