upgrade to fork of hasql-pool 0.7.2 (fixes #2401)

This version of hasql-pool is a simplified rewrite that doesn't use the resource-pool package. The major API changes are that idle connections are no longer timed out (and the corresponding setting is gone), and that `release` makes the pool unusable, where it used to remain usable and only flushed idle connections. We depend on a PostgREST fork of 0.7.2 that gives us reliable flushing, compare https://github.com/PostgREST/hasql-pool/pull/1 - hasql-pool 0.7 removes timing out of idle connections, so this change removes the db-pool-timeout option. Given that we were typically running with very high timeout settings, I don't anticipate the lack of timeout to introduce new issues, though we might want to consider introducing some retry-logic down the line when we encounter connection failures. - See https://github.com/PostgREST/postgrest/issues/2422 for a discussion on depending on a forked dependency. Besides adding the dependency to the nix overlay, we're also adding it to stack.yaml and a new cabal.project to allow stack/cabal users to build the project.
2022-08-29 14:55:09 +02:00
parent cdce929159
commit 90eaaefe12
25 changed files with 69 additions and 53 deletions
@@ -224,6 +224,9 @@ jobs:
        run: |
          ghcup install ghc ${{ matrix.ghc }}
          ghcup set ghc ${{ matrix.ghc }}
+      - name: Copy cabal.project
+        run: |
+          cp cabal.project.non-nix cabal.project
      - name: Cache
        uses: actions/cache@v3
        with:
@@ -8,6 +8,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 ### Deprecated

 - #1385, Deprecate bulk-calls when including the `Prefer: params=multiple-objects` in the request. A function with a JSON array or object parameter should be used instead for a better performance.
+ - #2401, #2444, Fix SIGUSR1 to fully flush connections pool, remove `db-pool-timeout`. - @robx

 ## [10.0.0] - 2022-08-18

@@ -74,6 +75,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

@@ -0,0 +1,10 @@
+-- Settings to allow building with plain cabal. If this was
+-- named just cabal.project, it would interfere with the default
+-- nix build.
+
+packages: .
+
+source-repository-package
+  type: git
+  location: https://github.com/PostgREST/hasql-pool.git
+  tag: 4d462c4d47d762effefc7de6c85eaed55f144f1d
@@ -31,6 +31,16 @@ let
      #
      # To get the sha256:
      #   nix-prefetch-url --unpack https://github.com/<owner>/<repo>/archive/<commit>.tar.gz
+
+      hasql-pool = lib.dontCheck (
+        prev.callCabal2nix "hasql-pool"
+          (super.fetchFromGitHub {
+            owner = "PostgREST";
+            repo = "hasql-pool";
+            rev = "4d462c4d47d762effefc7de6c85eaed55f144f1d"; # master as of 2022-08-26
+            sha256 = "sha256-UwX1PynimrQHm1KCs4BQXMwYYY3h4T5UAkgtEJ0EZQQ=";
+          })
+          { });
    } // extraOverrides final prev;
 in
 {
@@ -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
@@ -74,12 +74,12 @@ 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
+initWithPool pool conf =
+  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
@@ -93,23 +93,24 @@ initWithPool newPool conf =
    <*> newIORef 0

 destroy :: AppState -> IO ()
-destroy AppState{..} = SQL.release statePool
+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.
 usePool :: AppState -> SQL.Session a -> IO (Either SQL.UsageError a)
 usePool AppState{..} = SQL.use statePool

 -- | Flush the connection pool so that any future use of the pool will
 -- use connections freshly established after this call.
--
-- FIXME: #2401 Connections that are in-use during the call to flushPool
-- will currently be returned to the pool and reused afterwards, in
-- conflict with the intention.
 flushPool :: AppState -> IO ()
-flushPool AppState{..} = SQL.release statePool
+flushPool AppState{..} = SQL.flush statePool
+
+-- | Destroy the pool on shutdown.
+destroyPool :: AppState -> IO ()
+destroyPool AppState{..} = SQL.release statePool

 getPgVersion :: AppState -> IO PgVersion
 getPgVersion = readIORef . statePgVersion
@@ -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"
      |
@@ -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")
@@ -356,7 +352,7 @@ 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_timeout", "db_config"]
+            "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_config"]
          then lookup dbSettingName dbSettings
          else Nothing

@@ -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" _ _ _
@@ -14,8 +14,9 @@ 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
  - lens-aeson-1.1.3@sha256:52c8eaecd2d1c2a969c0762277c4a8ee72c339a686727d5785932e72ef9c3050,1764
  - optparse-applicative-0.16.1.0@sha256:418c22ed6a19124d457d96bc66bd22c93ac22fad0c7100fe4972bbb4ac989731,4982
  - protolude-0.3.2@sha256:2a38b3dad40d238ab644e234b692c8911423f9d3ed0e36b62287c4a698d92cd1,2240
  - ptr-0.16.8.2@sha256:708ebb95117f2872d2c5a554eb6804cf1126e86abe793b2673f913f14e5eb1ac,3959
