From a5cc4578751ef00265d8c363fc711ff64dffb038 Mon Sep 17 00:00:00 2001 From: Wolfgang Walther Date: Thu, 10 Jul 2025 14:29:32 +0200 Subject: [PATCH] chore(deps): update hasql to 1.9.3.1 Michael and I arrived at mostly the same things independently. Took some of his, some of mine. Co-authored-by: Michal Kleczek --- nix/overlays/haskell-packages.nix | 12 ------ postgrest.cabal | 18 ++++----- src/PostgREST/AppState.hs | 60 ++++++++++++++++------------- src/PostgREST/CLI.hs | 4 +- src/PostgREST/Config.hs | 35 +++++++++++------ src/PostgREST/Config/Database.hs | 18 ++++----- src/PostgREST/Error.hs | 11 +++++- src/PostgREST/Listener.hs | 8 ++-- src/PostgREST/Logger.hs | 9 +++-- src/PostgREST/MainTx.hs | 3 +- src/PostgREST/Metrics.hs | 2 +- src/PostgREST/SchemaCache.hs | 57 ++++++++++++++-------------- src/PostgREST/Version.hs | 6 +++ stack.yaml | 10 +---- stack.yaml.lock | 63 ++++--------------------------- test/observability/Main.hs | 7 ++-- test/spec/Main.hs | 7 ++-- 17 files changed, 146 insertions(+), 184 deletions(-) diff --git a/nix/overlays/haskell-packages.nix b/nix/overlays/haskell-packages.nix index c3fda9c7a..288a7d48c 100644 --- a/nix/overlays/haskell-packages.nix +++ b/nix/overlays/haskell-packages.nix @@ -49,17 +49,6 @@ let # Before upgrading fuzzyset to 0.3, check: https://github.com/PostgREST/postgrest/issues/3329 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); - text-builder = prev.text-builder_0_6_10; - text-builder-dev = prev.text-builder-dev_0_3_10; - http2 = prev.callHackageDirect { @@ -95,7 +84,6 @@ let sha256 = "sha256-jmr8kpeSPDkOhT0i9PhozZapX4nUs92cOX7POAGb7/M="; } { }); - }; in { diff --git a/postgrest.cabal b/postgrest.cabal index 5a7e77090..2a819d80b 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -117,11 +117,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-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 >= 1.9 && <= 1.9.3.1 + , hasql-dynamic-statements >= 0.3.1 && <= 0.3.1.8 + , hasql-notifications >= 0.2.4.0 && < 0.3 + , hasql-pool >= 1.1 && <= 1.3.0.4 + , hasql-transaction >= 1.0.1 && <= 1.2.1 , http-client >= 0.7.19 && < 0.8 , http-types >= 0.12.2 && < 0.13 , insert-ordered-containers >= 0.2.2 && < 0.3 @@ -270,8 +270,8 @@ test-suite spec , bytestring >= 0.10.8 && < 0.13 , case-insensitive >= 1.2 && < 1.3 , containers >= 0.5.7 && < 0.8 - , hasql-pool >= 1.0.1 && < 1.1 - , hasql-transaction >= 1.0.1 && < 1.2 + , hasql-pool >= 1.0.1 && <= 1.3.0.4 + , hasql-transaction >= 1.0.1 && <= 1.2.1 , heredoc >= 0.2 && < 0.3 , hspec >= 2.3 && < 2.12 , hspec-expectations >= 0.8.4 && < 0.9 @@ -314,8 +314,8 @@ test-suite observability build-depends: base >= 4.9 && < 4.22 , base64-bytestring >= 1 && < 1.3 , bytestring >= 0.10.8 && < 0.13 - , hasql-pool >= 1.0.1 && < 1.1 - , hasql-transaction >= 1.0.1 && < 1.2 + , hasql-pool >= 1.0.1 && <= 1.3.0.4 + , hasql-transaction >= 1.0.1 && <= 1.2.1 , hspec >= 2.3 && < 2.12 , hspec-expectations >= 0.8.4 && < 0.9 , hspec-wai >= 0.10 && < 0.12 diff --git a/src/PostgREST/AppState.hs b/src/PostgREST/AppState.hs index fd2edd2f7..110c7ce13 100644 --- a/src/PostgREST/AppState.hs +++ b/src/PostgREST/AppState.hs @@ -55,8 +55,8 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import PostgREST.Auth.JwtCache (JwtCacheState, update) import PostgREST.Config (AppConfig (..), - addFallbackAppName, - readAppConfig) + readAppConfig, + toConnectionSettings) import PostgREST.Config.Database (queryDbSettings, queryPgVersion, queryRoleSettings) @@ -143,34 +143,47 @@ destroy :: AppState -> IO () destroy = destroyPool initPool :: AppConfig -> ObservationHandler -> IO SQL.Pool -initPool AppConfig{..} observer = do +initPool cfg@AppConfig{..} observer = do SQL.acquire $ SQL.settings [ SQL.size configDbPoolSize , SQL.acquisitionTimeout $ fromIntegral configDbPoolAcquisitionTimeout , SQL.agingTimeout $ fromIntegral configDbPoolMaxLifetime , SQL.idlenessTimeout $ fromIntegral configDbPoolMaxIdletime - , SQL.staticConnectionSettings (toUtf8 $ addFallbackAppName prettyVersion configDbUri) + , SQL.staticConnectionSettings $ toConnectionSettings identity cfg , 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 - 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 + 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 + err@(SQL.SessionUsageError (SQL.PipelineError (SQL.ResultError resultErr))) -> + -- Passing the empty template will not work for schema cache queries, see TODO further below. + handleResultError err mempty resultErr + err@(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _))) -> + -- An error on the client-side, usually indicates problems with connection + 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 @@ -203,12 +216,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 with 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. @@ -308,7 +315,7 @@ retryingSchemaCacheLoad appState@AppState{stateObserver=observer, stateMainThrea qPgVersion :: IO (Maybe PgVersion) qPgVersion = do AppConfig{..} <- getConfig appState - pgVersion <- usePool appState (queryPgVersion False) -- No need to prepare the query here, as the connection might not be established + pgVersion <- usePool appState queryPgVersion case pgVersion of Left e -> do observer $ QueryPgVersionError e @@ -336,8 +343,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.transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) case result of Left e -> do markSchemaCachePending appState @@ -393,7 +399,7 @@ readInDbConfig startingUp appState@AppState{stateObserver=observer} = do pgVer <- getPgVersion appState dbSettings <- if configDbConfig conf then do - qDbSettings <- usePool appState (queryDbSettings (quoteQi <$> configDbPreConfig conf) (configDbPreparedStatements conf)) + qDbSettings <- usePool appState (queryDbSettings (quoteQi <$> configDbPreConfig conf)) case qDbSettings of Left e -> do observer $ ConfigReadErrorObs e @@ -403,7 +409,7 @@ readInDbConfig startingUp appState@AppState{stateObserver=observer} = do pure mempty (roleSettings, roleIsolationLvl) <- if configDbConfig conf then do - rSettings <- usePool appState (queryRoleSettings pgVer (configDbPreparedStatements conf)) + rSettings <- usePool appState (queryRoleSettings pgVer) case rSettings of Left e -> do observer $ QueryRoleSettingsErrorObs e diff --git a/src/PostgREST/CLI.hs b/src/PostgREST/CLI.hs index a635aa081..debd0e66a 100644 --- a/src/PostgREST/CLI.hs +++ b/src/PostgREST/CLI.hs @@ -62,9 +62,7 @@ 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) + AppState.usePool appState (SQL.transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) case result of Left e -> do let observer = AppState.getObserver appState diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 020779393..0590414d8 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -9,6 +9,7 @@ Description : Manages PostgREST configuration type and parser. {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NamedFieldPuns #-} module PostgREST.Config ( AppConfig (..) @@ -27,22 +28,25 @@ module PostgREST.Config , parseSecret , addFallbackAppName , addTargetSessionAttrs + , toConnectionSettings , exampleConfigFile , audMatchesCfg , Verbosity (..) ) where -import qualified Data.Aeson as JSON -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import qualified Data.CaseInsensitive as CI -import qualified Data.Configurator as C -import qualified Data.Map.Strict as M -import qualified Data.String as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Jose.Jwa as JWT -import qualified Jose.Jwk as JWT +import qualified Data.Aeson as JSON +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.CaseInsensitive as CI +import qualified Data.Configurator as C +import qualified Data.Map.Strict as M +import qualified Data.String as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Hasql.Connection.Setting as SQL +import qualified Hasql.Connection.Setting.Connection as SQL +import qualified Jose.Jwa as JWT +import qualified Jose.Jwk as JWT import Control.Monad (fail) import Data.Either.Combinators (mapLeft) @@ -67,7 +71,8 @@ import PostgREST.Config.Proxy (Proxy (..), import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..), toQi) -import Protolude hiding (Proxy, toList) +import PostgREST.Version (prettyVersion) +import Protolude hiding (Proxy, toList) audMatchesCfg :: AppConfig -> Text -> Bool audMatchesCfg = maybe (const True) (==) . configJwtAudience @@ -646,6 +651,12 @@ addFallbackAppName version dbUri = addConnStringOption dbUri "fallback_applicati addTargetSessionAttrs :: Text -> Text addTargetSessionAttrs dbUri = addConnStringOption dbUri "target_session_attrs" "read-write" +toConnectionSettings :: (Text -> Text) -> AppConfig -> [SQL.Setting] +toConnectionSettings transformUri AppConfig{configDbUri, configDbPreparedStatements} = + [ SQL.connection $ SQL.string $ transformUri . addFallbackAppName prettyVersion $ configDbUri + , SQL.usePreparedStatements configDbPreparedStatements + ] + addConnStringOption :: Text -> Text -> Text -> Text addConnStringOption dbUri key val = dbUri <> case pgConnString dbUri of diff --git a/src/PostgREST/Config/Database.hs b/src/PostgREST/Config/Database.hs index 7c77f9fdd..3aeb93ba5 100644 --- a/src/PostgREST/Config/Database.hs +++ b/src/PostgREST/Config/Database.hs @@ -72,8 +72,8 @@ dbSettingsNames = ,"server_timing_enabled" ] -queryPgVersion :: Bool -> Session PgVersion -queryPgVersion prepared = statement mempty $ pgVersionStatement prepared +queryPgVersion :: Session PgVersion +queryPgVersion = statement mempty $ pgVersionStatement False pgVersionStatement :: Bool -> SQL.Statement () PgVersion pgVersionStatement = SQL.Statement sql HE.noParams versionRow @@ -92,10 +92,9 @@ pgVersionStatement = SQL.Statement sql HE.noParams versionRow -- -- The example above will result in jwt_aud = 'val' -- A setting on the database only will have no effect: ALTER DATABASE postgres SET 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 +queryDbSettings :: Maybe Text -> Session [(Text, Text)] +queryDbSettings preConfFunc = + SQL.transaction SQL.ReadCommitted SQL.Read $ SQL.statement dbSettingsNames $ SQL.Statement sql (arrayParam HE.text) decodeSettings True where sql = encodeUtf8 [trimming| WITH @@ -133,10 +132,9 @@ queryDbSettings preConfFunc prepared = |]::Text decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text -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 +queryRoleSettings :: PgVersion -> Session (RoleSettings, RoleIsolationLvl) +queryRoleSettings pgVer = + SQL.transaction SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.Statement sql HE.noParams (processRows <$> rows) True where sql = encodeUtf8 [trimming| with diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 86d53c223..2399adf81 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -471,18 +471,22 @@ instance ErrorBody PgError 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 @@ -527,8 +531,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 diff --git a/src/PostgREST/Listener.hs b/src/PostgREST/Listener.hs index 1f49769db..80c65c218 100644 --- a/src/PostgREST/Listener.hs +++ b/src/PostgREST/Listener.hs @@ -11,7 +11,6 @@ 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 @@ -37,7 +36,7 @@ runListener appState = do -- | This function never returns (but can throw) and return type enforces that. retryingListen :: AppState -> IO Void retryingListen appState = do - AppConfig{..} <- AppState.getConfig appState + cfg@AppConfig{..} <- AppState.getConfig appState let dbChannel = toS configDbChannel onError err = do @@ -62,7 +61,8 @@ retryingListen appState = do -- Make sure we don't leak connections on errors bracket -- acquire connection - (SQL.acquire $ toUtf8 (Config.addTargetSessionAttrs $ Config.addFallbackAppName prettyVersion configDbUri)) + (SQL.acquire $ + Config.toConnectionSettings Config.addTargetSessionAttrs cfg) -- release connection (`whenRight` releaseConnection) $ -- use connection @@ -70,7 +70,7 @@ retryingListen appState = do Right db -> do SQL.listen db $ SQL.toPgIdentifier dbChannel (pqHost, pqPort) <- SQL.withLibPQConnection db $ bisequence . (LibPQ.host &&& LibPQ.port) - pgFullName <- SQL.run (queryPgVersion False) db >>= either throwIO (pure . pgvFullName) + pgFullName <- SQL.run queryPgVersion db >>= either throwIO (pure . pgvFullName) AppState.putIsListenerOn appState True diff --git a/src/PostgREST/Logger.hs b/src/PostgREST/Logger.hs index a43040137..b00bc775f 100644 --- a/src/PostgREST/Logger.hs +++ b/src/PostgREST/Logger.hs @@ -133,9 +133,8 @@ logWithZTime loggerState txts = do -- the SQL.Snippet or maybe don't use hasql-dynamic-statements and resort to plain strings for the queries and use regular hasql renderSnippet :: SQL.Snippet -> ByteString renderSnippet snippet = - let SQL.Statement sql _ _ _ = SQL.dynamicallyParameterized snippet decoder prepared + let SQL.Statement sql _ _ _ = SQL.dynamicallyParameterized snippet decoder False decoder = HD.noResult -- unused - prepared = False -- unused in sql @@ -218,13 +217,17 @@ observationMessages = \case pure $ "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 -> pure "Trying to borrow a connection from pool" diff --git a/src/PostgREST/MainTx.hs b/src/PostgREST/MainTx.hs index 5d4e9818e..26222526d 100644 --- a/src/PostgREST/MainTx.hs +++ b/src/PostgREST/MainTx.hs @@ -96,9 +96,8 @@ data ResultSet mainTx :: MainQuery -> AppConfig -> AuthResult -> ApiRequest -> ActionPlan -> SchemaCache -> MainTx mainTx _ _ _ _ (NoDb x) _ = NoDbTx $ NoDbResult x mainTx genQ@MainQuery{..} conf@AppConfig{..} AuthResult{..} apiReq (Db plan) sCache = - DbTx isoLvl txMode dbHandler transaction + DbTx isoLvl txMode dbHandler SQL.transaction where - transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction isoLvl = planIsoLvl conf authRole plan txMode = planTxMode plan dbHandler = do diff --git a/src/PostgREST/Metrics.hs b/src/PostgREST/Metrics.hs index 6261cbb1a..bf7ce017b 100644 --- a/src/PostgREST/Metrics.hs +++ b/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 diff --git a/src/PostgREST/SchemaCache.hs b/src/PostgREST/SchemaCache.hs index cdc1e6930..bd1e849ea 100644 --- a/src/PostgREST/SchemaCache.hs +++ b/src/PostgREST/SchemaCache.hs @@ -158,23 +158,23 @@ maxDbTablesForFuzzySearch = 500 querySchemaCache :: AppConfig -> SQL.Transaction SchemaCache querySchemaCache conf@AppConfig{..} = do SQL.sql "set local schema ''" -- This voids the search path. The following queries need this for getting the fully qualified name(schema.name) of every db object - tabs <- sqlTimedStmt gucTbls conf $ allTables prepared - keyDeps <- sqlTimedStmt gucKDeps conf $ allViewsKeyDependencies prepared - m2oRels <- sqlTimedStmt gucRels mempty $ allM2OandO2ORels prepared - funcs <- sqlTimedStmt gucFuncs conf $ allFunctions prepared - cRels <- sqlTimedStmt gucCRels mempty $ allComputedRels prepared - reps <- sqlTimedStmt gucDReps conf $ dataRepresentations prepared - mHdlers <- sqlTimedStmt gucMHdrs conf $ mediaHandlers prepared + tabs <- sqlTimedStmt gucTbls conf allTables + keyDeps <- sqlTimedStmt gucKDeps conf allViewsKeyDependencies + m2oRels <- sqlTimedStmt gucRels mempty allM2OandO2ORels + funcs <- sqlTimedStmt gucFuncs conf allFunctions + cRels <- sqlTimedStmt gucCRels mempty allComputedRels + reps <- sqlTimedStmt gucDReps conf dataRepresentations + mHdlers <- sqlTimedStmt gucMHdrs conf mediaHandlers tzones <- if configDbTimezoneEnabled - then sqlTimedStmt gucTzones mempty $ timezones prepared + then sqlTimedStmt gucTzones mempty timezones else pure S.empty _ <- - let sleepCall = SQL.Statement "select pg_sleep($1 / 1000.0)" (param HE.int4) HD.noResult prepared in + let sleepCall = SQL.Statement "select pg_sleep($1 / 1000.0)" (param HE.int4) HD.noResult True in for_ configInternalSCQuerySleep (`SQL.statement` sleepCall) -- only used for testing qsTime <- if isLogDebug - then Just <$> SQL.statement mempty (extractTimings configDbTimezoneEnabled prepared) + then Just <$> SQL.statement mempty (extractTimings configDbTimezoneEnabled) else pure Nothing let tabsWViewsPks = addViewPrimaryKeys tabs keyDeps @@ -198,7 +198,6 @@ querySchemaCache conf@AppConfig{..} = do } where schemas = toList configDbSchemas - prepared = configDbPreparedStatements delayEval confDelay result = maybe result (unsafePerformIO . (($> result) . (threadDelay . (1000 *) . fromIntegral))) confDelay isLogDebug = configLogLevel == LogDebug sqlTimedStmt = sqlTimedStatement isLogDebug @@ -364,8 +363,8 @@ decodeRepresentations = -- 2. implicit -- For the time being it must also be to/from JSON or text, although one can imagine a future where we support special -- cases like CSV specific representations. -dataRepresentations :: Bool -> SQL.Statement AppConfig RepresentationsMap -dataRepresentations = SQL.Statement sql mempty decodeRepresentations +dataRepresentations :: SQL.Statement AppConfig RepresentationsMap +dataRepresentations = SQL.Statement sql mempty decodeRepresentations True where sql = encodeUtf8 [trimming| SELECT @@ -386,8 +385,8 @@ dataRepresentations = SQL.Statement sql mempty decodeRepresentations OR (dst_t.typtype = 'd' AND c.castsource IN ('json'::regtype::oid , 'text'::regtype::oid))) |] -allFunctions :: Bool -> SQL.Statement AppConfig RoutineMap -allFunctions = SQL.Statement funcsSqlQuery params decodeFuncs +allFunctions :: SQL.Statement AppConfig RoutineMap +allFunctions = SQL.Statement funcsSqlQuery params decodeFuncs True where params = (map escapeIdent . toList . configDbSchemas >$< arrayParam HE.text) <> @@ -599,8 +598,8 @@ addViewPrimaryKeys tabs keyDeps = takeFirstPK = mapMaybe (head . snd) indexedDeps = HM.fromListWith (++) $ fmap ((keyDepType &&& keyDepView) &&& pure) keyDeps -allTables :: Bool -> SQL.Statement AppConfig TablesMap -allTables = SQL.Statement tablesSqlQuery params decodeTables +allTables :: SQL.Statement AppConfig TablesMap +allTables = SQL.Statement tablesSqlQuery params decodeTables True where params = map escapeIdent . toList . configDbSchemas >$< arrayParam HE.text @@ -747,9 +746,9 @@ tablesSqlQuery = ORDER BY table_schema, table_name|] -- | Gets many-to-one relationships and one-to-one(O2O) relationships, which are a refinement of the many-to-one's -allM2OandO2ORels :: Bool -> SQL.Statement () [Relationship] +allM2OandO2ORels :: SQL.Statement () [Relationship] allM2OandO2ORels = - SQL.Statement sql HE.noParams decodeRels + SQL.Statement sql HE.noParams decodeRels True where -- We use jsonb_agg for comparing the uniques/pks instead of array_agg to avoid the ERROR: cannot accumulate arrays of different dimensionality sql = encodeUtf8 [trimming| @@ -791,9 +790,9 @@ allM2OandO2ORels = AND traint.conparentid = 0 ORDER BY traint.conrelid, traint.conname|] -allComputedRels :: Bool -> SQL.Statement () [Relationship] +allComputedRels :: SQL.Statement () [Relationship] allComputedRels = - SQL.Statement sql HE.noParams (HD.rowList cRelRow) + SQL.Statement sql HE.noParams (HD.rowList cRelRow) True where sql = encodeUtf8 [trimming| with @@ -837,9 +836,9 @@ allComputedRels = column HD.bool -- | Returns all the views' primary keys and foreign keys dependencies -allViewsKeyDependencies :: Bool -> SQL.Statement AppConfig [ViewKeyDependency] +allViewsKeyDependencies :: SQL.Statement AppConfig [ViewKeyDependency] allViewsKeyDependencies = - SQL.Statement sql params decodeViewKeyDeps + SQL.Statement sql params decodeViewKeyDeps True -- query explanation at: -- * rationale: https://gist.github.com/wolfgangwalther/5425d64e7b0d20aad71f6f68474d9f19 -- * json transformation: https://gist.github.com/wolfgangwalther/3a8939da680c24ad767e93ad2c183089 @@ -1047,9 +1046,9 @@ initialMediaHandlers = HM.insert (RelAnyElement, MediaType.MTGeoJSON ) (BuiltinOvAggGeoJson, MediaType.MTGeoJSON) HM.empty -mediaHandlers :: Bool -> SQL.Statement AppConfig MediaHandlerMap +mediaHandlers :: SQL.Statement AppConfig MediaHandlerMap mediaHandlers = - SQL.Statement sql params decodeMediaHandlers + SQL.Statement sql params decodeMediaHandlers True where params = map escapeIdent . toList . configDbSchemas >$< arrayParam HE.text sql = encodeUtf8 [trimming| @@ -1123,8 +1122,8 @@ decodeMediaHandlers = <*> (MediaType.decodeMediaType . encodeUtf8 <$> column HD.text) <*> (MediaType.decodeMediaType . encodeUtf8 <$> column HD.text) -timezones :: Bool -> SQL.Statement () TimezoneNames -timezones = SQL.Statement sql HE.noParams decodeTimezones +timezones :: SQL.Statement () TimezoneNames +timezones = SQL.Statement sql HE.noParams decodeTimezones True where sql = encodeUtf8 $ unlines -- This CTE wrapper is only added for clarifying the query under pg_stat_statements @@ -1183,8 +1182,8 @@ sqlTimedStatement isLogDebug guc params stmt = eFrag = "select set_config('pgrst." <> guc <> "', (clock_timestamp() - current_setting('pgrst." <> guc <> "', false)::timestamptz)::text, true)" -- Extract all the generated timings (see sqlTimedStatement) converting the value to milliseconds. -extractTimings :: Bool -> Bool -> SQL.Statement () QueryTimings -extractTimings hasTimezones = SQL.Statement sql HE.noParams decodeThem +extractTimings :: Bool -> SQL.Statement () QueryTimings +extractTimings hasTimezones = SQL.Statement sql HE.noParams decodeThem True where qFrag setting = "extract('milliseconds' from current_setting('pgrst." <> setting <> "', false)::interval)::text" sql = "SELECT " <> BS.intercalate "," diff --git a/src/PostgREST/Version.hs b/src/PostgREST/Version.hs index c1a9cf549..325f4f9dc 100644 --- a/src/PostgREST/Version.hs +++ b/src/PostgREST/Version.hs @@ -8,6 +8,12 @@ import qualified Data.Text as T import Protolude +-- Somehow this is not defined in doctests, so when running them +-- on a file that includes Version.hs, compilation fails. +#ifndef VERSION_postgrest +#define VERSION_postgrest "0" +#endif + version :: [Text] version = T.splitOn "." VERSION_postgrest diff --git a/stack.yaml b/stack.yaml index e650dcdac..fcd05694e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,17 +10,9 @@ nix: extra-deps: - configurator-pg-0.2.11 - fuzzyset-0.2.4 - - hasql-1.6.4.4 - - hasql-dynamic-statements-0.3.1.5 - - hasql-implicits-0.1.1.3 - - hasql-notifications-0.2.2.2 - - hasql-pool-1.0.1 - - hasql-transaction-1.1.0.1 + - hasql-notifications-0.2.4.0 - http-semantics-0.4.0 - http2-5.4.0 - - postgresql-binary-0.13.1.3 - - text-builder-0.6.10 - - text-builder-dev-0.3.10 - warp-3.4.13 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index a55d75f27..5afe87881 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -19,47 +19,12 @@ packages: original: hackage: fuzzyset-0.2.4 - completed: - hackage: hasql-1.6.4.4@sha256:a26b346aaf33b903f011f8c47a1a1230ea2b0aa1d8325aaf779da425d6c076c5,4391 + hackage: hasql-notifications-0.2.4.0@sha256:8e7a0076519a02dbcaa2b914fab37d3c0d6a44b9620fc0e16bc49f6e6eef2810,1998 pantry-tree: - sha256: 120edb520584aa107998b49a7809fa70a1ad4648a9cae26d3b031cfe15bce18e - size: 2607 - original: - hackage: hasql-1.6.4.4 -- completed: - hackage: hasql-dynamic-statements-0.3.1.5@sha256:2455a5fdd8cc6458a6fa66cbca8a01d25011e16c405e36b0c6d75fc39b15477f,2961 - pantry-tree: - sha256: f4fe881d367499a03290028180fdcb76be050807d1e13effeec6c78ab23b481a - size: 595 - original: - hackage: hasql-dynamic-statements-0.3.1.5 -- completed: - hackage: hasql-implicits-0.1.1.3@sha256:7a46264113765b0080de33560b22e13d4dfe811ce20e9e805fe600f30a0d418a,1334 - pantry-tree: - sha256: 51278386de1d497546c1b1baabefaf16a63c30cb00dd8f1e8a9dc74291db9aac - size: 264 - original: - hackage: hasql-implicits-0.1.1.3 -- completed: - hackage: hasql-notifications-0.2.2.2@sha256:d1d6bc0d3ee5e418fc12ea023b78739e0decba6c34e2b43bec55b89e18bd4412,2025 - pantry-tree: - sha256: 83a9cbb179b1efd0b2acd6509583c7afcdbe63469ab033d8581d48d675a80b44 + sha256: 65a1d22d3fcf908824f312e98549b6f3cae91e1aaea67db16f5c51a9b5e7ec31 size: 452 original: - hackage: hasql-notifications-0.2.2.2 -- completed: - hackage: hasql-pool-1.0.1@sha256:3cfb4c7153a6c536ac7e126c17723e6d26ee03794954deed2d72bcc826d05a40,2302 - pantry-tree: - sha256: d98e1269bdd60989b0eb0b84e1d5357eaa9f92821439d9f206663b7251ee95b2 - size: 799 - original: - hackage: hasql-pool-1.0.1 -- completed: - hackage: hasql-transaction-1.1.0.1@sha256:ca451ad29d2195d9e59e9118ab1b210887fea15383fa175895bba711e92b1d00,3302 - pantry-tree: - sha256: b0435127264b8f40c11e0474d7c208f40278acd470fa2368ba2c6cda3a4f7ced - size: 1027 - original: - hackage: hasql-transaction-1.1.0.1 + hackage: hasql-notifications-0.2.4.0 - completed: hackage: http-semantics-0.4.0@sha256:da8a98d542b2032cc12590847179577b0208a52bb3b9aa9a07c08d27d2a1714c,1513 pantry-tree: @@ -75,26 +40,12 @@ packages: original: hackage: http2-5.4.0 - completed: - hackage: postgresql-binary-0.13.1.3@sha256:4de5ddc90d9d3e586c3edf2860280a0915a484e9b8de3f36316a4cab2b330852,4037 + hackage: warp-3.4.13@sha256:ccd1fb8765166ca31928635fffdab85569b7a0f2a81cc11c9a5b91eab663eda6,10066 pantry-tree: - sha256: a5e9a06511b2a6a5be2388a4874d3c62babcfe1165b876e425bcc819b0474cde - size: 1661 + sha256: dfe50280b7d9549f7eebedc35f62d633ecb185ba0d9686146bb39074c3055df5 + size: 4175 original: - hackage: postgresql-binary-0.13.1.3 -- completed: - hackage: text-builder-0.6.10@sha256:24e403038fb6b885c8a0f310e782d40ca80eb1b5359b90fbe74db98b84e1094b,2348 - pantry-tree: - sha256: 18cea18e1e6bfba7fe6ff36926bafa6963ef2ba3f20dcfe3f25e9afef5ca8bf8 - size: 515 - original: - hackage: text-builder-0.6.10 -- completed: - hackage: text-builder-dev-0.3.10@sha256:eb86d38ad19eb27ea5db1a9652330d6b0511bccc10a9fac43fedf8e65ba8b7f5,2973 - pantry-tree: - sha256: 136ef4106267630f4b43d6b35076e15a16c6c8d1790fa45cca20a2def4d6b404 - size: 736 - original: - hackage: text-builder-dev-0.3.10 + hackage: warp-3.4.13 snapshots: - completed: sha256: 655e468f774beee1badf07dc4c45fb50288d5c66ce7bef6f487b7f92891a90b0 diff --git a/test/observability/Main.hs b/test/observability/Main.hs index 416ed7055..217316122 100644 --- a/test/observability/Main.hs +++ b/test/observability/Main.hs @@ -8,7 +8,8 @@ import Data.Function (id) import PostgREST.App (postgrest) import qualified PostgREST.AppState as AppState -import PostgREST.Config (AppConfig (..)) +import PostgREST.Config (AppConfig (..), + toConnectionSettings) import PostgREST.Config.Database (queryPgVersion) import qualified PostgREST.Logger as Logger import qualified PostgREST.Metrics as Metrics @@ -38,12 +39,12 @@ main = do , P.acquisitionTimeout 10 , P.agingTimeout 60 , P.idlenessTimeout 60 - , P.staticConnectionSettings (toUtf8 $ configDbUri testCfg) + , P.staticConnectionSettings $ toConnectionSettings identity testCfg -- make sure metrics are updated and pool observations published to poolChan , P.observationHandler $ (writeChan poolChan <> Metrics.observationMetrics metricsState) . HasqlPoolObs ] - actualPgVersion <- either (panic . show) id <$> P.use pool (queryPgVersion False) + actualPgVersion <- either (panic . show) id <$> P.use pool queryPgVersion -- cached schema cache so most tests run fast baseSchemaCache <- loadSCache pool testCfg diff --git a/test/spec/Main.hs b/test/spec/Main.hs index d51f8b0aa..01b218cd1 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -9,7 +9,8 @@ import Data.Function (id) import Test.Hspec import PostgREST.App (postgrest) -import PostgREST.Config (AppConfig (..)) +import PostgREST.Config (AppConfig (..), + toConnectionSettings) import PostgREST.Config.Database (queryPgVersion) import PostgREST.SchemaCache (querySchemaCache) import Protolude hiding (toList, toS) @@ -78,10 +79,10 @@ main = do , P.acquisitionTimeout 10 , P.agingTimeout 60 , P.idlenessTimeout 60 - , P.staticConnectionSettings (toUtf8 $ configDbUri testCfg) + , P.staticConnectionSettings $ toConnectionSettings identity testCfg ] - actualPgVersion <- either (panic . show) id <$> P.use pool (queryPgVersion False) + actualPgVersion <- either (panic . show) id <$> P.use pool queryPgVersion -- cached schema cache so most tests run fast baseSchemaCache <- loadSCache pool testCfg