Clean AppEnv and AppContext passing, remove RunT, reduce ServerConfigCtx uses

## Description

This PR does several different things that happen to overlap; the most important being:
- it removes `RunT`: it was redundant in places where we already had `Handler`, and only used in one other place, `SchemaUpdate`, for which a local `SchemaUpdateT` is more than enough;
- it reduces the number of places where we create a `ServerConfigCtx`, since now `HasServerConfigCtx` can be implemented directly by `SchemaUpdateT` and `Handler` based on the full `AppContext`;
- it drastically reduces the number of arguments we pass around in the app init code, by introducing `HasAppEnv`;
- it simplifies `HandlerCtx` to reduce duplication

In doing so, this changes paves the way towards removing `ServerConfigCtx`, since there are only very few places where we construct it: we can now introduce smaller classes than `HasServerConfigCtx`, that expose only a relevant subset of fields, and implement them where we now implement `HasServerConfigCtx`.

This PR is loosely based on ideas in #8337, that are no longer applicable due to the changes introduced in #8159. A challenge of this PR was the postgres tests, which were running in `PGMetadataStorageAppT CacheBuild` 🙀

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/8392
GitOrigin-RevId: b90c1359066d20dbea329c87762ccdd1217b4d69

server/graphql-engine.cabal

@@ -731,7 +731,6 @@ library
                      , Hasura.GraphQL.Logging.QueryLog
                      , Hasura.GraphQL.Logging.ExecutionLog
                      , Hasura.RQL.DML.Select
-                     , Hasura.RQL.Types.Run
                      , Hasura.Session
 
                      , Hasura.Server.API.Config

server/src-lib/Hasura/App.hs