+  - git: https://github.com/PostgREST/hasql-pool.git
+    commit: 4d462c4d47d762effefc7de6c85eaed55f144f1d
@@ -32,13 +32,6 @@ packages:
      sha256: d49af8f8749ab7039fa668af4b78f997f7fa2928b4aded6798f573a3d08e76a0
  original:
    hackage: hasql-implicits-0.1.0.4@sha256:0848d3cbc9d94e1e539948fa0be4d0326b26335034161bf8076785293444ca6f,1361
- completed:
-    hackage: hasql-pool-0.5.2.2@sha256:b56d4dea112d97a2ef4b2749508c0ca646828cb2d77b827e8dc433d249bb2062,2438
-    pantry-tree:
-      size: 412
-      sha256: 2741a33f947d28b4076c798c20c1f646beecd21f5eaf522c8256cbeb34d4d6d0
-  original:
-    hackage: hasql-pool-0.5.2.2@sha256:b56d4dea112d97a2ef4b2749508c0ca646828cb2d77b827e8dc433d249bb2062,2438
 - completed:
    hackage: lens-aeson-1.1.3@sha256:52c8eaecd2d1c2a969c0762277c4a8ee72c339a686727d5785932e72ef9c3050,1764
    pantry-tree:
@@ -67,6 +60,17 @@ packages:
      sha256: 557c438345de19f82bf01d676100da2a191ef06f624e7a4b90b09ac17cbb52a5
  original:
    hackage: ptr-0.16.8.2@sha256:708ebb95117f2872d2c5a554eb6804cf1126e86abe793b2673f913f14e5eb1ac,3959
+- completed:
+    name: hasql-pool
+    version: 0.7.2
+    git: https://github.com/PostgREST/hasql-pool.git
+    pantry-tree:
+      size: 570
+      sha256: a388a9fc47252f7ba06874bc7e8fca769e6f33752320a29724801c298be00816
+    commit: 4d462c4d47d762effefc7de6c85eaed55f144f1d
+  original:
+    git: https://github.com/PostgREST/hasql-pool.git
+    commit: 4d462c4d47d762effefc7de6c85eaed55f144f1d
 snapshots:
 - completed:
    size: 618951
@@ -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"
@@ -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 = ""
@@ -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 = ""
@@ -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 = ""
@@ -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"
@@ -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"
@@ -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"
@@ -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 = ""
@@ -7,7 +7,6 @@ PGRST_DB_EXTRA_SEARCH_PATH: public, test
 PGRST_DB_MAX_ROWS: 1000
 PGRST_DB_PLAN_ENABLED: true
 PGRST_DB_POOL: 1
-PGRST_DB_POOL_TIMEOUT: 100
 PGRST_DB_PREPARED_STATEMENTS: false
 PGRST_DB_PRE_REQUEST: please_run_fast
 PGRST_DB_ROOT_SPEC: openapi_v3
@@ -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"
@@ -123,7 +123,6 @@ def defaultenv(baseenv):
        "PGRST_DB_CONFIG": "true",
        "PGRST_LOG_LEVEL": "info",
        "PGRST_DB_POOL": "1",
-        "PGRST_DB_POOL_TIMEOUT": "1",
    }


@@ -139,7 +138,6 @@ def metapostgrest():
        "PGRST_DB_CONFIG": "true",
        "PGRST_LOG_LEVEL": "info",
        "PGRST_DB_POOL": "1",
-        "PGRST_DB_POOL_TIMEOUT": "1",
    }
    with run(env=env) as postgrest:
        yield postgrest
@@ -995,7 +993,6 @@ def test_pool_size(defaultenv, metapostgrest):
        assert delta > 1 and delta < 1.5


-@pytest.mark.xfail(reason="issue #2401")
 def test_change_statement_timeout_held_connection(defaultenv, metapostgrest):
    "Statement timeout changes take effect immediately, even with a request outliving the reconfiguration"

@@ -64,7 +64,7 @@ import qualified Feature.RpcPreRequestGucsSpec

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

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

@@ -24,7 +24,7 @@ import Test.Hspec

 main :: IO ()
 main = do
-  pool <- P.acquire (3, 10, "postgresql://")
+  pool <- P.acquire 3 "postgresql://"

  hspec $ describe "QueryCost" $
    context "call proc query" $ do
@@ -79,7 +79,6 @@ baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in
  , configDbMaxRows             = Nothing
  , configDbPlanEnabled         = False
  , configDbPoolSize            = 10
-  , configDbPoolTimeout         = 10
  , configDbPreRequest          = Just $ QualifiedIdentifier "test" "switch_role"
  , configDbPreparedStatements  = True
  , configDbRootSpec            = Nothing