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
This commit is contained in:
Antoine Leblanc 2023-03-21 10:44:21 +00:00 committed by hasura-bot
parent eba0a3fb33
commit 0a1628c0cc
12 changed files with 282 additions and 391 deletions

View File

@ -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

View File

@ -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
logger
appEnvManager
appEnvMetaVersionRef
appStateRef
appEnvInstanceId
appEnvEnableMaintenanceMode
appEnvEventingMode
appEnvEnableReadOnlyMode
newLogTVar
appEnvCheckFeatureFlag
_ <- startSchemaSyncProcessorThread appStateRef newLogTVar
case appEnvEventingMode of
EventingEnabled -> do

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ->
L.Logger L.Hasura ->
InstanceId ->
UserInfo ->
ServerConfigCtx ->
AppContext ->
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) ->

View File

@ -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 ->
L.Logger L.Hasura ->
InstanceId ->
UserInfo ->
AppContext ->
RebuildableSchemaCache ->
ServerConfigCtx ->
RQLQuery ->
m (EncJSON, RebuildableSchemaCache)
runQuery env logger instanceId userInfo sc serverConfigCtx query = do
when ((_sccReadOnlyMode serverConfigCtx == ReadOnlyModeEnabled) && queryModifiesUserDB query) $
runQuery appContext sc query = do
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 <-
runReaderT (runQueryM env query) logger & \x -> do
((js, meta), rsc, ci) <-
x
& runMetadataT metadata metadataDefaults
& runCacheRWT sc
& peelRun runCtx
pure (js, rsc, ci, meta)
withReload currentResourceVersion result
where
runCtx = RunCtx userInfo serverConfigCtx
withReload currentResourceVersion (result, updatedCache, invalidations, updatedMetadata) = do
when (queryModifiesSchemaCache query) $ do
case (_sccMaintenanceMode serverConfigCtx) of
MaintenanceModeDisabled -> do
-- 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)
((result, updatedMetadata), updatedCache, invalidations) <-
runQueryM (acEnvironment appContext) query
-- TODO: remove this straight runReaderT that provides no actual new info
& flip runReaderT logger
& runMetadataT metadata metadataDefaults
& runCacheRWT sc
when (queryModifiesSchemaCache query) $ do
case appEnvEnableMaintenanceMode of
MaintenanceModeDisabled -> do
-- set modified metadata in storage
newResourceVersion <- liftEitherM $ setMetadata currentResourceVersion updatedMetadata
-- notify schema cache sync
liftEitherM $ notifySchemaCacheSync newResourceVersion appEnvInstanceId 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

View File

@ -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 ->
InstanceId ->
UserInfo ->
AppContext ->
RebuildableSchemaCache ->
ServerConfigCtx ->
RQLQuery ->
m (EncJSON, RebuildableSchemaCache)
runQuery env instanceId userInfo schemaCache serverConfigCtx rqlQuery = do
when ((_sccReadOnlyMode serverConfigCtx == ReadOnlyModeEnabled) && queryModifiesUserDB rqlQuery) $
runQuery appContext schemaCache rqlQuery = do
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 <-
runQueryM env rqlQuery & \x -> do
((js, meta), rsc, ci) <-
-- We can use defaults here unconditionally, since there is no MD export function in V2Query
x
& runMetadataT metadata (_sccMetadataDefaults serverConfigCtx)
& runCacheRWT schemaCache
& peelRun runCtx
pure (js, rsc, ci, meta)
withReload currentResourceVersion result
where
runCtx = RunCtx userInfo serverConfigCtx
withReload currentResourceVersion (result, updatedCache, invalidations, updatedMetadata) = do
when (queryModifiesSchema rqlQuery) $ do
case _sccMaintenanceMode serverConfigCtx of
MaintenanceModeDisabled -> do
-- set modified metadata in storage
newResourceVersion <-
Tracing.newSpan "setMetadata" $
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)
((result, updatedMetadata), updatedCache, invalidations) <-
runQueryM (acEnvironment appContext) rqlQuery
-- We can use defaults here unconditionally, since there is no MD export function in V2Query
& runMetadataT metadata (acMetadataDefaults appContext)
& runCacheRWT schemaCache
when (queryModifiesSchema rqlQuery) $ do
case appEnvEnableMaintenanceMode of
MaintenanceModeDisabled -> do
-- set modified metadata in storage
newResourceVersion <-
Tracing.newSpan "setMetadata" $
liftEitherM $
setMetadata currentResourceVersion updatedMetadata
-- notify schema cache sync
Tracing.newSpan "notifySchemaCacheSync" $
liftEitherM $
notifySchemaCacheSync newResourceVersion appEnvInstanceId invalidations
MaintenanceModeEnabled () ->
throw500 "metadata cannot be modified in maintenance mode"
pure (result, updatedCache)
queryModifiesSchema :: RQLQuery -> Bool
queryModifiesSchema = \case

View File

