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 <michal@kleczek.org>
This commit is contained in:
Wolfgang Walther
co-authored by
Michal Kleczek
Michal Kleczek
parent
f80122e12b
commit
a5cc457875
@@ -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
|
||||
{
|
||||
|
||||
+9
-9
@@ -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
|
||||
|
||||
+33
-27
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+23
-12
@@ -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
|
||||
|
||||
@@ -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 <prefix>jwt_aud = 'val'
|
||||
-- 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
|
||||
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
|
||||
|
||||
+10
-1
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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"
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 ","
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
+1
-9
@@ -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
|
||||
|
||||
+7
-56
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+4
-3
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user