Skip to content

Commit a5cc457

Browse files
wolfgangwalthermkleczek
wolfgangwalther
and
mkleczek
committed
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>
1 parent f80122e commit a5cc457

17 files changed

Lines changed: 146 additions & 184 deletions

File tree

‎nix/overlays/haskell-packages.nix‎

Lines changed: 0 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -49,17 +49,6 @@ let
4949
# Before upgrading fuzzyset to 0.3, check: https://github.com/PostgREST/postgrest/issues/3329
5050
fuzzyset = prev.fuzzyset_0_2_4;
5151

52-
# Downgrade hasql and related packages while we are still on GHC 9.4 for the static build.
53-
hasql = lib.dontCheck (lib.doJailbreak prev.hasql_1_6_4_4);
54-
hasql-dynamic-statements = lib.dontCheck prev.hasql-dynamic-statements_0_3_1_5;
55-
hasql-implicits = lib.dontCheck prev.hasql-implicits_0_1_1_3;
56-
hasql-notifications = lib.dontCheck prev.hasql-notifications_0_2_2_2;
57-
hasql-pool = lib.dontCheck prev.hasql-pool_1_0_1;
58-
hasql-transaction = lib.dontCheck prev.hasql-transaction_1_1_0_1;
59-
postgresql-binary = lib.dontCheck (lib.doJailbreak prev.postgresql-binary_0_13_1_3);
60-
text-builder = prev.text-builder_0_6_10;
61-
text-builder-dev = prev.text-builder-dev_0_3_10;
62-
6352
http2 =
6453
prev.callHackageDirect
6554
{
@@ -95,7 +84,6 @@ let
9584
sha256 = "sha256-jmr8kpeSPDkOhT0i9PhozZapX4nUs92cOX7POAGb7/M=";
9685
}
9786
{ });
98-
9987
};
10088
in
10189
{

‎postgrest.cabal‎

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -117,11 +117,11 @@ library
117117
, either >= 4.4.1 && < 5.1
118118
, extra >= 1.7.0 && < 2.0
119119
, fuzzyset >= 0.2.4 && < 0.3
120-
, hasql >= 1.6.1.1 && < 1.7
121-
, hasql-dynamic-statements >= 0.3.1 && < 0.4
122-
, hasql-notifications >= 0.2.2.2 && < 0.2.3
123-
, hasql-pool >= 1.0.1 && < 1.1
124-
, hasql-transaction >= 1.0.1 && < 1.2
120+
, hasql >= 1.9 && <= 1.9.3.1
121+
, hasql-dynamic-statements >= 0.3.1 && <= 0.3.1.8
122+
, hasql-notifications >= 0.2.4.0 && < 0.3
123+
, hasql-pool >= 1.1 && <= 1.3.0.4
124+
, hasql-transaction >= 1.0.1 && <= 1.2.1
125125
, http-client >= 0.7.19 && < 0.8
126126
, http-types >= 0.12.2 && < 0.13
127127
, insert-ordered-containers >= 0.2.2 && < 0.3
@@ -270,8 +270,8 @@ test-suite spec
270270
, bytestring >= 0.10.8 && < 0.13
271271
, case-insensitive >= 1.2 && < 1.3
272272
, containers >= 0.5.7 && < 0.8
273-
, hasql-pool >= 1.0.1 && < 1.1
274-
, hasql-transaction >= 1.0.1 && < 1.2
273+
, hasql-pool >= 1.0.1 && <= 1.3.0.4
274+
, hasql-transaction >= 1.0.1 && <= 1.2.1
275275
, heredoc >= 0.2 && < 0.3
276276
, hspec >= 2.3 && < 2.12
277277
, hspec-expectations >= 0.8.4 && < 0.9
@@ -314,8 +314,8 @@ test-suite observability
314314
build-depends: base >= 4.9 && < 4.22
315315
, base64-bytestring >= 1 && < 1.3
316316
, bytestring >= 0.10.8 && < 0.13
317-
, hasql-pool >= 1.0.1 && < 1.1
318-
, hasql-transaction >= 1.0.1 && < 1.2
317+
, hasql-pool >= 1.0.1 && <= 1.3.0.4
318+
, hasql-transaction >= 1.0.1 && <= 1.2.1
319319
, hspec >= 2.3 && < 2.12
320320
, hspec-expectations >= 0.8.4 && < 0.9
321321
, hspec-wai >= 0.10 && < 0.12

‎src/PostgREST/AppState.hs‎

Lines changed: 33 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -55,8 +55,8 @@ import Data.Time.Clock (UTCTime, getCurrentTime)
5555

5656
import PostgREST.Auth.JwtCache (JwtCacheState, update)
5757
import PostgREST.Config (AppConfig (..),
58-
addFallbackAppName,
59-
readAppConfig)
58+
readAppConfig,
59+
toConnectionSettings)
6060
import PostgREST.Config.Database (queryDbSettings,
6161
queryPgVersion,
6262
queryRoleSettings)
@@ -143,34 +143,47 @@ destroy :: AppState -> IO ()
143143
destroy = destroyPool
144144