@ -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,
hcSchemaCache :: !RebuildableSchemaCache,
hcSchemaCacheVersion :: !SchemaCacheVer,
hcAppEnv :: !AppEnv,
hcUser :: !UserInfo,
hcReqHeaders :: ![HTTP.Header],
hcRequestId :: !RequestId,
hcSourceIpAddress :: !Wai.IpAddress
{ hcAppContext :: AppContext,
hcSchemaCache :: RebuildableSchemaCache,
hcSchemaCacheVersion :: SchemaCacheVer,
hcUser :: UserInfo,
hcReqHeaders :: [HTTP.Header],
hcRequestId :: RequestId,
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.
(MonadIO n, HttpLog n) =>
forall any ctx.
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)
res <- bool (fst <$> (action logger)) (withSchemaCacheUpdate appStateRef logger Nothing (action logger)) $ queryModifiesSchemaCache query
logger <- _lsLogger . appEnvLoggers <$> askAppEnv
res <- bool (fst <$> action) (withSchemaCacheUpdate appStateRef logger Nothing action) $ queryModifiesSchemaCache query
return $ HttpResponse res []
where
action logger = do
userInfo <- asks hcUser
AppContext {..} <- asks hcAppContext
action = do
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
logger
instanceId
userInfo
appContext
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
AppContext {..} <- asks hcAppContext
logger <- _lsLogger . appEnvLoggers <$> askAppEnv
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
logger
instanceId
userInfo
serverConfigCtx
appContext
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)
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
V2Q.runQuery acEnvironment instanceId userInfo schemaCache serverConfigCtx query
appContext <- asks hcAppContext
V2Q.runQuery
appContext
schemaCache
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.
( FromJSON a,
MonadIO n,
MonadBaseControl IO n,
UserAuthentication n,
HttpLog n,
MonadTrace n,
HasResourceLimits n
) =>
forall a.
(FromJSON a) =>
(Bool -> QErr -> Value) ->
(QErr -> QErr) ->
APIHandler n a ->
Spock.ActionT n ()
spockAction qErrEncoder qErrModifier apiHandler = mkSpockAction appStateRef appEnv qErrEncoder qErrModifier apiHandler
APIHandler m a ->
Spock.ActionT m ()
spockAction qErrEncoder qErrModifier apiHandler = mkSpockAction appStateRef qErrEncoder qErrModifier apiHandler
-- all graphql errors should be of type 200
allMod200 qe = qe {qeStatus = HTTP.status200}

View File

@ -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
logger
httpMgr
schemaSyncEventRef
appStateRef
instanceId
maintenanceMode
eventingMode
readOnlyMode
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
startSchemaSyncProcessorThread appStateRef logTVar = do
AppEnv {..} <- lift askAppEnv
let logger = _lsLogger appEnvLoggers
-- Start processor thread
processorThread <-
C.forkManagedT "SchemeUpdate.processor" logger $
processor appEnvMetadataVersionRef appStateRef logTVar
logThreadStarted logger appEnvInstanceId 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
maintenanceMode
eventingMode
readOnlyMode
logTVar
checkFeatureFlag = forever $ do
logTVar = forever do
metaVersion <- liftIO $ STM.atomically $ STM.takeTMVar metaVersionRef
AppContext {..} <- liftIO $ getAppContext appStateRef
let serverConfigCtx =
ServerConfigCtx
acFunctionPermsCtx
acRemoteSchemaPermsCtx
acSQLGenCtx
maintenanceMode
acExperimentalFeatures
eventingMode
readOnlyMode
acDefaultNamingConvention
acMetadataDefaults
checkFeatureFlag
acApolloFederationStatus
refreshSchemaCache metaVersion instanceId logger appStateRef TTProcessor serverConfigCtx logTVar
refreshSchemaCache metaVersion appStateRef TTProcessor logTVar
newtype SchemaUpdateT m a = SchemaUpdateT (AppContext -> m a)
deriving
( Functor,
Applicative,
Monad,
MonadError e,
MonadIO,
MonadMetadataStorage,
ProvidesNetwork,
MonadResolveSource
)
via (ReaderT AppContext m)
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]

View File

@ -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
>>> runExceptT
>=> flip onLeft printErrJExit
>=> flip onLeft printErrJExit
>>> flip onLeftM 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

View File

@ -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 =
CacheRefT $ flip modifyMVar \schemaCache -> do
buildSchemaCacheWithOptions reason invalidations metadata = do
scVar <- asks snd
modifyMVar scVar \schemaCache -> do
((), cache, _) <- runCacheRWT schemaCache (buildSchemaCacheWithOptions reason invalidations metadata)
pure (cache, ())
setMetadataResourceVersionInSchemaCache resourceVersion =
CacheRefT $ flip modifyMVar \schemaCache -> do
setMetadataResourceVersionInSchemaCache resourceVersion = 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 $
CacheRefT $ flip modifyMVar \_ ->
(runTx' pgExecCtx dropHdbCatalogSchema) *> (migrateCatalogAndBuildCache env time)
dropAndInit env time = lift do
scVar <- asks snd
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 $
CacheRefT $ flip modifyMVar \_ ->
migrateCatalogAndBuildCache env time
let upgradeToLatest env time = lift do
scVar <- asks snd
modifyMVar scVar $ const $ migrateCatalogAndBuildCache env time
env <- Env.getEnvironment
time <- getCurrentTime
transact (dropAndInit env time) `shouldReturn` MRInitialized