jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Robert Vollmert
2022-08-29 14:55:09 +02:00
committed by Robert
parent cdce929159
commit 90eaaefe12
25 changed files with 69 additions and 53 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/AppState.hs
+12 -11
View File
@@ -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
src/PostgREST/CLI.hs
-3
View File
@@ -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
+1 -5
View File
@@ -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
src/PostgREST/Error.hs
+13 -7
View File
@@ -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" _ _ _