145145
initPool :: AppConfig -> ObservationHandler -> IO SQL.Pool
146-
initPool AppConfig{..} observer = do
146+
initPool cfg@AppConfig{..} observer = do
147147
SQL.acquire $ SQL.settings
148148
[ SQL.size configDbPoolSize
149149
, SQL.acquisitionTimeout $ fromIntegral configDbPoolAcquisitionTimeout
150150
, SQL.agingTimeout $ fromIntegral configDbPoolMaxLifetime
151151
, SQL.idlenessTimeout $ fromIntegral configDbPoolMaxIdletime
152-
, SQL.staticConnectionSettings (toUtf8 $ addFallbackAppName prettyVersion configDbUri)
152+
, SQL.staticConnectionSettings $ toConnectionSettings identity cfg
153153
, SQL.observationHandler $ observer . HasqlPoolObs
154154
]
155155

156156
-- | Run an action with a database connection.
157157
usePool :: AppState -> SQL.Session a -> IO (Either SQL.UsageError a)
158158
usePool AppState{stateObserver=observer, stateMainThreadId=mainThreadId, ..} sess = do
159-
observer PoolRequest
159+
observer PoolRequest
160160

161-
res <- SQL.use statePool sess
161+
res <- SQL.use statePool sess
162162

163-
observer PoolRequestFullfilled
163+
observer PoolRequestFullfilled
164164

165-
whenLeft res (\case
166-
SQL.AcquisitionTimeoutUsageError ->
167-
observer PoolAcqTimeoutObs
168-
err@(SQL.ConnectionUsageError e) ->
169-
let failureMessage = BS.unpack $ fromMaybe mempty e in
170-
when (("FATAL: password authentication failed" `isInfixOf` failureMessage) || ("no password supplied" `isInfixOf` failureMessage)) $ do
171-
observer $ ExitDBFatalError ServerAuthError err
172-
killThread mainThreadId
173-
err@(SQL.SessionUsageError (SQL.QueryError tpl _ (SQL.ResultError resultErr))) -> do
165+
whenLeft res (\case
166+
SQL.AcquisitionTimeoutUsageError ->
167+
observer PoolAcqTimeoutObs
168+
err@(SQL.ConnectionUsageError e) ->
169+
let failureMessage = BS.unpack $ fromMaybe mempty e in
170+
when (("FATAL: password authentication failed" `isInfixOf` failureMessage) || ("no password supplied" `isInfixOf` failureMessage)) $ do
171+
observer $ ExitDBFatalError ServerAuthError err
172+
killThread mainThreadId
173+
err@(SQL.SessionUsageError (SQL.QueryError tpl _ (SQL.ResultError resultErr))) ->
174+
handleResultError err tpl resultErr
175+
err@(SQL.SessionUsageError (SQL.PipelineError (SQL.ResultError resultErr))) ->
176+
-- Passing the empty template will not work for schema cache queries, see TODO further below.
177+
handleResultError err mempty resultErr
178+
err@(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _))) ->
179+
-- An error on the client-side, usually indicates problems with connection
180+
observer $ QueryErrorCodeHighObs err
181+
SQL.SessionUsageError (SQL.PipelineError (SQL.ClientError _)) -> pure ()
182+
)
183+
184+
return res
185+
where
186+
handleResultError err tpl resultErr = do
174187
case resultErr of
175188
SQL.UnexpectedResult{} -> do
176189
observer $ ExitDBFatalError ServerPgrstBug err
@@ -203,12 +216,6 @@ usePool AppState{stateObserver=observer, stateMainThreadId=mainThreadId, ..} ses
203216
SQL.ServerError{} ->
204217
when (Error.status (Error.PgError False err) >= HTTP.status500) $
205218
observer $ QueryErrorCodeHighObs err
206-
err@(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _))) ->
207-
-- An error on the client-side, usually indicates problems with connection
208-
observer $ QueryErrorCodeHighObs err
209-
)
210-
211-
return res
212219