@@ -294,6 +294,9 @@ newtype PGMetadataStorageAppT m a = PGMetadataStorageAppT (ReaderT AppEnv (Trace
       MonadBaseControl b
     )
 
+instance Monad m => HasAppEnv (PGMetadataStorageAppT m) where
+  askAppEnv = ask
+
 instance (MonadIO m, MonadBaseControl IO m) => MonadTrace (PGMetadataStorageAppT m) where
   newTraceWith c p n (PGMetadataStorageAppT a) = PGMetadataStorageAppT $ newTraceWith c p n a
   newSpanWith i n (PGMetadataStorageAppT a) = PGMetadataStorageAppT $ newSpanWith i n a
@@ -306,9 +309,6 @@ instance MonadTrans PGMetadataStorageAppT where
 instance Monad m => ProvidesNetwork (PGMetadataStorageAppT m) where
   askHTTPManager = asks appEnvManager
 
-instance HasServerConfigCtx m => HasServerConfigCtx (PGMetadataStorageAppT m) where
-  askServerConfigCtx = lift askServerConfigCtx
-
 runPGMetadataStorageAppT :: AppEnv -> PGMetadataStorageAppT m a -> m a
 runPGMetadataStorageAppT c (PGMetadataStorageAppT a) = ignoreTraceT $ runReaderT a c
 
@@ -595,6 +595,7 @@ runHGEServer ::
     LA.Forall (LA.Pure m),
     UserAuthentication m,
     HttpLog m,
+    HasAppEnv m,
     ConsoleRenderer m,
     MonadVersionAPIWithExtraData m,
     MonadMetadataApiAuthorization m,
@@ -687,6 +688,7 @@ mkHGEServer ::
     LA.Forall (LA.Pure m),
     UserAuthentication m,
     HttpLog m,
+    HasAppEnv m,
     ConsoleRenderer m,
     MonadVersionAPIWithExtraData m,
     MonadMetadataApiAuthorization m,
@@ -757,18 +759,7 @@ mkHGEServer setupHook appStateRef appEnv@AppEnv {..} ekgStore = do
   newLogTVar <- liftIO $ STM.newTVarIO False
 
   -- Start a background thread for processing schema sync event present in the '_sscSyncEventRef'
-  _ <-
+  _ <- startSchemaSyncProcessorThread appStateRef newLogTVar
-    startSchemaSyncProcessorThread
-      logger
-      appEnvManager
-      appEnvMetaVersionRef
-      appStateRef
-      appEnvInstanceId
-      appEnvEnableMaintenanceMode
-      appEnvEventingMode
-      appEnvEnableReadOnlyMode
-      newLogTVar
-      appEnvCheckFeatureFlag
 
   case appEnvEventingMode of
     EventingEnabled -> do

server/src-lib/Hasura/App/State.hs

@@ -1,10 +1,16 @@
 {-# LANGUAGE Arrows #-}
 
 module Hasura.App.State
-  ( RebuildableAppContext (..),
+  ( -- * application state
+    RebuildableAppContext (..),
     AppEnv (..),
     AppContext (..),
     Loggers (..),
+
+    -- * env access
+    HasAppEnv (..),
+
+    -- * init functions
     buildRebuildableAppContext,
     initSQLGenCtx,
   )
@@ -44,6 +50,9 @@ import Network.Wai.Handler.Warp (HostPreference)
 import Network.WebSockets.Connection qualified as WebSockets
 import Refined (NonNegative, Refined)
 
+--------------------------------------------------------------------------------
+-- application state
+
 {- Note [Hasura Application State]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Hasura Application state represents the entire state of hasura.
@@ -151,6 +160,35 @@ data Loggers = Loggers
 
 data InvalidationKeys = InvalidationKeys
 
+--------------------------------------------------------------------------------
+-- env access
+
+-- | Provides access to the 'AppEnv'.
+--
+-- This class is nothing more than an equivalent of @MonadReader AppEnv m@, but
+-- it abstracts it, so that application code can be written without explicitly
+-- relying on an explicit implementation of the app monad. It allows for the app
+-- env to be passed implicitly instead of explictly in all of the app init code.
+--
+-- This class is not meant to be used across the entirety of the codebase, as
+-- using it brings in scope the types of all fields, creating dependencies
+-- between unrelated parts of the codebase. It is only meant to be used at the
+-- top level; more specific parts of the code should only rely on the relevant
+-- subset of the environment, exposed by small, local typeclasses. For instance,
+-- at time of writing, this can be used to implement 'HasServerConfigCtx', as a
+-- first step towards breaking it down.
+class Monad m => HasAppEnv m where
+  askAppEnv :: m AppEnv
+
+instance (HasAppEnv m) => HasAppEnv (ReaderT r m) where
+  askAppEnv = lift askAppEnv
+
+instance (HasAppEnv m) => HasAppEnv (ExceptT e m) where
+  askAppEnv = lift askAppEnv
+
+--------------------------------------------------------------------------------
+-- init functions
+
 initInvalidationKeys :: InvalidationKeys
 initInvalidationKeys = InvalidationKeys
 

server/src-lib/Hasura/GraphQL/Execute/Backend.hs

@@ -40,7 +40,6 @@ import Hasura.RQL.Types.Column (ColumnType, fromCol)
 import Hasura.RQL.Types.Common
 import Hasura.RQL.Types.QueryTags (QueryTagsConfig)
 import Hasura.RQL.Types.ResultCustomization
-import Hasura.RQL.Types.Run (RunT (..))
 import Hasura.RQL.Types.SchemaCache.Build (MetadataT (..))
 import Hasura.RemoteSchema.SchemaCache
 import Hasura.SQL.AnyBackend qualified as AB
@@ -330,6 +329,7 @@ data ExecutionStep where
 -- this will need to be changed into an annotated tree.
 type ExecutionPlan = RootFieldMap ExecutionStep
 
+-- TODO: move this to a new module.
 class (Monad m) => MonadQueryTags m where
   -- | Creates Query Tags. These are appended to the Generated SQL.
   -- Helps users to use native database monitoring tools to get some 'application-context'.
@@ -353,6 +353,3 @@ instance (MonadQueryTags m) => MonadQueryTags (MetadataT m) where
 
 instance (MonadQueryTags m) => MonadQueryTags (CacheRWT m) where
   createQueryTags qtSourceConfig attr = retag (createQueryTags @m qtSourceConfig attr) :: Tagged (CacheRWT m) QueryTagsComment
-
-instance (MonadQueryTags m) => MonadQueryTags (RunT m) where
-  createQueryTags qtSourceConfig attr = retag (createQueryTags @m qtSourceConfig attr) :: Tagged (RunT m) QueryTagsComment

server/src-lib/Hasura/RQL/Types/Run.hs

@@ -1,57 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-
-module Hasura.RQL.Types.Run
-  ( RunT (..),
-    RunCtx (..),
-    peelRun,
-  )
-where
-
-import Control.Monad.Trans
-import Control.Monad.Trans.Control (MonadBaseControl)
-import Hasura.Metadata.Class
-import Hasura.Prelude
-import Hasura.RQL.DDL.ApiLimit (MonadGetApiTimeLimit (..))
-import Hasura.RQL.DDL.EventTrigger (MonadEventLogCleanup (..))
-import Hasura.RQL.Types.Source
-import Hasura.Server.Types
-import Hasura.Services
-import Hasura.Session
-import Hasura.Tracing qualified as Tracing
-
-data RunCtx = RunCtx
-  { _rcUserInfo :: UserInfo,
-    _rcServerConfigCtx :: ServerConfigCtx
-  }
-
-newtype RunT m a = RunT {unRunT :: RunCtx -> m a}
-  deriving
-    ( Functor,
-      Applicative,
-      Monad,
-      MonadError e,
-      MonadIO,
-      Tracing.MonadTrace,
-      MonadBase b,
-      MonadBaseControl b,
-      MonadMetadataStorage,
-      MonadMetadataStorageQueryAPI,
-      ProvidesNetwork,
-      MonadResolveSource,
-      MonadEventLogCleanup,
-      MonadGetApiTimeLimit
-    )
-    via (ReaderT RunCtx m)
-  deriving (MonadTrans) via (ReaderT RunCtx)
-
-instance (Monad m) => UserInfoM (RunT m) where
-  askUserInfo = RunT $ pure . _rcUserInfo
-
-instance (Monad m) => HasServerConfigCtx (RunT m) where
-  askServerConfigCtx = RunT $ pure . _rcServerConfigCtx
-
-peelRun ::
-  RunCtx ->
-  RunT m a ->
-  m a
-peelRun = flip unRunT

server/src-lib/Hasura/Server/API/Metadata.hs

@@ -18,6 +18,7 @@ import Data.Has (Has)
 import Data.Text qualified as T
 import Data.Text.Extended qualified as T
 import GHC.Generics.Extended (constrName)
+import Hasura.App.State
 import Hasura.Base.Error
 import Hasura.EncJSON
 import Hasura.Logging qualified as L
@@ -66,7 +67,6 @@ import Hasura.RQL.Types.OpenTelemetry
 import Hasura.RQL.Types.Permission
 import Hasura.RQL.Types.QueryCollection
 import Hasura.RQL.Types.Roles
-import Hasura.RQL.Types.Run
 import Hasura.RQL.Types.ScheduledTrigger
 import Hasura.RQL.Types.SchemaCache
 import Hasura.RQL.Types.SchemaCache.Build
@@ -381,22 +381,23 @@ runMetadataQuery ::
   ( MonadIO m,
     MonadError QErr m,
     MonadBaseControl IO m,
+    HasAppEnv m,
     Tracing.MonadTrace m,
     MonadMetadataStorageQueryAPI m,
     MonadResolveSource m,
     MonadEventLogCleanup m,
     ProvidesHasuraServices m,
-    MonadGetApiTimeLimit m
+    MonadGetApiTimeLimit m,
+    UserInfoM m,
+    HasServerConfigCtx m
   ) =>
-  Env.Environment ->
+  AppContext ->
-  L.Logger L.Hasura ->
-  InstanceId ->
-  UserInfo ->
-  ServerConfigCtx ->
   RebuildableSchemaCache ->
   RQLMetadata ->
   m (EncJSON, RebuildableSchemaCache)
-runMetadataQuery env logger instanceId userInfo serverConfigCtx schemaCache RQLMetadata {..} = do
+runMetadataQuery appContext schemaCache RQLMetadata {..} = do
+  AppEnv {..} <- askAppEnv
+  let logger = _lsLogger appEnvLoggers
   (metadata, currentResourceVersion) <- Tracing.newSpan "fetchMetadata" $ liftEitherM fetchMetadata
   let exportsMetadata = \case
         RMV1 (RMExportMetadata _) -> True
@@ -420,16 +421,16 @@ runMetadataQuery env logger instanceId userInfo serverConfigCtx schemaCache RQLM
         --
         if (exportsMetadata _rqlMetadata || queryModifiesMetadata _rqlMetadata)
           then emptyMetadataDefaults
-          else _sccMetadataDefaults serverConfigCtx
+          else acMetadataDefaults appContext
   ((r, modMetadata), modSchemaCache, cacheInvalidations) <-
-    runMetadataQueryM env currentResourceVersion _rqlMetadata
+    runMetadataQueryM (acEnvironment appContext) currentResourceVersion _rqlMetadata
+      -- TODO: remove this straight runReaderT that provides no actual new info
       & flip runReaderT logger
       & runMetadataT metadata metadataDefaults
       & runCacheRWT schemaCache
-      & peelRun (RunCtx userInfo serverConfigCtx)
   -- set modified metadata in storage
   if queryModifiesMetadata _rqlMetadata
-    then case (_sccMaintenanceMode serverConfigCtx, _sccReadOnlyMode serverConfigCtx) of
+    then case (appEnvEnableMaintenanceMode, appEnvEnableReadOnlyMode) of
       (MaintenanceModeDisabled, ReadOnlyModeDisabled) -> do
         -- set modified metadata in storage
         L.unLogger logger $
@@ -448,7 +449,7 @@ runMetadataQuery env logger instanceId userInfo serverConfigCtx schemaCache RQLM
         -- notify schema cache sync
         Tracing.newSpan "notifySchemaCacheSync" $
           liftEitherM $
-            notifySchemaCacheSync newResourceVersion instanceId cacheInvalidations
+            notifySchemaCacheSync newResourceVersion appEnvInstanceId cacheInvalidations
         L.unLogger logger $
           SchemaSyncLog L.LevelInfo TTMetadataApi $
             String $
@@ -458,7 +459,6 @@ runMetadataQuery env logger instanceId userInfo serverConfigCtx schemaCache RQLM
           Tracing.newSpan "setMetadataResourceVersionInSchemaCache" $
             setMetadataResourceVersionInSchemaCache newResourceVersion
               & runCacheRWT modSchemaCache
-              & peelRun (RunCtx userInfo serverConfigCtx)
 
         pure (r, modSchemaCache')
       (MaintenanceModeEnabled (), ReadOnlyModeDisabled) ->

server/src-lib/Hasura/Server/API/Query.hs

@@ -15,6 +15,7 @@ import Data.Aeson.Casing
 import Data.Aeson.TH
 import Data.Environment qualified as Env
 import Data.Has (Has)
+import Hasura.App.State
 import Hasura.Backends.Postgres.DDL.RunSQL
 import Hasura.Base.Error
 import Hasura.EncJSON
@@ -49,7 +50,6 @@ import Hasura.RQL.Types.Endpoint
 import Hasura.RQL.Types.Metadata
 import Hasura.RQL.Types.Permission
 import Hasura.RQL.Types.QueryCollection
-import Hasura.RQL.Types.Run
 import Hasura.RQL.Types.ScheduledTrigger
 import Hasura.RQL.Types.SchemaCache.Build
 import Hasura.RQL.Types.Source
@@ -177,6 +177,7 @@ $( concat
 runQuery ::
   ( MonadIO m,
     MonadError QErr m,
+    HasAppEnv m,
     Tracing.MonadTrace m,
     MonadBaseControl IO m,
     MonadMetadataStorageQueryAPI m,
@@ -184,18 +185,18 @@ runQuery ::
     MonadQueryTags m,
     MonadEventLogCleanup m,
     ProvidesHasuraServices m,
-    MonadGetApiTimeLimit m
+    MonadGetApiTimeLimit m,
+    UserInfoM m,
+    HasServerConfigCtx m
   ) =>
-  Env.Environment ->
+  AppContext ->
-  L.Logger L.Hasura ->
-  InstanceId ->
-  UserInfo ->
   RebuildableSchemaCache ->
-  ServerConfigCtx ->
   RQLQuery ->
   m (EncJSON, RebuildableSchemaCache)
-runQuery env logger instanceId userInfo sc serverConfigCtx query = do
+runQuery appContext sc query = do
-  when ((_sccReadOnlyMode serverConfigCtx == ReadOnlyModeEnabled) && queryModifiesUserDB query) $
+  AppEnv {..} <- askAppEnv
+  let logger = _lsLogger appEnvLoggers
+  when ((appEnvEnableReadOnlyMode == ReadOnlyModeEnabled) && queryModifiesUserDB query) $
     throw400 NotSupported "Cannot run write queries when read-only mode is enabled"
 
   let exportsMetadata = \case
@@ -204,32 +205,25 @@ runQuery env logger instanceId userInfo sc serverConfigCtx query = do
       metadataDefaults =
         if (exportsMetadata query)
           then emptyMetadataDefaults
-          else _sccMetadataDefaults serverConfigCtx
+          else acMetadataDefaults appContext
 
   (metadata, currentResourceVersion) <- liftEitherM fetchMetadata
-  result <-
+  ((result, updatedMetadata), updatedCache, invalidations) <-
-    runReaderT (runQueryM env query) logger & \x -> do
+    runQueryM (acEnvironment appContext) query
-      ((js, meta), rsc, ci) <-
+      -- TODO: remove this straight runReaderT that provides no actual new info
-        x
+      & flip runReaderT logger
-          & runMetadataT metadata metadataDefaults
+      & runMetadataT metadata metadataDefaults
-          & runCacheRWT sc
+      & runCacheRWT sc
-          & peelRun runCtx
+  when (queryModifiesSchemaCache query) $ do
-      pure (js, rsc, ci, meta)
+    case appEnvEnableMaintenanceMode of
-  withReload currentResourceVersion result
+      MaintenanceModeDisabled -> do
-  where
+        -- set modified metadata in storage
-    runCtx = RunCtx userInfo serverConfigCtx
+        newResourceVersion <- liftEitherM $ setMetadata currentResourceVersion updatedMetadata
-
+        -- notify schema cache sync
-    withReload currentResourceVersion (result, updatedCache, invalidations, updatedMetadata) = do
+        liftEitherM $ notifySchemaCacheSync newResourceVersion appEnvInstanceId invalidations
-      when (queryModifiesSchemaCache query) $ do
+      MaintenanceModeEnabled () ->
-        case (_sccMaintenanceMode serverConfigCtx) of
+        throw500 "metadata cannot be modified in maintenance mode"
-          MaintenanceModeDisabled -> do
+  pure (result, updatedCache)
-            -- set modified metadata in storage
-            newResourceVersion <- liftEitherM $ setMetadata currentResourceVersion updatedMetadata
-            -- notify schema cache sync
-            liftEitherM $ notifySchemaCacheSync newResourceVersion instanceId invalidations
-          MaintenanceModeEnabled () ->
-            throw500 "metadata cannot be modified in maintenance mode"
-      pure (result, updatedCache)
 
 -- | A predicate that determines whether the given query might modify/rebuild the schema cache. If
 -- so, it needs to acquire the global lock on the schema cache so that other queries do not modify

server/src-lib/Hasura/Server/API/V2Query.hs

@@ -16,6 +16,7 @@ import Data.Aeson.Types (Parser)
 import Data.Environment qualified as Env
 import Data.Text qualified as T
 import GHC.Generics.Extended (constrName)
+import Hasura.App.State
 import Hasura.Backends.BigQuery.DDL.RunSQL qualified as BigQuery
 import Hasura.Backends.DataConnector.Adapter.RunSQL qualified as DataConnector
 import Hasura.Backends.DataConnector.Adapter.Types (DataConnectorName, mkDataConnectorName)
@@ -41,7 +42,6 @@ import Hasura.RQL.DML.Types
   )
 import Hasura.RQL.DML.Update
 import Hasura.RQL.Types.Metadata
-import Hasura.RQL.Types.Run
 import Hasura.RQL.Types.SchemaCache.Build
 import Hasura.RQL.Types.Source
 import Hasura.SQL.Backend
@@ -105,53 +105,45 @@ runQuery ::
   ( MonadIO m,
     MonadBaseControl IO m,
     MonadError QErr m,
+    HasAppEnv m,
     Tracing.MonadTrace m,
     MonadMetadataStorage m,
     MonadResolveSource m,
     MonadQueryTags m,
-    ProvidesHasuraServices m
+    ProvidesHasuraServices m,
+    UserInfoM m,
+    HasServerConfigCtx m
   ) =>
-  Env.Environment ->
+  AppContext ->
-  InstanceId ->
-  UserInfo ->
   RebuildableSchemaCache ->
-  ServerConfigCtx ->
   RQLQuery ->
   m (EncJSON, RebuildableSchemaCache)
-runQuery env instanceId userInfo schemaCache serverConfigCtx rqlQuery = do
+runQuery appContext schemaCache rqlQuery = do
-  when ((_sccReadOnlyMode serverConfigCtx == ReadOnlyModeEnabled) && queryModifiesUserDB rqlQuery) $
+  AppEnv {..} <- askAppEnv
+  when ((appEnvEnableReadOnlyMode == ReadOnlyModeEnabled) && queryModifiesUserDB rqlQuery) $
     throw400 NotSupported "Cannot run write queries when read-only mode is enabled"
 
   (metadata, currentResourceVersion) <- Tracing.newSpan "fetchMetadata" $ liftEitherM fetchMetadata
-  result <-
+  ((result, updatedMetadata), updatedCache, invalidations) <-
-    runQueryM env rqlQuery & \x -> do
+    runQueryM (acEnvironment appContext) rqlQuery
-      ((js, meta), rsc, ci) <-
+      -- We can use defaults here unconditionally, since there is no MD export function in V2Query
-        -- We can use defaults here unconditionally, since there is no MD export function in V2Query
+      & runMetadataT metadata (acMetadataDefaults appContext)
-        x
+      & runCacheRWT schemaCache
-          & runMetadataT metadata (_sccMetadataDefaults serverConfigCtx)
+  when (queryModifiesSchema rqlQuery) $ do
-          & runCacheRWT schemaCache
+    case appEnvEnableMaintenanceMode of
-          & peelRun runCtx
+      MaintenanceModeDisabled -> do
-      pure (js, rsc, ci, meta)
+        -- set modified metadata in storage
-  withReload currentResourceVersion result
+        newResourceVersion <-
-  where
+          Tracing.newSpan "setMetadata" $
-    runCtx = RunCtx userInfo serverConfigCtx
+            liftEitherM $
-
+              setMetadata currentResourceVersion updatedMetadata
-    withReload currentResourceVersion (result, updatedCache, invalidations, updatedMetadata) = do
+        -- notify schema cache sync
-      when (queryModifiesSchema rqlQuery) $ do
+        Tracing.newSpan "notifySchemaCacheSync" $
-        case _sccMaintenanceMode serverConfigCtx of
+          liftEitherM $
-          MaintenanceModeDisabled -> do
+            notifySchemaCacheSync newResourceVersion appEnvInstanceId invalidations
-            -- set modified metadata in storage
+      MaintenanceModeEnabled () ->
-            newResourceVersion <-
+        throw500 "metadata cannot be modified in maintenance mode"
-              Tracing.newSpan "setMetadata" $
+  pure (result, updatedCache)
-                liftEitherM $
-                  setMetadata currentResourceVersion updatedMetadata
-            -- notify schema cache sync
-            Tracing.newSpan "notifySchemaCacheSync" $
-              liftEitherM $
-                notifySchemaCacheSync newResourceVersion instanceId invalidations
-          MaintenanceModeEnabled () ->
-            throw500 "metadata cannot be modified in maintenance mode"
-      pure (result, updatedCache)
 
 queryModifiesSchema :: RQLQuery -> Bool
 queryModifiesSchema = \case

server/src-lib/Hasura/Server/App.hs

@@ -6,7 +6,7 @@ module Hasura.Server.App
     ConsoleRenderer (..),
     MonadVersionAPIWithExtraData (..),
     Handler,
-    HandlerCtx (hcReqHeaders, hcAppContext, hcSchemaCache, hcAppEnv, hcUser),
+    HandlerCtx (hcReqHeaders, hcAppContext, hcSchemaCache, hcUser),
     HasuraApp (HasuraApp),
     Loggers (..),
     MonadConfigApiHandler (..),
@@ -113,14 +113,13 @@ import Web.Spock.Core ((<//>))
 import Web.Spock.Core qualified as Spock
 
 data HandlerCtx = HandlerCtx
-  { hcAppContext :: !AppContext,
+  { hcAppContext :: AppContext,
-    hcSchemaCache :: !RebuildableSchemaCache,
+    hcSchemaCache :: RebuildableSchemaCache,
-    hcSchemaCacheVersion :: !SchemaCacheVer,
+    hcSchemaCacheVersion :: SchemaCacheVer,
-    hcAppEnv :: !AppEnv,
+    hcUser :: UserInfo,
-    hcUser :: !UserInfo,
+    hcReqHeaders :: [HTTP.Header],
-    hcReqHeaders :: ![HTTP.Header],
+    hcRequestId :: RequestId,
-    hcRequestId :: !RequestId,
+    hcSourceIpAddress :: Wai.IpAddress
-    hcSourceIpAddress :: !Wai.IpAddress
   }
 
 newtype Handler m a = Handler (ReaderT HandlerCtx (ExceptT QErr m) a)
@@ -135,9 +134,9 @@ newtype Handler m a = Handler (ReaderT HandlerCtx (ExceptT QErr m) a)
       MonadReader HandlerCtx,
       MonadError QErr,
       MonadTrace,
+      HasAppEnv,
       HasResourceLimits,
       MonadResolveSource,
-      HasServerConfigCtx,
       E.MonadGQLExecutionCheck,
       MonadEventLogCleanup,
       MonadQueryLog,
@@ -154,6 +153,28 @@ newtype Handler m a = Handler (ReaderT HandlerCtx (ExceptT QErr m) a)
 instance MonadTrans Handler where
   lift = Handler . lift . lift
 
+instance Monad m => UserInfoM (Handler m) where
+  askUserInfo = asks hcUser
+
+instance (HasAppEnv m) => HasServerConfigCtx (Handler m) where
+  askServerConfigCtx = Handler do
+    AppEnv {..} <- askAppEnv
+    AppContext {..} <- asks hcAppContext
+    pure
+      ServerConfigCtx
+        { _sccFunctionPermsCtx = acFunctionPermsCtx,
+          _sccRemoteSchemaPermsCtx = acRemoteSchemaPermsCtx,
+          _sccSQLGenCtx = acSQLGenCtx,
+          _sccMaintenanceMode = appEnvEnableMaintenanceMode,
+          _sccExperimentalFeatures = acExperimentalFeatures,
+          _sccEventingMode = appEnvEventingMode,
+          _sccReadOnlyMode = appEnvEnableReadOnlyMode,
+          _sccDefaultNamingConvention = acDefaultNamingConvention,
+          _sccMetadataDefaults = acMetadataDefaults,
+          _sccCheckFeatureFlag = appEnvCheckFeatureFlag,
+          _sccApolloFederationStatus = acApolloFederationStatus
+        }
+
 runHandler :: (HasResourceLimits m, MonadBaseControl IO m) => HandlerCtx -> Handler m a -> m (Either QErr a)
 runHandler ctx (Handler r) = do
   handlerLimit <- askHTTPHandlerLimit
@@ -268,6 +289,7 @@ mkSpockAction ::
   forall m a impl.
   ( MonadIO m,
     MonadBaseControl IO m,
+    HasAppEnv m,
     FromJSON a,
     UserAuthentication m,
     HttpLog m,
@@ -275,20 +297,20 @@ mkSpockAction ::
     MonadTrace m
   ) =>
   AppStateRef impl ->
-  AppEnv ->
   -- | `QErr` JSON encoder function
   (Bool -> QErr -> Value) ->
   -- | `QErr` modifier
   (QErr -> QErr) ->
   APIHandler m a ->
   Spock.ActionT m ()
-mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler = do
+mkSpockAction appStateRef qErrEncoder qErrModifier apiHandler = do
+  AppEnv {..} <- lift askAppEnv
+  AppContext {..} <- liftIO $ getAppContext appStateRef
   req <- Spock.request
   let origHeaders = Wai.requestHeaders req
       ipAddress = Wai.getSourceFromFallback req
       pathInfo = Wai.rawPathInfo req
 
-  AppContext {..} <- liftIO $ getAppContext appStateRef
   -- Bytes are actually read from the socket here. Time this.
   (ioWaitTime, reqBody) <- withElapsedTime $ liftIO $ Wai.strictRequestBody req
 
@@ -330,7 +352,7 @@ mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler
         pure
           ( userInfo,
             authHeaders,
-            HandlerCtx appContext schemaCache schemaCacheVer appEnv userInfo headers requestId ipAddress,
+            HandlerCtx appContext schemaCache schemaCacheVer userInfo headers requestId ipAddress,
             shouldIncludeInternal (_uiRole userInfo) acResponseInternalErrorsConfig,
             extraUserInfo
           )
@@ -378,8 +400,7 @@ mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler
         logSuccessAndResp (Just userInfo) requestId req (reqBody, queryJSON) res (Just (ioWaitTime, serviceTime)) origHeaders authHeaders httpLogMetadata
   where
     logErrorAndResp ::
-      forall n a3 ctx.
+      forall any ctx.
-      (MonadIO n, HttpLog n) =>
       Maybe UserInfo ->
       RequestId ->
       Wai.Request ->
@@ -388,9 +409,10 @@ mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler
       [HTTP.Header] ->
       ExtraUserInfo ->
       QErr ->
-      Spock.ActionCtxT ctx n a3
+      Spock.ActionCtxT ctx m any
     logErrorAndResp userInfo reqId waiReq req includeInternal headers extraUserInfo qErr = do
-      let httpLogMetadata = buildHttpLogMetadata @n emptyHttpLogGraphQLInfo extraUserInfo
+      AppEnv {..} <- lift askAppEnv
+      let httpLogMetadata = buildHttpLogMetadata @m emptyHttpLogGraphQLInfo extraUserInfo
           jsonResponse = J.encode $ qErrEncoder includeInternal qErr
           contentLength = ("Content-Length", B8.toStrict $ BB.toLazyByteString $ BB.int64Dec $ BL.length jsonResponse)
           allHeaders = [contentLength, jsonHeader]
@@ -400,6 +422,7 @@ mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler
       Spock.lazyBytes jsonResponse
 
     logSuccessAndResp userInfo reqId waiReq req result qTime reqHeaders authHdrs httpLoggingMetadata = do
+      AppEnv {..} <- lift askAppEnv
       let (respBytes, respHeaders) = case result of
             JSONResp (HttpResponse encJson h) -> (encJToLBS encJson, pure jsonHeader <> h)
             RawResp (HttpResponse rawBytes h) -> (rawBytes, h)
@@ -431,49 +454,29 @@ v1QueryHandler ::
     MonadReader HandlerCtx m,
     MonadMetadataStorageQueryAPI m,
     MonadResolveSource m,
+    HasAppEnv m,
     EB.MonadQueryTags m,
     MonadEventLogCleanup m,
     ProvidesNetwork m,
-    MonadGetApiTimeLimit m
+    MonadGetApiTimeLimit m,
+    UserInfoM m,
+    HasServerConfigCtx m
   ) =>
   AppStateRef impl ->
   RQLQuery ->
   m (HttpResponse EncJSON)
 v1QueryHandler appStateRef query = do
   (liftEitherM . authorizeV1QueryApi query) =<< ask
-  logger <- asks (_lsLogger . appEnvLoggers . hcAppEnv)
+  logger <- _lsLogger . appEnvLoggers <$> askAppEnv
-  res <- bool (fst <$> (action logger)) (withSchemaCacheUpdate appStateRef logger Nothing (action logger)) $ queryModifiesSchemaCache query
+  res <- bool (fst <$> action) (withSchemaCacheUpdate appStateRef logger Nothing action) $ queryModifiesSchemaCache query
   return $ HttpResponse res []
   where
-    action logger = do
+    action = do
-      userInfo <- asks hcUser
+      appContext <- asks hcAppContext
-      AppContext {..} <- asks hcAppContext
       schemaCache <- asks hcSchemaCache
-      instanceId <- asks (appEnvInstanceId . hcAppEnv)
-      maintenanceMode <- asks (appEnvEnableMaintenanceMode . hcAppEnv)
-      eventingMode <- asks (appEnvEventingMode . hcAppEnv)
-      readOnlyMode <- asks (appEnvEnableReadOnlyMode . hcAppEnv)
-      checkFeatureFlag <- asks (appEnvCheckFeatureFlag . hcAppEnv)
-      let serverConfigCtx =
-            ServerConfigCtx
-              acFunctionPermsCtx
-              acRemoteSchemaPermsCtx
-              acSQLGenCtx
-              maintenanceMode
-              acExperimentalFeatures
-              eventingMode
-              readOnlyMode
-              acDefaultNamingConvention
-              acMetadataDefaults
-              checkFeatureFlag
-              acApolloFederationStatus
       runQuery
-        acEnvironment
+        appContext
-        logger
-        instanceId
-        userInfo
         schemaCache
-        serverConfigCtx
         query
 
 -- | See Note [Explicitly passing AppStateRef]
@@ -487,47 +490,27 @@ v1MetadataHandler ::
     MonadResolveSource m,
     MonadMetadataApiAuthorization m,
     MonadEventLogCleanup m,
+    HasAppEnv m,
     ProvidesNetwork m,
-    MonadGetApiTimeLimit m
+    MonadGetApiTimeLimit m,
+    UserInfoM m,
+    HasServerConfigCtx m
   ) =>
   AppStateRef impl ->
   RQLMetadata ->
   m (HttpResponse EncJSON)
 v1MetadataHandler appStateRef query = Tracing.newSpan "Metadata" $ do
   (liftEitherM . authorizeV1MetadataApi query) =<< ask
-  userInfo <- asks hcUser
+  logger <- _lsLogger . appEnvLoggers <$> askAppEnv
-  AppContext {..} <- asks hcAppContext
+  appContext <- asks hcAppContext
   schemaCache <- asks hcSchemaCache
-  instanceId <- asks (appEnvInstanceId . hcAppEnv)
-  logger <- asks (_lsLogger . appEnvLoggers . hcAppEnv)
-  maintenanceMode <- asks (appEnvEnableMaintenanceMode . hcAppEnv)
-  eventingMode <- asks (appEnvEventingMode . hcAppEnv)
-  readOnlyMode <- asks (appEnvEnableReadOnlyMode . hcAppEnv)
-  checkFeatureFlag <- asks (appEnvCheckFeatureFlag . hcAppEnv)
-  let serverConfigCtx =
-        ServerConfigCtx
-          acFunctionPermsCtx
-          acRemoteSchemaPermsCtx
-          acSQLGenCtx
-          maintenanceMode
-          acExperimentalFeatures
-          eventingMode
-          readOnlyMode
-          acDefaultNamingConvention
-          acMetadataDefaults
-          checkFeatureFlag
-          acApolloFederationStatus
   r <-
     withSchemaCacheUpdate
       appStateRef
       logger
       Nothing
       $ runMetadataQuery
-        acEnvironment
+        appContext
-        logger
-        instanceId
-        userInfo
-        serverConfigCtx
         schemaCache
         query
   pure $ HttpResponse r []
@@ -541,15 +524,18 @@ v2QueryHandler ::
     MonadReader HandlerCtx m,
     MonadMetadataStorage m,
     MonadResolveSource m,
+    HasAppEnv m,
     EB.MonadQueryTags m,
-    ProvidesNetwork m
+    ProvidesNetwork m,
+    UserInfoM m,
+    HasServerConfigCtx m
   ) =>
   AppStateRef impl ->
   V2Q.RQLQuery ->
   m (HttpResponse EncJSON)
 v2QueryHandler appStateRef query = Tracing.newSpan "v2 Query" $ do
   (liftEitherM . authorizeV2QueryApi query) =<< ask
-  logger <- asks (_lsLogger . appEnvLoggers . hcAppEnv)
+  logger <- _lsLogger . appEnvLoggers <$> askAppEnv
   res <-
     bool (fst <$> dbAction) (withSchemaCacheUpdate appStateRef logger Nothing dbAction) $
       V2Q.queryModifiesSchema query
@@ -557,29 +543,12 @@ v2QueryHandler appStateRef query = Tracing.newSpan "v2 Query" $ do
   where
     -- Hit postgres
     dbAction = do
-      userInfo <- asks hcUser
-      AppContext {..} <- asks hcAppContext
       schemaCache <- asks hcSchemaCache
-      instanceId <- asks (appEnvInstanceId . hcAppEnv)
+      appContext <- asks hcAppContext
-      maintenanceMode <- asks (appEnvEnableMaintenanceMode . hcAppEnv)
+      V2Q.runQuery
-      eventingMode <- asks (appEnvEventingMode . hcAppEnv)
+        appContext
-      readOnlyMode <- asks (appEnvEnableReadOnlyMode . hcAppEnv)
+        schemaCache
-      checkFeatureFlag <- asks (appEnvCheckFeatureFlag . hcAppEnv)
+        query
-      let serverConfigCtx =
-            ServerConfigCtx
-              acFunctionPermsCtx
-              acRemoteSchemaPermsCtx
-              acSQLGenCtx
-              maintenanceMode
-              acExperimentalFeatures
-              eventingMode
-              readOnlyMode
-              acDefaultNamingConvention
-              acMetadataDefaults
-              checkFeatureFlag
-              acApolloFederationStatus
-
-      V2Q.runQuery acEnvironment instanceId userInfo schemaCache serverConfigCtx query
 
 v1Alpha1GQHandler ::
   ( MonadIO m,
@@ -588,6 +557,7 @@ v1Alpha1GQHandler ::
     MonadQueryLog m,
     MonadExecutionLog m,
     MonadTrace m,
+    HasAppEnv m,
     GH.MonadExecuteQuery m,
     MonadError QErr m,
     MonadReader HandlerCtx m,
@@ -600,9 +570,9 @@ v1Alpha1GQHandler ::
   GH.GQLBatchedReqs (GH.GQLReq GH.GQLQueryText) ->
   m (HttpLogGraphQLInfo, HttpResponse EncJSON)
 v1Alpha1GQHandler queryType query = do
-  userInfo <- asks hcUser
+  appEnv <- askAppEnv
   appCtx@AppContext {..} <- asks hcAppContext
-  appEnv <- asks hcAppEnv
+  userInfo <- asks hcUser
   schemaCache <- asks hcSchemaCache
   schemaCacheVer <- asks hcSchemaCacheVersion
   reqHeaders <- asks hcReqHeaders
@@ -638,6 +608,7 @@ v1GQHandler ::
     MonadQueryLog m,
     MonadExecutionLog m,
     MonadTrace m,
+    HasAppEnv m,
     GH.MonadExecuteQuery m,
     MonadError QErr m,
     MonadReader HandlerCtx m,
@@ -657,6 +628,7 @@ v1GQRelayHandler ::
     MonadQueryLog m,
     MonadExecutionLog m,
     MonadTrace m,
+    HasAppEnv m,
     GH.MonadExecuteQuery m,
     MonadError QErr m,
     MonadReader HandlerCtx m,
@@ -755,6 +727,7 @@ configApiGetHandler ::
   forall m impl.
   ( MonadIO m,
     MonadBaseControl IO m,
+    HasAppEnv m,
     UserAuthentication m,
     HttpLog m,
     HasResourceLimits m,
@@ -763,10 +736,10 @@ configApiGetHandler ::
   AppStateRef impl ->
   AppEnv ->
   Spock.SpockCtxT () m ()
-configApiGetHandler appStateRef appEnv = do
+configApiGetHandler appStateRef AppEnv {..} = do
   AppContext {..} <- liftIO $ getAppContext appStateRef
   Spock.get "v1alpha1/config" $
-    mkSpockAction appStateRef appEnv encodeQErr id $
+    mkSpockAction appStateRef encodeQErr id $
       mkGetHandler $ do
         onlyAdmin
         let res =
@@ -777,7 +750,7 @@ configApiGetHandler appStateRef appEnv = do
                 acEnableAllowlist
                 acLiveQueryOptions
                 acStreamQueryOptions
-                (appEnvConsoleAssetsDir appEnv)
+                appEnvConsoleAssetsDir
                 acExperimentalFeatures
                 acEnabledAPIs
                 acDefaultNamingConvention
@@ -798,6 +771,7 @@ mkWaiApp ::
     ConsoleRenderer m,
     MonadVersionAPIWithExtraData m,
     HttpLog m,
+    HasAppEnv m,
     UserAuthentication m,
     MonadMetadataApiAuthorization m,
     E.MonadGQLExecutionCheck m,
@@ -849,6 +823,7 @@ httpApp ::
     ConsoleRenderer m,
     MonadVersionAPIWithExtraData m,
     HttpLog m,
+    HasAppEnv m,
     UserAuthentication m,
     MonadMetadataApiAuthorization m,
     E.MonadGQLExecutionCheck m,
@@ -932,25 +907,11 @@ httpApp setupHook appStateRef appEnv@AppEnv {..} ekgStore = do
     Spock.lazyBytes $ encode $ object $ ["version" .= currentVersion] <> extraData
 
   let customEndpointHandler ::
-        forall n.
-        ( MonadIO n,
-          MonadBaseControl IO n,
-          E.MonadGQLExecutionCheck n,
-          MonadQueryLog n,
-          MonadExecutionLog n,
-          GH.MonadExecuteQuery n,
-          MonadMetadataStorage n,
-          EB.MonadQueryTags n,
-          HasResourceLimits n,
-          ProvidesNetwork n,
-          MonadTrace n
-        ) =>
         RestRequest Spock.SpockMethod ->
-        Handler n (HttpLogGraphQLInfo, APIResp)
+        Handler m (HttpLogGraphQLInfo, APIResp)
       customEndpointHandler restReq = do
         endpoints <- liftIO $ scEndpoints <$> getSchemaCache appStateRef
         appCtx' <- asks hcAppContext
-        appEnv' <- asks hcAppEnv
         schemaCache <- asks hcSchemaCache
         schemaCacheVer <- asks hcSchemaCacheVersion
         requestId <- asks hcRequestId
@@ -958,7 +919,7 @@ httpApp setupHook appStateRef appEnv@AppEnv {..} ekgStore = do
         reqHeaders <- asks hcReqHeaders
         ipAddress <- asks hcSourceIpAddress
 
-        let execCtx = mkExecutionContext appCtx' appEnv' schemaCache schemaCacheVer
+        let execCtx = mkExecutionContext appCtx' appEnv schemaCache schemaCacheVer
 
         req <-
           restReq & traverse \case
@@ -1113,20 +1074,13 @@ httpApp setupHook appStateRef appEnv@AppEnv {..} ekgStore = do
         logHttpError logger appEnvLoggingSettings Nothing reqId req (reqBody, Nothing) err headers (emptyHttpLogMetadata @m)
 
     spockAction ::
-      forall a n.
+      forall a.
-      ( FromJSON a,
+      (FromJSON a) =>
-        MonadIO n,
-        MonadBaseControl IO n,
-        UserAuthentication n,
-        HttpLog n,
-        MonadTrace n,
-        HasResourceLimits n
-      ) =>
       (Bool -> QErr -> Value) ->
       (QErr -> QErr) ->
-      APIHandler n a ->
+      APIHandler m a ->
-      Spock.ActionT n ()
+      Spock.ActionT m ()
-    spockAction qErrEncoder qErrModifier apiHandler = mkSpockAction appStateRef appEnv qErrEncoder qErrModifier apiHandler
+    spockAction qErrEncoder qErrModifier apiHandler = mkSpockAction appStateRef qErrEncoder qErrModifier apiHandler
 
     -- all graphql errors should be of type 200
     allMod200 qe = qe {qeStatus = HTTP.status200}

server/src-lib/Hasura/Server/SchemaUpdate.hs

@@ -27,7 +27,6 @@ import Hasura.Metadata.Class
 import Hasura.Prelude
 import Hasura.RQL.DDL.Schema (runCacheRWT)
 import Hasura.RQL.DDL.Schema.Catalog
-import Hasura.RQL.Types.Run
 import Hasura.RQL.Types.SchemaCache
 import Hasura.RQL.Types.SchemaCache.Build
 import Hasura.RQL.Types.Source
@@ -39,12 +38,10 @@ import Hasura.Server.AppStateRef
     readSchemaCacheRef,
     withSchemaCacheUpdate,
   )
-import Hasura.Server.Init (FeatureFlag)
 import Hasura.Server.Logging
 import Hasura.Server.Types
 import Hasura.Services
 import Hasura.Session
-import Network.HTTP.Client qualified as HTTP
 import Refined (NonNegative, Refined, unrefine)
 
 data ThreadError
@@ -141,38 +138,23 @@ startSchemaSyncListenerThread logger pool instanceId interval metaVersionRef = d
 -- See Note [Schema Cache Sync]
 startSchemaSyncProcessorThread ::
   ( C.ForkableMonadIO m,
+    HasAppEnv m,
     MonadMetadataStorage m,
     MonadResolveSource m,
     ProvidesNetwork m
   ) =>
-  Logger Hasura ->
-  HTTP.Manager ->
-  STM.TMVar MetadataResourceVersion ->
   AppStateRef impl ->
-  InstanceId ->
-  (MaintenanceMode ()) ->
-  EventingMode ->
-  ReadOnlyMode ->
   STM.TVar Bool ->
-  (FeatureFlag -> IO Bool) ->
   ManagedT m Immortal.Thread
-startSchemaSyncProcessorThread
+startSchemaSyncProcessorThread appStateRef logTVar = do
-  logger
+  AppEnv {..} <- lift askAppEnv
-  httpMgr
+  let logger = _lsLogger appEnvLoggers
-  schemaSyncEventRef
+  -- Start processor thread
-  appStateRef
+  processorThread <-
-  instanceId
+    C.forkManagedT "SchemeUpdate.processor" logger $
-  maintenanceMode
+      processor appEnvMetadataVersionRef appStateRef logTVar
-  eventingMode
+  logThreadStarted logger appEnvInstanceId TTProcessor processorThread
-  readOnlyMode
+  pure processorThread
-  logTVar
-  checkFeatureFlag = do
-    -- Start processor thread
-    processorThread <-
-      C.forkManagedT "SchemeUpdate.processor" logger $
-        processor logger httpMgr schemaSyncEventRef appStateRef instanceId maintenanceMode eventingMode readOnlyMode logTVar checkFeatureFlag
-    logThreadStarted logger instanceId TTProcessor processorThread
-    pure processorThread
 
 -- TODO: This is also defined in multitenant, consider putting it in a library somewhere
 forcePut :: STM.TMVar a -> a -> IO ()
@@ -261,76 +243,85 @@ listener logger pool metaVersionRef interval = L.iterateM_ listenerLoop defaultE
 processor ::
   forall m void impl.
   ( C.ForkableMonadIO m,
+    HasAppEnv m,
     MonadMetadataStorage m,
     MonadResolveSource m,
     ProvidesNetwork m
   ) =>
-  Logger Hasura ->
-  HTTP.Manager ->
   STM.TMVar MetadataResourceVersion ->
   AppStateRef impl ->
-  InstanceId ->
-  (MaintenanceMode ()) ->
-  EventingMode ->
-  ReadOnlyMode ->
   STM.TVar Bool ->
-  (FeatureFlag -> IO Bool) ->
   m void
 processor
-  logger
-  _httpMgr
   metaVersionRef
   appStateRef
-  instanceId
+  logTVar = forever do
-  maintenanceMode
-  eventingMode
-  readOnlyMode
-  logTVar
-  checkFeatureFlag = forever $ do
     metaVersion <- liftIO $ STM.atomically $ STM.takeTMVar metaVersionRef
-    AppContext {..} <- liftIO $ getAppContext appStateRef
+    refreshSchemaCache metaVersion appStateRef TTProcessor logTVar
-    let serverConfigCtx =
+
-          ServerConfigCtx
+newtype SchemaUpdateT m a = SchemaUpdateT (AppContext -> m a)
-            acFunctionPermsCtx
+  deriving
-            acRemoteSchemaPermsCtx
+    ( Functor,
-            acSQLGenCtx
+      Applicative,
-            maintenanceMode
+      Monad,
-            acExperimentalFeatures
+      MonadError e,
-            eventingMode
+      MonadIO,
-            readOnlyMode
+      MonadMetadataStorage,
-            acDefaultNamingConvention
+      ProvidesNetwork,
-            acMetadataDefaults
+      MonadResolveSource
-            checkFeatureFlag
+    )
-            acApolloFederationStatus
+    via (ReaderT AppContext m)
-    refreshSchemaCache metaVersion instanceId logger appStateRef TTProcessor serverConfigCtx logTVar
+  deriving (MonadTrans) via (ReaderT AppContext)
+
+runSchemaUpdate :: AppContext -> SchemaUpdateT m a -> m a
+runSchemaUpdate appContext (SchemaUpdateT action) = action appContext
+
+instance (Monad m) => UserInfoM (SchemaUpdateT m) where
+  askUserInfo = pure adminUserInfo
+
+instance (HasAppEnv m) => HasServerConfigCtx (SchemaUpdateT m) where
+  askServerConfigCtx = SchemaUpdateT \AppContext {..} -> do
+    AppEnv {..} <- askAppEnv
+    pure
+      ServerConfigCtx
+        { _sccFunctionPermsCtx = acFunctionPermsCtx,
+          _sccRemoteSchemaPermsCtx = acRemoteSchemaPermsCtx,
+          _sccSQLGenCtx = acSQLGenCtx,
+          _sccMaintenanceMode = appEnvEnableMaintenanceMode,
+          _sccExperimentalFeatures = acExperimentalFeatures,
+          _sccEventingMode = appEnvEventingMode,
+          _sccReadOnlyMode = appEnvEnableReadOnlyMode,
+          _sccDefaultNamingConvention = acDefaultNamingConvention,
+          _sccMetadataDefaults = acMetadataDefaults,
+          _sccCheckFeatureFlag = appEnvCheckFeatureFlag,
+          _sccApolloFederationStatus = acApolloFederationStatus
+        }
 
 refreshSchemaCache ::
   ( MonadIO m,
     MonadBaseControl IO m,
+    HasAppEnv m,
     MonadMetadataStorage m,
     MonadResolveSource m,
     ProvidesNetwork m
   ) =>
   MetadataResourceVersion ->
-  InstanceId ->
-  Logger Hasura ->
   AppStateRef impl ->
   SchemaSyncThreadType ->
-  ServerConfigCtx ->
   STM.TVar Bool ->
   m ()
 refreshSchemaCache
   resourceVersion
-  instanceId
-  logger
   appStateRef
   threadType
-  serverConfigCtx
   logTVar = do
+    AppEnv {..} <- askAppEnv
+    let logger = _lsLogger appEnvLoggers
     respErr <- runExceptT $
       withSchemaCacheUpdate appStateRef logger (Just logTVar) $ do
         rebuildableCache <- liftIO $ fst <$> readSchemaCacheRef appStateRef
-        (msg, cache, _) <- peelRun runCtx $
+        appContext <- liftIO $ getAppContext appStateRef
+        (msg, cache, _) <- runSchemaUpdate appContext $
           runCacheRWT rebuildableCache $ do
             schemaCache <- askSchemaCache
             case scMetadataResourceVersion schemaCache of
@@ -360,7 +351,7 @@ refreshSchemaCache
                       "Fetched metadata with resource version "
                         <> tshow latestResourceVersion
 
-                  notifications <- liftEitherM $ fetchMetadataNotifications engineResourceVersion instanceId
+                  notifications <- liftEitherM $ fetchMetadataNotifications engineResourceVersion appEnvInstanceId
 
                   case notifications of
                     [] -> do
@@ -395,8 +386,6 @@ refreshSchemaCache
                       logInfo logger threadType $ object ["message" .= ("Schema Version changed with notifications" :: Text)]
         pure (msg, cache)
     onLeft respErr (logError logger threadType . TEQueryError)
-    where
-      runCtx = RunCtx adminUserInfo serverConfigCtx
 
 logInfo :: (MonadIO m) => Logger Hasura -> SchemaSyncThreadType -> Value -> m ()
 logInfo logger threadType val =
@@ -408,10 +397,3 @@ logError logger threadType err =
   unLogger logger $
     SchemaSyncLog LevelError threadType $
       object ["error" .= toJSON err]
-
--- Currently unused
-_logDebug :: (MonadIO m) => Logger Hasura -> SchemaSyncThreadType -> String -> m ()
-_logDebug logger threadType msg =
-  unLogger logger $
-    SchemaSyncLog LevelDebug threadType $
-      object ["message" .= msg]

server/test-postgres/Main.hs

@@ -131,25 +131,22 @@ main = do
           )
           $ \(appStateRef, appEnv) -> return (appStateRef, appEnv)
 
-        let run :: ExceptT QErr (PGMetadataStorageAppT CacheBuild) a -> IO a
+        let run :: ExceptT QErr (PGMetadataStorageAppT IO) a -> IO a
             run =
               runExceptT
                 >>> runPGMetadataStorageAppT appEnv
-                >>> runCacheBuild cacheBuildParams
+                >>> flip onLeftM printErrJExit
-                >>> runExceptT
-                >=> flip onLeft printErrJExit
-                >=> flip onLeft printErrJExit
 
         (metadata, schemaCache) <- run do
           metadata <-
             snd
               <$> (liftEitherM . runExceptT . _pecRunTx pgContext (PGExecCtxInfo (Tx PG.ReadWrite Nothing) InternalRawQuery))
                 (migrateCatalog (Just sourceConfig) defaultPostgresExtensionsSchema maintenanceMode =<< liftIO getCurrentTime)
-          schemaCache <- lift $ lift $ buildRebuildableSchemaCache logger envMap metadata
+          schemaCache <- runCacheBuild cacheBuildParams $ buildRebuildableSchemaCache logger envMap metadata
           pure (metadata, schemaCache)
 
         cacheRef <- newMVar schemaCache
-        pure $ NT (run . flip MigrateSuite.runCacheRefT cacheRef . fmap fst . runMetadataT metadata emptyMetadataDefaults)
+        pure $ NT (run . flip MigrateSuite.runCacheRefT (serverConfigCtx, cacheRef) . fmap fst . runMetadataT metadata emptyMetadataDefaults)
 
   streamingSubscriptionSuite <- StreamingSubscriptionSuite.buildStreamingSubscriptionSuite
   eventTriggerLogCleanupSuite <- EventTriggerCleanupSuite.buildEventTriggerCleanupSuite

server/test-postgres/Test/Hasura/Server/MigrateSuite.hs

@@ -38,7 +38,7 @@ import Test.Hspec.Expectations.Lifted
 
 -- -- NOTE: downgrade test disabled for now (see #5273)
 
-newtype CacheRefT m a = CacheRefT {runCacheRefT :: MVar RebuildableSchemaCache -> m a}
+newtype CacheRefT m a = CacheRefT {runCacheRefT :: (ServerConfigCtx, MVar RebuildableSchemaCache) -> m a}
   deriving
     ( Functor,
       Applicative,
@@ -47,15 +47,19 @@ newtype CacheRefT m a = CacheRefT {runCacheRefT :: MVar RebuildableSchemaCache -
       MonadError e,
       MonadBase b,
       MonadBaseControl b,
+      MonadReader (ServerConfigCtx, MVar RebuildableSchemaCache),
       MonadTx,
       UserInfoM,
-      HasServerConfigCtx,
       MonadMetadataStorage,
       MonadMetadataStorageQueryAPI,
+      MonadResolveSource,
       ProvidesNetwork,
       MonadGetApiTimeLimit
     )
-    via (ReaderT (MVar RebuildableSchemaCache) m)
+    via (ReaderT (ServerConfigCtx, MVar RebuildableSchemaCache) m)
+
+instance Monad m => HasServerConfigCtx (CacheRefT m) where
+  askServerConfigCtx = asks fst
 
 instance MonadTrans CacheRefT where
   lift = CacheRefT . const
@@ -65,7 +69,7 @@ instance MFunctor CacheRefT where
 
 -- instance (MonadBase IO m) => TableCoreInfoRM 'Postgres (CacheRefT m)
 instance (MonadBase IO m) => CacheRM (CacheRefT m) where
-  askSchemaCache = CacheRefT (fmap lastBuiltSchemaCache . readMVar)
+  askSchemaCache = CacheRefT (fmap lastBuiltSchemaCache . readMVar . snd)
 
 instance (MonadEventLogCleanup m) => MonadEventLogCleanup (CacheRefT m) where
   runLogCleaner conf = lift $ runLogCleaner conf
@@ -77,18 +81,19 @@ instance
     MonadBaseControl IO m,
     MonadError QErr m,
     MonadResolveSource m,
-    HasServerConfigCtx m,
     ProvidesNetwork m
   ) =>
   CacheRWM (CacheRefT m)
   where
-  buildSchemaCacheWithOptions reason invalidations metadata =
+  buildSchemaCacheWithOptions reason invalidations metadata = do
-    CacheRefT $ flip modifyMVar \schemaCache -> do
+    scVar <- asks snd
+    modifyMVar scVar \schemaCache -> do
       ((), cache, _) <- runCacheRWT schemaCache (buildSchemaCacheWithOptions reason invalidations metadata)
       pure (cache, ())
 
-  setMetadataResourceVersionInSchemaCache resourceVersion =
+  setMetadataResourceVersionInSchemaCache resourceVersion = do
-    CacheRefT $ flip modifyMVar \schemaCache -> do
+    scVar <- asks snd
+    modifyMVar scVar \schemaCache -> do
       ((), cache, _) <- runCacheRWT schemaCache (setMetadataResourceVersionInSchemaCache resourceVersion)
       pure (cache, ())
 
@@ -106,7 +111,6 @@ suite ::
   ( MonadIO m,
     MonadError QErr m,
     MonadBaseControl IO m,
-    HasServerConfigCtx m,
     MonadResolveSource m,
     MonadMetadataStorageQueryAPI m,
     MonadEventLogCleanup m,
@@ -127,9 +131,9 @@ suite srcConfig pgExecCtx pgConnInfo = do
         (migrationResult, metadata) <- runTx' pgExecCtx $ migrateCatalog (Just srcConfig) (ExtensionsSchema "public") MaintenanceModeDisabled time
         (,migrationResult) <$> runCacheBuildM (buildRebuildableSchemaCache logger env metadata)
 
-      dropAndInit env time = lift $
+      dropAndInit env time = lift do
-        CacheRefT $ flip modifyMVar \_ ->
+        scVar <- asks snd
-          (runTx' pgExecCtx dropHdbCatalogSchema) *> (migrateCatalogAndBuildCache env time)
+        modifyMVar scVar $ const $ (runTx' pgExecCtx dropHdbCatalogSchema) *> (migrateCatalogAndBuildCache env time)
       downgradeTo v = runTx' pgExecCtx . downgradeCatalog (Just srcConfig) DowngradeOptions {dgoDryRun = False, dgoTargetVersion = v}
 
   describe "migrateCatalog" $ do
@@ -149,9 +153,9 @@ suite srcConfig pgExecCtx pgConnInfo = do
       secondDump `shouldBe` firstDump
 
     it "supports upgrades after downgrade to version 12" \(NT transact) -> do
-      let upgradeToLatest env time = lift $
+      let upgradeToLatest env time = lift do
-            CacheRefT $ flip modifyMVar \_ ->
+            scVar <- asks snd
-              migrateCatalogAndBuildCache env time
+            modifyMVar scVar $ const $ migrateCatalogAndBuildCache env time
       env <- Env.getEnvironment
       time <- getCurrentTime
       transact (dropAndInit env time) `shouldReturn` MRInitialized