From d663421f6df1bfd069c99ab732b43d7e7cf2f347 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20K=C5=82eczek?= Date: Sun, 31 May 2026 08:47:00 +0200 Subject: [PATCH] refactor: simplify control flow in App.postgrest Currently, authentication and response execution each unwrap ExceptT with separate runExceptT calls, which split the main request flow across nested pattern matching and Either handling. Control flow is complex and difficult to understand. The goal of this change is to make request execution as sequential monadic code with clear error handling. To implement that, request handling is now run in ExceptT over WriterT (Last ByteString) IO monad stack. Auth role is written after authentication succeeds and further returned along the response. Thanks to it response observation generation is centralized at the end of request handling. It was necessary to abstract monad stack in getAuthResult, lookupJwtCache, postgrestResponse, and withTiming to enable introduction of WriterT. --- src/PostgREST/App.hs | 44 ++++++++++++++++------------------ src/PostgREST/Auth.hs | 14 ++++------- src/PostgREST/Auth/JwtCache.hs | 11 +++++---- 3 files changed, 32 insertions(+), 37 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index ac1be60eac..0103625733 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -9,6 +9,7 @@ Some of its functionality includes: - Producing HTTP Headers according to RFCs. - Content Negotiation -} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -61,6 +62,7 @@ import PostgREST.SchemaCache (SchemaCache (..)) import PostgREST.TimeIt (timeItT) import PostgREST.Version (docsVersion, prettyVersion) +import Control.Monad.Writer import qualified Data.ByteString.Char8 as BS import qualified Data.List as L import Data.Streaming.Network (bindPortTCP) @@ -127,24 +129,19 @@ postgrest appState connWorker = appConf@AppConfig{..} <- AppState.getConfig appState -- the config must be read again because it can reload maybeSchemaCache <- AppState.getSchemaCache appState - let observer = AppState.getObserver appState - bearerAuth = ApiRequest.userBearerAuth req + let handleError = fmap (either (Error.errorResponseFor configClientErrorVerbosity) identity) - response <- do - authResultE <- runExceptT $ withTiming appConf $ - liftIO (Auth.getAuthResult appState bearerAuth) >>= liftEither + -- writer to save authRole (uses `tell` for this and `getLast` to obtain it) + -- has to be before runExceptT to make sure role is not lost on error + (response, authRole) <- runWriterT . handleError . runExceptT $ do + (jwtTime, authResult@AuthResult{..}) <- withTiming appConf $ + Auth.getAuthResult appState $ ApiRequest.userBearerAuth req - case authResultE of - Left err -> do - let resp = Error.errorResponseFor configClientErrorVerbosity err - observer $ genResponseObs Nothing req resp - pure resp + tell $ pure authRole - Right (jwtTime, authResult@AuthResult{..}) -> do - resp <- either (Error.errorResponseFor configClientErrorVerbosity) identity <$> - runExceptT (postgrestResponse appState appConf maybeSchemaCache jwtTime authResult req) - observer $ genResponseObs (Just authRole) req resp - pure resp + postgrestResponse appState appConf maybeSchemaCache jwtTime authResult req + + AppState.getObserver appState $ genResponseObs (getLast authRole) req response -- Launch the connWorker when the connection is down. The postgrest -- function can respond successfully (with a stale schema cache) before @@ -164,13 +161,14 @@ postgrest appState connWorker = ResponseObs user req (Wai.responseStatus resp) (WaiHeader.contentLength $ Wai.responseHeaders resp) postgrestResponse - :: AppState.AppState + :: (MonadError Error m, MonadIO m) + => AppState.AppState -> AppConfig -> Maybe SchemaCache -> Maybe Double -> AuthResult -> Wai.Request - -> ExceptT Error IO Wai.Response + -> m Wai.Response postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jwtTime authResult@AuthResult{..} req = do let observer = AppState.getObserver appState @@ -179,12 +177,12 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jwtTime authResul Just sCache -> return sCache Nothing -> do - lift $ observer SchemaCacheEmptyObs + liftIO $ observer SchemaCacheEmptyObs throwError Error.NoSchemaCacheError let prefs = ApiRequest.userPreferences conf req (dbTimezones sCache) - body <- lift $ Wai.strictRequestBody req + body <- liftIO $ Wai.strictRequestBody req (parseTime, apiReq@ApiRequest{..}) <- withTiming conf $ liftEither . mapLeft Error.ApiRequestErr $ ApiRequest.userApiRequest conf prefs req body (planTime, plan) <- withTiming conf $ liftEither $ Plan.actionPlan iAction conf apiReq sCache @@ -197,13 +195,13 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jwtTime authResul case tx of MainTx.NoDbTx r -> pure r MainTx.DbTx dbSession -> do - dbRes <- lift $ AppState.usePool appState dbSession + dbRes <- liftIO $ AppState.usePool appState dbSession let eitherResp = join $ mapLeft (Error.PgErr . Error.PgError (Just authRole /= configDbAnonRole)) dbRes -- TODO: we use obsQuery twice, one here and one below because in case of an error with the usePool above, the request will finish here and return an error message. -- This is because of a combination of ExceptT + our Error module which has Wai.responseLBS. -- This needs refactoring so only the below obsQuery is used. - lift $ whenLeft eitherResp $ obsQuery . Error.status + liftIO $ whenLeft eitherResp $ obsQuery . Error.status liftEither eitherResp (respTime, resp) <- withTiming conf $ do @@ -211,7 +209,7 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jwtTime authResul status' = either Error.status Response.pgrstStatus response -- TODO: see above obsQuery, only this obsQuery should remain after refactoring (because the QueryObs depends on the status) - lift $ obsQuery status' + liftIO $ obsQuery status' liftEither response return $ toWaiResponse (ServerTiming jwtTime parseTime planTime txTime respTime) resp @@ -230,7 +228,7 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jwtTime authResul varyHeaderPresent :: [HTTP.Header] -> Bool varyHeaderPresent = any (\(h, _v) -> h == HTTP.hVary) -withTiming :: AppConfig -> ExceptT e IO a -> ExceptT e IO (Maybe Double, a) +withTiming :: (MonadError e m, MonadIO m) => AppConfig -> m a -> m (Maybe Double, a) withTiming AppConfig{configServerTimingEnabled} f = if configServerTimingEnabled then do (t, r) <- timeItT f diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 114512d108..9d332c2826 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -10,6 +10,7 @@ Authentication should always be implemented in an external service. In the test suite there is an example of simple login function that can be used for a very simple authentication system inside the PostgreSQL database. -} +{-# LANGUAGE FlexibleContexts #-} module PostgREST.Auth ( getAuthResult ) where @@ -25,14 +26,9 @@ import Protolude -- | Perform authentication and authorization -- Parse JWT and return AuthResult -getAuthResult :: AppState -> Maybe ByteString -> IO (Either Error AuthResult) +getAuthResult :: (MonadError Error m, MonadIO m) => AppState -> Maybe ByteString -> m AuthResult getAuthResult appState token = do - conf <- getConfig appState - time <- getTime appState + conf <- liftIO $ getConfig appState + time <- liftIO $ getTime appState - let jwtCacheState = getJwtCacheState appState - parseJwt = runExceptT $ do - claims <- lookupJwtCache jwtCacheState token - parseClaims conf time claims - - parseJwt + parseClaims conf time =<< lookupJwtCache (getJwtCacheState appState) token diff --git a/src/PostgREST/Auth/JwtCache.hs b/src/PostgREST/Auth/JwtCache.hs index 395ecd48d4..389043adde 100644 --- a/src/PostgREST/Auth/JwtCache.hs +++ b/src/PostgREST/Auth/JwtCache.hs @@ -5,6 +5,7 @@ Description : PostgREST JWT validation results Cache. This module provides functions to deal with the JWT cache. -} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -42,7 +43,7 @@ import Protolude data JwtCacheState = JwtCacheState ObservationHandler (IORef JwtCache) class CacheVariant m v where - cached :: SC.Cache m ByteString v -> ByteString -> ExceptT Error IO JSON.Object + cached :: (MonadError Error n, MonadIO n) => SC.Cache m ByteString v -> ByteString -> n JSON.Object {-| Jwt caching can have three different configurations: @@ -60,12 +61,12 @@ data JwtCache = forall m v. CacheVariant m v => JwtCache JwkSet (TVar Int) (SC.Cache m ByteString v) instance CacheVariant IO (Either Error JSON.Object) where - cached c = lift . SC.cached c >=> liftEither + cached c = liftIO . SC.cached c >=> liftEither instance CacheVariant (ExceptT Error IO) JSON.Object where - cached = SC.cached + cached c = liftIO . runExceptT . SC.cached c >=> liftEither -decode :: JwtCache -> ByteString -> ExceptT Error IO JSON.Object +decode :: (MonadError Error m, MonadIO m) => JwtCache -> ByteString -> m JSON.Object decode JwtNoJwks = const $ throwError (JwtErr JwtSecretMissing) decode (JwtNoCache key) = parseAndDecodeClaims key decode (JwtCache _ _ c) = cached c @@ -110,5 +111,5 @@ newJwtCache AppConfig{configJWKS, configJwtCacheMaxEntries} observationHandler = (const . const $ lift $ observationHandler JwtCacheEviction) -- evictions metrics alwaysValid) -- no invalidation for now -lookupJwtCache :: JwtCacheState -> Maybe ByteString -> ExceptT Error IO JSON.Object +lookupJwtCache :: (MonadError Error m, MonadIO m) => JwtCacheState -> Maybe ByteString -> m JSON.Object lookupJwtCache (JwtCacheState _ cacheState) k = liftIO (readIORef cacheState) >>= flip (maybe (pure KM.empty)) k . decode