213220
-- | Flush the connection pool so that any future use of the pool will
214221
-- use connections freshly established after this call.
@@ -308,7 +315,7 @@ retryingSchemaCacheLoad appState@AppState{stateObserver=observer, stateMainThrea
308315
qPgVersion :: IO (Maybe PgVersion)
309316
qPgVersion = do
310317
AppConfig{..} <- getConfig appState
311-
pgVersion <- usePool appState (queryPgVersion False) -- No need to prepare the query here, as the connection might not be established
318+
pgVersion <- usePool appState queryPgVersion
312319
case pgVersion of
313320
Left e -> do
314321
observer $ QueryPgVersionError e
@@ -336,8 +343,7 @@ retryingSchemaCacheLoad appState@AppState{stateObserver=observer, stateMainThrea
336343
qSchemaCache = do
337344
conf@AppConfig{..} <- getConfig appState
338345
(resultTime, result) <-
339-
let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
340-
timeItT $ usePool appState (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
346+
timeItT $ usePool appState (SQL.transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
341347
case result of
342348
Left e -> do
343349
markSchemaCachePending appState
@@ -393,7 +399,7 @@ readInDbConfig startingUp appState@AppState{stateObserver=observer} = do
393399
pgVer <- getPgVersion appState
394400
dbSettings <-
395401
if configDbConfig conf then do
396-
qDbSettings <- usePool appState (queryDbSettings (quoteQi <$> configDbPreConfig conf) (configDbPreparedStatements conf))
402+
qDbSettings <- usePool appState (queryDbSettings (quoteQi <$> configDbPreConfig conf))
397403
case qDbSettings of
398404
Left e -> do
399405
observer $ ConfigReadErrorObs e
@@ -403,7 +409,7 @@ readInDbConfig startingUp appState@AppState{stateObserver=observer} = do
403409
pure mempty
404410
(roleSettings, roleIsolationLvl) <-
405411
if configDbConfig conf then do
406-
rSettings <- usePool appState (queryRoleSettings pgVer (configDbPreparedStatements conf))
412+
rSettings <- usePool appState (queryRoleSettings pgVer)
407413
case rSettings of
408414
Left e -> do
409415
observer $ QueryRoleSettingsErrorObs e

‎src/PostgREST/CLI.hs‎

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -62,9 +62,7 @@ dumpSchema :: AppState -> IO LBS.ByteString
6262
dumpSchema appState = do
6363
conf@AppConfig{..} <- AppState.getConfig appState
6464
result <-
65-
let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
66-
AppState.usePool appState
67-
(transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
65+
AppState.usePool appState (SQL.transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
6866
case result of
6967
Left e -> do
7068
let observer = AppState.getObserver appState

‎src/PostgREST/Config.hs‎

Lines changed: 23 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ Description : Manages PostgREST configuration type and parser.
99
{-# LANGUAGE MultiParamTypeClasses #-}
1010
{-# LANGUAGE RecordWildCards #-}
1111
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
12+
{-# LANGUAGE NamedFieldPuns #-}
1213

1314
module PostgREST.Config
1415
( AppConfig (..)
@@ -27,22 +28,25 @@ module PostgREST.Config
2728
, parseSecret
2829
, addFallbackAppName
2930
, addTargetSessionAttrs
31+
, toConnectionSettings
3032
, exampleConfigFile
3133
, audMatchesCfg
3234
, Verbosity (..)
3335
) where
3436

35-
import qualified Data.Aeson as JSON
36-
import qualified Data.ByteString as BS
37-
import qualified Data.ByteString.Base64 as B64
38-
import qualified Data.CaseInsensitive as CI
39-
import qualified Data.Configurator as C
40-
import qualified Data.Map.Strict as M
41-
import qualified Data.String as S
42-
import qualified Data.Text as T
43-
import qualified Data.Text.Encoding as T
44-
import qualified Jose.Jwa as JWT
45-
import qualified Jose.Jwk as JWT
37+
import qualified Data.Aeson as JSON
38+
import qualified Data.ByteString as BS
39+
import qualified Data.ByteString.Base64 as B64
40+
import qualified Data.CaseInsensitive as CI
41+
import qualified Data.Configurator as C
42+
import qualified Data.Map.Strict as M
43+
import qualified Data.String as S
44+
import qualified Data.Text as T
45+
import qualified Data.Text.Encoding as T
46+
import qualified Hasql.Connection.Setting as SQL
47+
import qualified Hasql.Connection.Setting.Connection as SQL
48+
import qualified Jose.Jwa as JWT
49+
import qualified Jose.Jwk as JWT
4650

4751
import Control.Monad (fail)
4852
import Data.Either.Combinators (mapLeft)
@@ -67,7 +71,8 @@ import PostgREST.Config.Proxy (Proxy (..),
6771
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
6872
toQi)
6973

70-
import Protolude hiding (Proxy, toList)
74+
import PostgREST.Version (prettyVersion)
75+
import Protolude hiding (Proxy, toList)
7176

7277
audMatchesCfg :: AppConfig -> Text -> Bool
7378
audMatchesCfg = maybe (const True) (==) . configJwtAudience
@@ -646,6 +651,12 @@ addFallbackAppName version dbUri = addConnStringOption dbUri "fallback_applicati
646651
addTargetSessionAttrs :: Text -> Text
647652
addTargetSessionAttrs dbUri = addConnStringOption dbUri "target_session_attrs" "read-write"
648653

654+
toConnectionSettings :: (Text -> Text) -> AppConfig -> [SQL.Setting]
655+
toConnectionSettings transformUri AppConfig{configDbUri, configDbPreparedStatements} =
656+
[ SQL.connection $ SQL.string $ transformUri . addFallbackAppName prettyVersion $ configDbUri
657+
, SQL.usePreparedStatements configDbPreparedStatements
658+
]
659+
649660
addConnStringOption :: Text -> Text -> Text -> Text
650661
addConnStringOption dbUri key val = dbUri <>
651662
case pgConnString dbUri of

‎src/PostgREST/Config/Database.hs‎

Lines changed: 8 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -72,8 +72,8 @@ dbSettingsNames =
7272
,"server_timing_enabled"
7373
]
7474

75-
queryPgVersion :: Bool -> Session PgVersion
76-
queryPgVersion prepared = statement mempty $ pgVersionStatement prepared
75+
queryPgVersion :: Session PgVersion
76+
queryPgVersion = statement mempty $ pgVersionStatement False
7777

7878
pgVersionStatement :: Bool -> SQL.Statement () PgVersion
7979
pgVersionStatement = SQL.Statement sql HE.noParams versionRow
@@ -92,10 +92,9 @@ pgVersionStatement = SQL.Statement sql HE.noParams versionRow
9292
--
9393
-- The example above will result in <prefix>jwt_aud = 'val'
9494
-- A setting on the database only will have no effect: ALTER DATABASE postgres SET <prefix>jwt_aud = 'xx'
95-
queryDbSettings :: Maybe Text -> Bool -> Session [(Text, Text)]
96-
queryDbSettings preConfFunc prepared =
97-
let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
98-
transaction SQL.ReadCommitted SQL.Read $ SQL.statement dbSettingsNames $ SQL.Statement sql (arrayParam HE.text) decodeSettings prepared
95+
queryDbSettings :: Maybe Text -> Session [(Text, Text)]
96+
queryDbSettings preConfFunc =
97+
SQL.transaction SQL.ReadCommitted SQL.Read $ SQL.statement dbSettingsNames $ SQL.Statement sql (arrayParam HE.text) decodeSettings True
9998
where
10099
sql = encodeUtf8 [trimming|
101100
WITH
@@ -133,10 +132,9 @@ queryDbSettings preConfFunc prepared =
133132
|]::Text
134133
decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
135134

136-
queryRoleSettings :: PgVersion -> Bool -> Session (RoleSettings, RoleIsolationLvl)
137-
queryRoleSettings pgVer prepared =
138-
let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
139-
transaction SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.Statement sql HE.noParams (processRows <$> rows) prepared
135+
queryRoleSettings :: PgVersion -> Session (RoleSettings, RoleIsolationLvl)
136+
queryRoleSettings pgVer =
137+
SQL.transaction SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.Statement sql HE.noParams (processRows <$> rows) True
140138
where
141139
sql = encodeUtf8 [trimming|
142140
with

‎src/PostgREST/Error.hs‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -471,18 +471,22 @@ instance ErrorBody PgError where
471471

472472
instance ErrorBody SQL.UsageError where
473473
code (SQL.ConnectionUsageError _) = "PGRST000"
474+
code (SQL.SessionUsageError (SQL.PipelineError e)) = code e
474475
code (SQL.SessionUsageError (SQL.QueryError _ _ e)) = code e
475476
code SQL.AcquisitionTimeoutUsageError = "PGRST003"
476477

477478
message (SQL.ConnectionUsageError _) = "Database connection error. Retrying the connection."
479+
message (SQL.SessionUsageError (SQL.PipelineError e)) = message e
478480
message (SQL.SessionUsageError (SQL.QueryError _ _ e)) = message e
479481
message SQL.AcquisitionTimeoutUsageError = "Timed out acquiring connection from connection pool."
480482

481483
details (SQL.ConnectionUsageError e) = JSON.String . T.decodeUtf8 <$> e
484+
details (SQL.SessionUsageError (SQL.PipelineError e)) = details e
482485
details (SQL.SessionUsageError (SQL.QueryError _ _ e)) = details e
483486
details SQL.AcquisitionTimeoutUsageError = Nothing
484487

485488
hint (SQL.ConnectionUsageError _) = Nothing
489+
hint (SQL.SessionUsageError (SQL.PipelineError e)) = hint e
486490
hint (SQL.SessionUsageError (SQL.QueryError _ _ e)) = hint e
487491
hint SQL.AcquisitionTimeoutUsageError = Nothing
488492

@@ -527,8 +531,13 @@ instance ErrorBody SQL.CommandError where
527531
pgErrorStatus :: Bool -> SQL.UsageError -> HTTP.Status
528532
pgErrorStatus _ (SQL.ConnectionUsageError _) = HTTP.status503
529533
pgErrorStatus _ SQL.AcquisitionTimeoutUsageError = HTTP.status504
534+
pgErrorStatus _ (SQL.SessionUsageError (SQL.PipelineError (SQL.ClientError _))) = HTTP.status503
530535
pgErrorStatus _ (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _))) = HTTP.status503
531-
pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError rError))) =
536+
pgErrorStatus authed (SQL.SessionUsageError (SQL.PipelineError (SQL.ResultError rError))) = mapSQLtoHTTP authed rError
537+
pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError rError))) = mapSQLtoHTTP authed rError
538+
539+
mapSQLtoHTTP :: Bool -> SQL.ResultError -> HTTP.Status
540+
mapSQLtoHTTP authed rError =
532541
case rError of
533542
(SQL.ServerError c m d _ _) ->
534543
case BS.unpack c of

‎src/PostgREST/Listener.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@ import qualified Hasql.Notifications as SQL
1111
import PostgREST.AppState (AppState, getConfig)
1212
import PostgREST.Config (AppConfig (..))
1313
import PostgREST.Observation (Observation (..))
14-
import PostgREST.Version (prettyVersion)
1514

1615
import qualified PostgREST.AppState as AppState
1716
import qualified PostgREST.Config as Config
@@ -37,7 +36,7 @@ runListener appState = do
3736
-- | This function never returns (but can throw) and return type enforces that.
3837
retryingListen :: AppState -> IO Void
3938
retryingListen appState = do
40-
AppConfig{..} <- AppState.getConfig appState
39+
cfg@AppConfig{..} <- AppState.getConfig appState
4140
let
4241
dbChannel = toS configDbChannel
4342
onError err = do
@@ -62,15 +61,16 @@ retryingListen appState = do
6261
-- Make sure we don't leak connections on errors
6362
bracket
6463
-- acquire connection
65-
(SQL.acquire $ toUtf8 (Config.addTargetSessionAttrs $ Config.addFallbackAppName prettyVersion configDbUri))
64+
(SQL.acquire $
65+
Config.toConnectionSettings Config.addTargetSessionAttrs cfg)
6666
-- release connection
6767
(`whenRight` releaseConnection) $
6868
-- use connection
6969
\case
7070
Right db -> do
7171
SQL.listen db $ SQL.toPgIdentifier dbChannel
7272
(pqHost, pqPort) <- SQL.withLibPQConnection db $ bisequence . (LibPQ.host &&& LibPQ.port)
73-
pgFullName <- SQL.run (queryPgVersion False) db >>= either throwIO (pure . pgvFullName)
73+
pgFullName <- SQL.run queryPgVersion db >>= either throwIO (pure . pgvFullName)
7474

7575
AppState.putIsListenerOn appState True
7676

0 commit comments

Comments
 (0)