hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-14 17:02:49 +03:00
Code Issues Projects Releases Wiki Activity

Remove ServerConfigCtx.

Browse Source 
### Description

This PR removes `ServerConfigCtx` and `HasServerConfigCtx`. Instead, it favours different approaches:
- when the code was only using one field, it passes that field explicitly (usually `SQLGenCtx` or `CheckFeatureFlag`)
- when the code was using several fields, but in only one function, it inlines
- for the cache build, it introduces `CacheStaticConfig` and `CacheDynamicConfig`, which are subsets of `AppEnv` and `AppContext` respectively

The main goal of this is to help with the modularization of the engine: as `ServerConfigCtx` had fields whose types were imported from several unrelated parts of the engine, using it tied together parts of the engine that should not be aware of one another (such as tying together `Hasura.LogicalModel` and `Hasura.GraphQL.Schema`).

The bulk of this PR is a change to the cache build, as a follow up to #8509: instead of giving the entire `ServerConfigCtx` as a incremental rule argument, we only give the new `CacheDynamicConfig` struct, which has fewer fields. The other required fields, that were coming from the `AppEnv`, are now given via the `HasCacheStaticConfig` constraint, which is a "subset" of `HasAppEnv`.

(Some further work could include moving `StringifyNumbers` out of `GraphQL.Schema.Options`, given how it is used all across the codebase, including in `RQL.DML`.)

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/8513
GitOrigin-RevId: 818cbcd71494e3cd946b06adbb02ca328a8a298e
This commit is contained in:
Antoine Leblanc 2023-04-04 17:59:58 +02:00 committed by hasura-bot
parent 794690f30c
commit 306162f477
31 changed files with 475 additions and 403 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
server/graphql-engine.cabal
View File

@ -881,6 +881,7 @@ library
, Hasura.RQL.DDL.Schema
, Hasura.RQL.DDL.Schema.Cache
, Hasura.RQL.DDL.Schema.Cache.Common
, Hasura.RQL.DDL.Schema.Cache.Config
, Hasura.RQL.DDL.Schema.Cache.Dependencies
, Hasura.RQL.DDL.Schema.Cache.Fields
, Hasura.RQL.DDL.Schema.Cache.Permission

37
server/src-lib/Hasura/App.hs
View File

@ -122,6 +122,7 @@ import Hasura.RQL.DDL.ApiLimit (MonadGetApiTimeLimit (..))
import Hasura.RQL.DDL.EventTrigger (MonadEventLogCleanup (..))
import Hasura.RQL.DDL.Schema.Cache
import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.DDL.Schema.Catalog
import Hasura.RQL.Types.Allowlist
import Hasura.RQL.Types.Backend
@ -500,21 +501,18 @@ initialiseAppContext ::
AppInit ->
m (AppStateRef Hasura)
initialiseAppContext env serveOptions@ServeOptions {..} AppInit {..} = do
AppEnv {..} <- askAppEnv
appEnv@AppEnv {..} <- askAppEnv
let Loggers _ logger pgLogger = appEnvLoggers
sqlGenCtx = initSQLGenCtx soExperimentalFeatures soStringifyNum soDangerousBooleanCollapse
serverConfigCtx =
ServerConfigCtx
cacheStaticConfig = buildCacheStaticConfig appEnv
cacheDynamicConfig =
CacheDynamicConfig
soInferFunctionPermissions
soEnableRemoteSchemaPermissions
sqlGenCtx
soEnableMaintenanceMode
soExperimentalFeatures
soEventingMode
soReadOnlyMode
soDefaultNamingConvention
soMetadataDefaults
(CheckFeatureFlag $ checkFeatureFlag env)
soApolloFederationStatus
-- Create the schema cache
@ -522,10 +520,11 @@ initialiseAppContext env serveOptions@ServeOptions {..} AppInit {..} = do
buildFirstSchemaCache
env
logger
serverConfigCtx
(mkPgSourceResolver pgLogger)
mkMSSQLSourceResolver
aiMetadataWithResourceVersion
cacheStaticConfig
cacheDynamicConfig
appEnvManager
-- Build the RebuildableAppContext.
@ -589,26 +588,28 @@ buildFirstSchemaCache ::
(MonadIO m) =>
Env.Environment ->
Logger Hasura ->
ServerConfigCtx ->
SourceResolver ('Postgres 'Vanilla) ->
SourceResolver ('MSSQL) ->
MetadataWithResourceVersion ->
CacheStaticConfig ->
CacheDynamicConfig ->
HTTP.Manager ->
m RebuildableSchemaCache
buildFirstSchemaCache
env
logger
serverConfigCtx
pgSourceResolver
mssqlSourceResolver
metadataWithVersion
cacheStaticConfig
cacheDynamicConfig
httpManager = do
let cacheBuildParams = CacheBuildParams httpManager pgSourceResolver mssqlSourceResolver
let cacheBuildParams = CacheBuildParams httpManager pgSourceResolver mssqlSourceResolver cacheStaticConfig
buildReason = CatalogSync
result <-
runExceptT $
runCacheBuild cacheBuildParams $
buildRebuildableSchemaCacheWithReason buildReason logger env metadataWithVersion serverConfigCtx
buildRebuildableSchemaCacheWithReason buildReason logger env metadataWithVersion cacheDynamicConfig
result `onLeft` \err -> do
-- TODO: we used to bundle the first schema cache build with the catalog
-- migration, using the same error handler for both, meaning that an
@ -665,6 +666,14 @@ runAppM c (AppM a) = ignoreTraceT $ runReaderT a c
instance HasAppEnv AppM where
askAppEnv = ask
instance HasFeatureFlagChecker AppM where
checkFlag f = AppM do
CheckFeatureFlag runCheckFeatureFlag <- asks appEnvCheckFeatureFlag
liftIO $ runCheckFeatureFlag f
instance HasCacheStaticConfig AppM where
askCacheStaticConfig = buildCacheStaticConfig <$> askAppEnv
instance MonadTrace AppM where
newTraceWith c p n (AppM a) = AppM $ newTraceWith c p n a
newSpanWith i n (AppM a) = AppM $ newSpanWith i n a
@ -879,6 +888,8 @@ runHGEServer ::
UserAuthentication m,
HttpLog m,
HasAppEnv m,
HasCacheStaticConfig m,
HasFeatureFlagChecker m,
ConsoleRenderer m,
MonadVersionAPIWithExtraData m,
MonadMetadataApiAuthorization m,
@ -971,6 +982,8 @@ mkHGEServer ::
UserAuthentication m,
HttpLog m,
HasAppEnv m,
HasCacheStaticConfig m,
HasFeatureFlagChecker m,
ConsoleRenderer m,
MonadVersionAPIWithExtraData m,
MonadMetadataApiAuthorization m,

52
server/src-lib/Hasura/App/State.hs
View File

@ -13,10 +13,11 @@ module Hasura.App.State
-- * init functions
buildRebuildableAppContext,
rebuildRebuildableAppContext,
initSQLGenCtx,
-- * server config
buildServerConfigCtx,
-- * subsets
initSQLGenCtx,
buildCacheStaticConfig,
buildCacheDynamicConfig,
)
where
@ -36,6 +37,7 @@ import Hasura.GraphQL.Schema.Options qualified as Options
import Hasura.Incremental qualified as Inc
import Hasura.Logging qualified as L
import Hasura.Prelude
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Metadata
import Hasura.RQL.Types.SchemaCache (MetadataResourceVersion)
@ -300,6 +302,9 @@ buildAppContextRule = proc (ServeOptions {..}, env, _keys) -> do
| otherwise -> InternalErrorsDisabled
returnA -< responseInternalErrorsConfig
--------------------------------------------------------------------------------
-- subsets
initSQLGenCtx :: HashSet ExperimentalFeature -> Options.StringifyNumbers -> Options.DangerouslyCollapseBooleans -> SQLGenCtx
initSQLGenCtx experimentalFeatures stringifyNum dangerousBooleanCollapse =
let optimizePermissionFilters
@ -311,26 +316,23 @@ initSQLGenCtx experimentalFeatures stringifyNum dangerousBooleanCollapse =
| otherwise = Options.DisableBigQueryStringNumericInput
in SQLGenCtx stringifyNum dangerousBooleanCollapse optimizePermissionFilters bigqueryStringNumericInput
--------------------------------------------------------------------------------
-- server config
-- | We are trying to slowly get rid of 'HasServerConfigCtx' (and consequently
-- of 'ServercConfigtx') in favour of smaller / more specific ad-hoc
-- types. However, in the meantime, it is often required to builda
-- 'ServerConfigCtx' at the boundary between parts of the code that use it and
-- part of the code that use the new 'AppEnv' and 'AppContext'.
buildServerConfigCtx :: AppEnv -> AppContext -> ServerConfigCtx
buildServerConfigCtx AppEnv {..} AppContext {..} =
ServerConfigCtx
{ _sccFunctionPermsCtx = acFunctionPermsCtx,
_sccRemoteSchemaPermsCtx = acRemoteSchemaPermsCtx,
_sccSQLGenCtx = acSQLGenCtx,
_sccMaintenanceMode = appEnvEnableMaintenanceMode,
_sccExperimentalFeatures = acExperimentalFeatures,
_sccEventingMode = appEnvEventingMode,
_sccReadOnlyMode = appEnvEnableReadOnlyMode,
_sccDefaultNamingConvention = acDefaultNamingConvention,
_sccMetadataDefaults = acMetadataDefaults,
_sccCheckFeatureFlag = appEnvCheckFeatureFlag,
_sccApolloFederationStatus = acApolloFederationStatus
buildCacheStaticConfig :: AppEnv -> CacheStaticConfig
buildCacheStaticConfig AppEnv {..} =
CacheStaticConfig
{ _cscMaintenanceMode = appEnvEnableMaintenanceMode,
_cscEventingMode = appEnvEventingMode,
_cscReadOnlyMode = appEnvEnableReadOnlyMode,
_cscCheckFeatureFlag = appEnvCheckFeatureFlag
}
buildCacheDynamicConfig :: AppContext -> CacheDynamicConfig
buildCacheDynamicConfig AppContext {..} =
CacheDynamicConfig
{ _cdcFunctionPermsCtx = acFunctionPermsCtx,
_cdcRemoteSchemaPermsCtx = acRemoteSchemaPermsCtx,
_cdcSQLGenCtx = acSQLGenCtx,
_cdcExperimentalFeatures = acExperimentalFeatures,
_cdcDefaultNamingConvention = acDefaultNamingConvention,
_cdcMetadataDefaults = acMetadataDefaults,
_cdcApolloFederationStatus = acApolloFederationStatus
}

6
server/src-lib/Hasura/Backends/MSSQL/DDL/EventTrigger.hs
View File

@ -214,7 +214,7 @@ dropDanglingSQLTrigger sourceConfig triggerName table ops =
createTableEventTrigger ::
MonadIO m =>
ServerConfigCtx ->
SQLGenCtx ->
MSSQLSourceConfig ->
TableName ->
[ColumnInfo 'MSSQL] ->
@ -223,7 +223,7 @@ createTableEventTrigger ::
TriggerOpsDef 'MSSQL ->
Maybe (PrimaryKey 'MSSQL (ColumnInfo 'MSSQL)) ->
m (Either QErr ())
createTableEventTrigger _serverConfigCtx sourceConfig table columns triggerName triggerOnReplication opsDefinition primaryKeyMaybe = do
createTableEventTrigger _sqlGen sourceConfig table columns triggerName triggerOnReplication opsDefinition primaryKeyMaybe = do
liftIO $
runMSSQLSourceWriteTx sourceConfig $ do
mkAllTriggersQ triggerName table triggerOnReplication columns opsDefinition primaryKeyMaybe
@ -233,7 +233,7 @@ createMissingSQLTriggers ::
MonadError QErr m,
MonadBaseControl IO m
) =>
ServerConfigCtx ->
SQLGenCtx ->
MSSQLSourceConfig ->
TableName ->
([ColumnInfo 'MSSQL], Maybe (PrimaryKey 'MSSQL (ColumnInfo 'MSSQL))) ->

12
server/src-lib/Hasura/Backends/Postgres/DDL/EventTrigger.hs
View File

@ -205,7 +205,7 @@ createMissingSQLTriggers ::
MonadBaseControl IO m,
Backend ('Postgres pgKind)
) =>
ServerConfigCtx ->
SQLGenCtx ->
PGSourceConfig ->
TableName ('Postgres pgKind) ->
([(ColumnInfo ('Postgres pgKind))], Maybe (PrimaryKey ('Postgres pgKind) (ColumnInfo ('Postgres pgKind)))) ->
@ -241,7 +241,7 @@ createMissingSQLTriggers serverConfigCtx sourceConfig table (allCols, _) trigger
createTableEventTrigger ::
(Backend ('Postgres pgKind), MonadIO m, MonadBaseControl IO m) =>
ServerConfigCtx ->
SQLGenCtx ->
PGSourceConfig ->
QualifiedTable ->
[ColumnInfo ('Postgres pgKind)] ->
@ -674,7 +674,7 @@ pgIdenTrigger op = QualifiedTriggerName . pgFmtIdentifier . unQualifiedTriggerNa
-- | Define the pgSQL trigger functions on database events.
mkTriggerFunctionQ ::
forall pgKind m.
(Backend ('Postgres pgKind), MonadTx m, MonadReader ServerConfigCtx m) =>
(Backend ('Postgres pgKind), MonadTx m, MonadReader SQLGenCtx m) =>
TriggerName ->
QualifiedTable ->
[ColumnInfo ('Postgres pgKind)] ->
@ -682,7 +682,7 @@ mkTriggerFunctionQ ::
SubscribeOpSpec ('Postgres pgKind) ->
m QualifiedTriggerName
mkTriggerFunctionQ triggerName (QualifiedObject schema table) allCols op (SubscribeOpSpec listenColumns deliveryColumns') = do
strfyNum <- stringifyNum . _sccSQLGenCtx <$> ask
strfyNum <- asks stringifyNum
let dbQualifiedTriggerName = pgIdenTrigger op triggerName
() <-
liftTx $
@ -795,7 +795,7 @@ checkIfFunctionExistsQ triggerName op = do
mkTrigger ::
forall pgKind m.
(Backend ('Postgres pgKind), MonadTx m, MonadReader ServerConfigCtx m) =>
(Backend ('Postgres pgKind), MonadTx m, MonadReader SQLGenCtx m) =>
TriggerName ->
QualifiedTable ->
TriggerOnReplication ->
@ -830,7 +830,7 @@ mkTrigger triggerName table triggerOnReplication allCols op subOpSpec = do
mkAllTriggersQ ::
forall pgKind m.
(Backend ('Postgres pgKind), MonadTx m, MonadReader ServerConfigCtx m) =>
(Backend ('Postgres pgKind), MonadTx m, MonadReader SQLGenCtx m) =>
TriggerName ->
QualifiedTable ->
TriggerOnReplication ->

15
server/src-lib/Hasura/Backends/Postgres/DDL/RunSQL.hs
View File

@ -59,7 +59,6 @@ import Hasura.RQL.Types.Source
import Hasura.RQL.Types.Table
import Hasura.SQL.AnyBackend qualified as AB
import Hasura.SQL.Backend
import Hasura.Server.Types
import Hasura.Server.Utils (quoteRegex)
import Hasura.Session
import Hasura.Tracing qualified as Tracing
@ -207,7 +206,6 @@ runRunSQL ::
FetchTableMetadata pgKind,
FetchFunctionMetadata pgKind,
CacheRWM m,
HasServerConfigCtx m,
MetadataM m,
MonadBaseControl IO m,
MonadError QErr m,
@ -215,9 +213,10 @@ runRunSQL ::
Tracing.MonadTrace m,
UserInfoM m
) =>
SQLGenCtx ->
RunSQL ->
m EncJSON
runRunSQL q@RunSQL {..} = do
runRunSQL sqlGen q@RunSQL {..} = do
sourceConfig <- askSourceConfig @('Postgres pgKind) rSource
traceCtx <- Tracing.currentContext
userInfo <- askUserInfo
@ -225,7 +224,7 @@ runRunSQL q@RunSQL {..} = do
if (isSchemaCacheBuildRequiredRunSQL q)
then do
-- see Note [Checking metadata consistency in run_sql]
withMetadataCheck @pgKind rSource rCascade rTxAccessMode $
withMetadataCheck @pgKind sqlGen rSource rCascade rTxAccessMode $
withTraceContext traceCtx $
withUserInfo userInfo $
execRawSQL rSql
@ -250,18 +249,18 @@ withMetadataCheck ::
FetchTableMetadata pgKind,
FetchFunctionMetadata pgKind,
CacheRWM m,
HasServerConfigCtx m,
MetadataM m,
MonadBaseControl IO m,
MonadError QErr m,
MonadIO m
) =>
SQLGenCtx ->
SourceName ->
Bool ->
PG.TxAccess ->
PG.TxET QErr m a ->
m a
withMetadataCheck source cascade txAccess runSQLQuery = do
withMetadataCheck sqlGen source cascade txAccess runSQLQuery = do
SourceInfo _ tableCache functionCache _logicalModels _customReturnTypes sourceConfig _ _ <- askSourceInfo @('Postgres pgKind) source
-- Run SQL query and metadata checker in a transaction
@ -281,14 +280,14 @@ withMetadataCheck source cascade txAccess runSQLQuery = do
recreateEventTriggers :: PGSourceConfig -> SchemaCache -> m ()
recreateEventTriggers sourceConfig schemaCache = do
let tables = fromMaybe mempty $ unsafeTableCache @('Postgres pgKind) source $ scSources schemaCache
serverConfigCtx <- askServerConfigCtx
liftEitherM $
runPgSourceWriteTx sourceConfig RunSQLQuery $
forM_ (M.elems tables) $ \(TableInfo coreInfo _ eventTriggers _) -> do
let table = _tciName coreInfo
columns = getCols $ _tciFieldInfoMap coreInfo
forM_ (M.toList eventTriggers) $ \(triggerName, EventTriggerInfo {etiOpsDef, etiTriggerOnReplication}) -> do
flip runReaderT serverConfigCtx $ mkAllTriggersQ triggerName table etiTriggerOnReplication columns etiOpsDef
flip runReaderT sqlGen $
mkAllTriggersQ triggerName table etiTriggerOnReplication columns etiOpsDef
-- | @'runTxWithMetadataCheck source sourceConfig txAccess tableCache functionCache cascadeDependencies tx' checks for
-- changes in GraphQL Engine metadata when a @'tx' is executed on the database alters Postgres

24
server/src-lib/Hasura/CustomReturnType/API.hs
View File

@ -42,8 +42,8 @@ import Hasura.RQL.Types.Permission (PermDef (_pdRole), SelPerm)
import Hasura.RQL.Types.SchemaCache.Build
import Hasura.SQL.AnyBackend qualified as AB
import Hasura.SQL.Backend
import Hasura.Server.Init.FeatureFlag as FF
import Hasura.Server.Types (HasServerConfigCtx (..), ServerConfigCtx (..))
import Hasura.Server.Init.FeatureFlag (HasFeatureFlagChecker (..))
import Hasura.Server.Init.FeatureFlag qualified as FF
import Hasura.Session (RoleName)
-- | Default implementation of the 'track_custom_return_type' request payload.
@ -122,8 +122,7 @@ runGetCustomReturnType ::
forall b m.
( BackendMetadata b,
MetadataM m,
HasServerConfigCtx m,
MonadIO m,
HasFeatureFlagChecker m,
MonadError QErr m
) =>
GetCustomReturnType b ->
@ -151,8 +150,7 @@ runTrackCustomReturnType ::
CacheRWM m,
MetadataM m,
MonadError QErr m,
HasServerConfigCtx m,
MonadIO m
HasFeatureFlagChecker m
) =>
TrackCustomReturnType b ->
m EncJSON
@ -273,7 +271,7 @@ instance
runCreateSelectCustomReturnTypePermission ::
forall b m.
(Backend b, CacheRWM m, MetadataM m, MonadError QErr m, MonadIO m, HasServerConfigCtx m) =>
(Backend b, CacheRWM m, MetadataM m, MonadError QErr m, HasFeatureFlagChecker m) =>
CreateCustomReturnTypePermission SelPerm b ->
m EncJSON
runCreateSelectCustomReturnTypePermission CreateCustomReturnTypePermission {..} = do
@ -312,7 +310,7 @@ instance FromJSON (DropCustomReturnTypePermission b) where
runDropSelectCustomReturnTypePermission ::
forall b m.
(Backend b, CacheRWM m, MetadataM m, MonadError QErr m, MonadIO m, HasServerConfigCtx m) =>
(Backend b, CacheRWM m, MetadataM m, MonadError QErr m, HasFeatureFlagChecker m) =>
DropCustomReturnTypePermission b ->
m EncJSON
runDropSelectCustomReturnTypePermission DropCustomReturnTypePermission {..} = do
@ -340,14 +338,10 @@ dropCustomReturnTypeInMetadata source name = do
%~ OMap.delete name
-- | check feature flag is enabled before carrying out any actions
throwIfFeatureDisabled :: (HasServerConfigCtx m, MonadIO m, MonadError QErr m) => m ()
throwIfFeatureDisabled :: (HasFeatureFlagChecker m, MonadError QErr m) => m ()
throwIfFeatureDisabled = do
configCtx <- askServerConfigCtx
let CheckFeatureFlag runCheckFeatureFlag = _sccCheckFeatureFlag configCtx
enableCustomReturnTypes <- liftIO (runCheckFeatureFlag FF.logicalModelInterface)
unless enableCustomReturnTypes (throw500 "CustomReturnTypes is disabled!")
enableCustomReturnTypes <- checkFlag FF.logicalModelInterface
unless enableCustomReturnTypes $ throw500 "CustomReturnTypes is disabled!"
-- | Check whether a custom return type with the given root field name exists for
-- the given source.

129
server/src-lib/Hasura/GraphQL/Schema.hs
View File

@ -97,7 +97,11 @@ buildGQLContext ::
( MonadError QErr m,
MonadIO m
) =>
ServerConfigCtx ->
Options.InferFunctionPermissions ->
Options.RemoteSchemaPermissions ->
HashSet ExperimentalFeature ->
SQLGenCtx ->
ApolloFederationStatus ->
SourceCache ->
HashMap RemoteSchemaName (RemoteSchemaCtx, MetadataObject) ->
ActionCache ->
@ -114,66 +118,75 @@ buildGQLContext ::
GQLContext
)
)
buildGQLContext ServerConfigCtx {..} sources allRemoteSchemas allActions customTypes = do
let remoteSchemasRoles = concatMap (Map.keys . _rscPermissions . fst . snd) $ Map.toList allRemoteSchemas
actionRoles =
Set.insert adminRoleName $
Set.fromList (allActionInfos ^.. folded . aiPermissions . to Map.keys . folded)
<> Set.fromList (bool mempty remoteSchemasRoles $ _sccRemoteSchemaPermsCtx == Options.EnableRemoteSchemaPermissions)
allActionInfos = Map.elems allActions
allTableRoles = Set.fromList $ getTableRoles =<< Map.elems sources
allCustomReturnTypeRoles = Set.fromList $ getCustomReturnTypeRoles =<< Map.elems sources
allRoles = actionRoles <> allTableRoles <> allCustomReturnTypeRoles
buildGQLContext
functionPermissions
remoteSchemaPermissions
experimentalFeatures
sqlGen
apolloFederationStatus
sources
allRemoteSchemas
allActions
customTypes = do
let remoteSchemasRoles = concatMap (Map.keys . _rscPermissions . fst . snd) $ Map.toList allRemoteSchemas
actionRoles =
Set.insert adminRoleName $
Set.fromList (allActionInfos ^.. folded . aiPermissions . to Map.keys . folded)
<> Set.fromList (bool mempty remoteSchemasRoles $ remoteSchemaPermissions == Options.EnableRemoteSchemaPermissions)
allActionInfos = Map.elems allActions
allTableRoles = Set.fromList $ getTableRoles =<< Map.elems sources
allCustomReturnTypeRoles = Set.fromList $ getCustomReturnTypeRoles =<< Map.elems sources
allRoles = actionRoles <> allTableRoles <> allCustomReturnTypeRoles
contexts <-
-- Buld role contexts in parallel. We'd prefer deterministic parallelism
-- but that isn't really acheivable (see mono #3829). NOTE: the admin role
-- will still be a bottleneck here, even on huge_schema which has many
-- roles.
fmap Map.fromList $
forConcurrentlyEIO 10 (Set.toList allRoles) $ \role -> do
(role,)
<$> concurrentlyEIO
( buildRoleContext
(_sccSQLGenCtx, _sccFunctionPermsCtx)
sources
allRemoteSchemas
allActionInfos
customTypes
role
_sccRemoteSchemaPermsCtx
_sccExperimentalFeatures
_sccApolloFederationStatus
)
( buildRelayRoleContext
(_sccSQLGenCtx, _sccFunctionPermsCtx)
sources
allActionInfos
customTypes
role
_sccExperimentalFeatures
)
let hasuraContexts = fst <$> contexts
relayContexts = snd <$> contexts
contexts <-
-- Buld role contexts in parallel. We'd prefer deterministic parallelism
-- but that isn't really acheivable (see mono #3829). NOTE: the admin role
-- will still be a bottleneck here, even on huge_schema which has many
-- roles.
fmap Map.fromList $
forConcurrentlyEIO 10 (Set.toList allRoles) $ \role -> do
(role,)
<$> concurrentlyEIO
( buildRoleContext
(sqlGen, functionPermissions)
sources
allRemoteSchemas
allActionInfos
customTypes
role
remoteSchemaPermissions
experimentalFeatures
apolloFederationStatus
)
( buildRelayRoleContext
(sqlGen, functionPermissions)
sources
allActionInfos
customTypes
role
experimentalFeatures
)
let hasuraContexts = fst <$> contexts
relayContexts = snd <$> contexts
adminIntrospection <-
case Map.lookup adminRoleName hasuraContexts of
Just (_context, _errors, introspection) -> pure introspection
Nothing -> throw500 "buildGQLContext failed to build for the admin role"
(unauthenticated, unauthenticatedRemotesErrors) <- unauthenticatedContext allRemoteSchemas _sccRemoteSchemaPermsCtx
pure
( ( adminIntrospection,
view _1 <$> hasuraContexts,
unauthenticated,
Set.unions $ unauthenticatedRemotesErrors : (view _2 <$> Map.elems hasuraContexts)
),
( relayContexts,
-- Currently, remote schemas are exposed through Relay, but ONLY through
-- the unauthenticated role. This is probably an oversight. See
-- hasura/graphql-engine-mono#3883.
unauthenticated
adminIntrospection <-
case Map.lookup adminRoleName hasuraContexts of
Just (_context, _errors, introspection) -> pure introspection
Nothing -> throw500 "buildGQLContext failed to build for the admin role"
(unauthenticated, unauthenticatedRemotesErrors) <- unauthenticatedContext allRemoteSchemas remoteSchemaPermissions
pure
( ( adminIntrospection,
view _1 <$> hasuraContexts,
unauthenticated,
Set.unions $ unauthenticatedRemotesErrors : (view _2 <$> Map.elems hasuraContexts)
),
( relayContexts,
-- Currently, remote schemas are exposed through Relay, but ONLY through
-- the unauthenticated role. This is probably an oversight. See
-- hasura/graphql-engine-mono#3883.
unauthenticated
)
)
)
buildSchemaOptions ::
(SQLGenCtx, Options.InferFunctionPermissions) ->

25
server/src-lib/Hasura/LogicalModel/API.hs
View File

@ -37,8 +37,8 @@ import Hasura.RQL.Types.SchemaCache.Build
import Hasura.SQL.AnyBackend qualified as AB
import Hasura.SQL.Backend
import Hasura.SQL.Tag
import Hasura.Server.Init.FeatureFlag as FF
import Hasura.Server.Types (HasServerConfigCtx (..), ServerConfigCtx (..))
import Hasura.Server.Init.FeatureFlag (HasFeatureFlagChecker (..))
import Hasura.Server.Init.FeatureFlag qualified as FF
-- | Default implementation of the 'track_logical_model' request payload.
data TrackLogicalModel (b :: BackendType) = TrackLogicalModel
@ -90,9 +90,9 @@ deriving via
logicalModelTrackToMetadata ::
forall b m.
( BackendMetadata b,
MetadataM m,
MonadError QErr m,
MonadIO m,
MonadError QErr m
MetadataM m
) =>
Env.Environment ->
SourceConnConfiguration b ->
@ -145,8 +145,7 @@ runGetLogicalModel ::
forall b m.
( BackendMetadata b,
MetadataM m,
HasServerConfigCtx m,
MonadIO m,
HasFeatureFlagChecker m,
MonadError QErr m
) =>
GetLogicalModel b ->
@ -167,11 +166,11 @@ runGetLogicalModel q = do
runTrackLogicalModel ::
forall b m.
( BackendMetadata b,
MonadError QErr m,
MonadIO m,
CacheRWM m,
MetadataM m,
MonadError QErr m,
HasServerConfigCtx m,
MonadIO m
HasFeatureFlagChecker m
) =>
Env.Environment ->
TrackLogicalModel b ->
@ -273,13 +272,9 @@ dropLogicalModelInMetadata source rootFieldName = do
%~ OMap.delete rootFieldName
-- | check feature flag is enabled before carrying out any actions
throwIfFeatureDisabled :: (HasServerConfigCtx m, MonadIO m, MonadError QErr m) => m ()
throwIfFeatureDisabled :: (HasFeatureFlagChecker m, MonadError QErr m) => m ()
throwIfFeatureDisabled = do
configCtx <- askServerConfigCtx
let CheckFeatureFlag runCheckFeatureFlag = _sccCheckFeatureFlag configCtx
enableLogicalModels <- liftIO (runCheckFeatureFlag FF.logicalModelInterface)
enableLogicalModels <- checkFlag FF.logicalModelInterface
unless enableLogicalModels (throw500 "LogicalModels is disabled!")
-- | Check whether a logical model with the given root field name exists for

6
server/src-lib/Hasura/RQL/DDL/FeatureFlag.hs
View File

@ -9,7 +9,6 @@ where
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
import Data.Aeson (FromJSON, (.:), (.=))
import Data.Aeson qualified as Aeson
import Data.HashMap.Strict qualified as HashMap
@ -31,13 +30,12 @@ instance FromJSON GetFeatureFlag where
runGetFeatureFlag ::
( MonadError Error.QErr m,
Types.HasServerConfigCtx m,
MonadIO m
) =>
Types.CheckFeatureFlag ->
GetFeatureFlag ->
m EncJSON
runGetFeatureFlag GetFeatureFlag {..} = do
Types.CheckFeatureFlag getFeatureFlag <- Types._sccCheckFeatureFlag <$> Types.askServerConfigCtx
runGetFeatureFlag (Types.CheckFeatureFlag getFeatureFlag) GetFeatureFlag {..} = do
let flagM = HashMap.lookup gfgIdentifier $ FeatureFlag.getFeatureFlags $ FeatureFlag.featureFlags
case flagM of
Nothing -> Error.throw400 Error.NotFound $ "Feature Flag '" <> gfgIdentifier <> "' not found"

136
server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs
View File

@ -61,6 +61,7 @@ import Hasura.RQL.DDL.InheritedRoles (resolveInheritedRole)
import Hasura.RQL.DDL.RemoteRelationship (CreateRemoteSchemaRemoteRelationship (..), PartiallyResolvedSource (..), buildRemoteFieldInfo, getRemoteSchemaEntityJoinColumns)
import Hasura.RQL.DDL.ScheduledTrigger
import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.DDL.Schema.Cache.Dependencies
import Hasura.RQL.DDL.Schema.Cache.Fields
import Hasura.RQL.DDL.Schema.Cache.Permission
@ -147,7 +148,7 @@ buildRebuildableSchemaCache ::
Logger Hasura ->
Env.Environment ->
MetadataWithResourceVersion ->
ServerConfigCtx ->
CacheDynamicConfig ->
CacheBuild RebuildableSchemaCache
buildRebuildableSchemaCache =
buildRebuildableSchemaCacheWithReason CatalogSync
@ -157,12 +158,12 @@ buildRebuildableSchemaCacheWithReason ::
Logger Hasura ->
Env.Environment ->
MetadataWithResourceVersion ->
ServerConfigCtx ->
CacheDynamicConfig ->
CacheBuild RebuildableSchemaCache
buildRebuildableSchemaCacheWithReason reason logger env metadataWithVersion serverConfigCtx = do
buildRebuildableSchemaCacheWithReason reason logger env metadataWithVersion dynamicConfig = do
result <-
flip runReaderT reason $
Inc.build (buildSchemaCacheRule logger env) (metadataWithVersion, serverConfigCtx, initialInvalidationKeys, Nothing)
Inc.build (buildSchemaCacheRule logger env) (metadataWithVersion, dynamicConfig, initialInvalidationKeys, Nothing)
pure $ RebuildableSchemaCache (Inc.result result) initialInvalidationKeys (Inc.rebuildRule result)
@ -172,11 +173,11 @@ newtype CacheRWT m a
-- (which added Control.Monad.Trans.Writer.CPS) are leaky, and we don’t have
-- that yet.
--
-- The use of 'ReaderT ServerConfigCtx' is only here to avoid manually
-- passing the 'ServerConfigCtx' to every function that builds the cache. It
-- The use of 'ReaderT CacheDynamicConfig' is only here to avoid manually
-- passing the 'CacheDynamicConfig' to every function that builds the cache. It
-- should ultimately be reduced to 'AppContext', or even better a relevant
-- subset thereof.
CacheRWT (ReaderT ServerConfigCtx (StateT (RebuildableSchemaCache, CacheInvalidations) m) a)
CacheRWT (ReaderT CacheDynamicConfig (StateT (RebuildableSchemaCache, CacheInvalidations) m) a)
deriving newtype
( Functor,
Applicative,
@ -188,13 +189,11 @@ newtype CacheRWT m a
Tracing.MonadTrace,
MonadBase b,
MonadBaseControl b,
ProvidesNetwork
ProvidesNetwork,
FF.HasFeatureFlagChecker
)
deriving anyclass (MonadQueryTags)
instance Monad m => HasServerConfigCtx (CacheRWT m) where
askServerConfigCtx = CacheRWT ask
instance MonadReader r m => MonadReader r (CacheRWT m) where
ask = lift ask
local f (CacheRWT m) = CacheRWT $ mapReaderT (local f) m
@ -209,7 +208,7 @@ instance (MonadGetApiTimeLimit m) => MonadGetApiTimeLimit (CacheRWT m) where
runCacheRWT ::
Monad m =>
ServerConfigCtx ->
CacheDynamicConfig ->
RebuildableSchemaCache ->
CacheRWT m a ->
m (a, RebuildableSchemaCache, CacheInvalidations)
@ -228,19 +227,20 @@ instance
( MonadIO m,
MonadError QErr m,
ProvidesNetwork m,
MonadResolveSource m
MonadResolveSource m,
HasCacheStaticConfig m
) =>
CacheRWM (CacheRWT m)
where
buildSchemaCacheWithOptions buildReason invalidations metadata = CacheRWT do
serverConfigCtx <- ask
dynamicConfig <- ask
(RebuildableSchemaCache lastBuiltSC invalidationKeys rule, oldInvalidations) <- get
let metadataWithVersion = MetadataWithResourceVersion metadata $ scMetadataResourceVersion lastBuiltSC
newInvalidationKeys = invalidateKeys invalidations invalidationKeys
result <-
runCacheBuildM $
flip runReaderT buildReason $
Inc.build rule (metadataWithVersion, serverConfigCtx, newInvalidationKeys, Nothing)
Inc.build rule (metadataWithVersion, dynamicConfig, newInvalidationKeys, Nothing)
let schemaCache = Inc.result result
prunedInvalidationKeys = pruneInvalidationKeys schemaCache newInvalidationKeys
!newCache = RebuildableSchemaCache schemaCache prunedInvalidationKeys (Inc.rebuildRule result)
@ -335,19 +335,20 @@ buildSchemaCacheRule ::
MonadError QErr m,
MonadReader BuildReason m,
ProvidesNetwork m,
MonadResolveSource m
MonadResolveSource m,
HasCacheStaticConfig m
) =>
Logger Hasura ->
Env.Environment ->
(MetadataWithResourceVersion, ServerConfigCtx, InvalidationKeys, Maybe StoredIntrospection) `arr` SchemaCache
buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDefaults resourceVersion, serverConfigCtx, invalidationKeys, storedIntrospection) -> do
(MetadataWithResourceVersion, CacheDynamicConfig, InvalidationKeys, Maybe StoredIntrospection) `arr` SchemaCache
buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDefaults resourceVersion, dynamicConfig, invalidationKeys, storedIntrospection) -> do
invalidationKeysDep <- Inc.newDependency -< invalidationKeys
let metadataDefaults = _sccMetadataDefaults serverConfigCtx
let metadataDefaults = _cdcMetadataDefaults dynamicConfig
metadata@Metadata {..} = overrideMetadataDefaults metadataNoDefaults metadataDefaults
metadataDep <- Inc.newDependency -< metadata
(inconsistentObjects, (resolvedOutputs, dependencyInconsistentObjects, resolvedDependencies), ((adminIntrospection, gqlContext, gqlContextUnauth, inconsistentRemoteSchemas), (relayContext, relayContextUnauth))) <-
Inc.cache buildOutputsAndSchema -< (metadataDep, serverConfigCtx, invalidationKeysDep, storedIntrospection)
Inc.cache buildOutputsAndSchema -< (metadataDep, dynamicConfig, invalidationKeysDep, storedIntrospection)
let (resolvedEndpoints, endpointCollectedInfo) = runIdentity $ runWriterT $ buildRESTEndpoints _metaQueryCollections (OMap.elems _metaRestEndpoints)
(cronTriggersMap, cronTriggersCollectedInfo) = runIdentity $ runWriterT $ buildCronTriggers (OMap.elems _metaCronTriggers)
@ -442,15 +443,19 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
}
where
-- See Note [Avoiding GraphQL schema rebuilds when changing irrelevant Metadata]
buildOutputsAndSchema = proc (metadataDep, serverConfigCtx, invalidationKeysDep, storedIntrospection) -> do
(outputs, collectedInfo) <- runWriterA buildAndCollectInfo -< (serverConfigCtx, metadataDep, invalidationKeysDep, storedIntrospection)
buildOutputsAndSchema = proc (metadataDep, dynamicConfig, invalidationKeysDep, storedIntrospection) -> do
(outputs, collectedInfo) <- runWriterA buildAndCollectInfo -< (dynamicConfig, metadataDep, invalidationKeysDep, storedIntrospection)
let (inconsistentObjects, unresolvedDependencies) = partitionEithers $ toList collectedInfo
out2@(resolvedOutputs, _dependencyInconsistentObjects, _resolvedDependencies) <- resolveDependencies -< (outputs, unresolvedDependencies)
out3 <-
bindA
-< do
buildGQLContext
serverConfigCtx
(_cdcFunctionPermsCtx dynamicConfig)
(_cdcRemoteSchemaPermsCtx dynamicConfig)
(_cdcExperimentalFeatures dynamicConfig)
(_cdcSQLGenCtx dynamicConfig)
(_cdcApolloFederationStatus dynamicConfig)
(_boSources resolvedOutputs)
(_boRemoteSchemas resolvedOutputs)
(_boActions resolvedOutputs)
@ -484,7 +489,8 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
ArrowWriter (Seq (Either InconsistentMetadata MetadataDependency)) arr,
MonadIO m,
MonadBaseControl IO m,
ProvidesNetwork m
ProvidesNetwork m,
HasCacheStaticConfig m
) =>
(Inc.Dependency (BackendMap BackendInvalidationKeysWrapper), [AB.AnyBackend BackendConfigWrapper]) `arr` BackendCache
resolveBackendCache = proc (backendInvalidationMap, backendConfigs) -> do
@ -586,17 +592,19 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
MonadIO m,
BackendMetadata b,
MonadError QErr m,
MonadBaseControl IO m
MonadBaseControl IO m,
HasCacheStaticConfig m
) =>
(Proxy b, ServerConfigCtx, Bool, SourceConfig b) `arr` (RecreateEventTriggers, SourceCatalogMigrationState)
initCatalogIfNeeded = Inc.cache proc (Proxy, serverConfigCtx, atleastOneTrigger, sourceConfig) -> do
(Proxy b, Bool, SourceConfig b) `arr` (RecreateEventTriggers, SourceCatalogMigrationState)
initCatalogIfNeeded = Inc.cache proc (Proxy, atleastOneTrigger, sourceConfig) -> do
bindA
-< do
if atleastOneTrigger
then do
let maintenanceMode = _sccMaintenanceMode serverConfigCtx
eventingMode = _sccEventingMode serverConfigCtx
readOnlyMode = _sccReadOnlyMode serverConfigCtx
cacheStaticConfig <- askCacheStaticConfig
let maintenanceMode = _cscMaintenanceMode cacheStaticConfig
eventingMode = _cscEventingMode cacheStaticConfig
readOnlyMode = _cscReadOnlyMode cacheStaticConfig
if
-- when safe mode is enabled, don't perform any migrations
@ -632,9 +640,10 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
MonadError QErr m,
MonadIO m,
BackendMetadata b,
GetAggregationPredicatesDeps b
GetAggregationPredicatesDeps b,
HasCacheStaticConfig m
) =>
( ServerConfigCtx,
( CacheDynamicConfig,
HashMap SourceName (AB.AnyBackend PartiallyResolvedSource),
SourceMetadata b,
SourceConfig b,
@ -646,7 +655,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
OrderedRoles
)
`arr` (SourceInfo b)
buildSource = proc (serverConfigCtx, allSources, sourceMetadata, sourceConfig, tablesRawInfo, eventTriggerInfoMaps, _dbTables, dbFunctions, remoteSchemaMap, orderedRoles) -> do
buildSource = proc (dynamicConfig, allSources, sourceMetadata, sourceConfig, tablesRawInfo, eventTriggerInfoMaps, _dbTables, dbFunctions, remoteSchemaMap, orderedRoles) -> do
let SourceMetadata sourceName _backendKind tables functions logicalModels customReturnTypes _ queryTagsConfig sourceCustomization _healthCheckConfig = sourceMetadata
tablesMetadata = OMap.elems tables
(_, nonColumnInputs, permissions) = unzip3 $ map mkTableInputs tablesMetadata
@ -683,8 +692,8 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
-- not forcing the evaluation here results in a measurable negative impact
-- on memory residency as measured by our benchmark
let !defaultNC = _sccDefaultNamingConvention serverConfigCtx
!isNamingConventionEnabled = EFNamingConventions `elem` (_sccExperimentalFeatures serverConfigCtx)
let !defaultNC = _cdcDefaultNamingConvention dynamicConfig
!isNamingConventionEnabled = EFNamingConventions `elem` (_cdcExperimentalFeatures dynamicConfig)
!namingConv <-
bindA
-<
@ -732,7 +741,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
areLogicalModelsEnabled <-
bindA
-< do
let CheckFeatureFlag checkFeatureFlag = _sccCheckFeatureFlag serverConfigCtx
CheckFeatureFlag checkFeatureFlag <- _cscCheckFeatureFlag <$> askCacheStaticConfig
liftIO @m $ checkFeatureFlag FF.logicalModelInterface
let mkCustomReturnTypeMetadataObject :: CustomReturnTypeMetadata b -> MetadataObject
@ -821,10 +830,11 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
MonadReader BuildReason m,
MonadBaseControl IO m,
ProvidesNetwork m,
MonadResolveSource m
MonadResolveSource m,
HasCacheStaticConfig m
) =>
(ServerConfigCtx, Inc.Dependency Metadata, Inc.Dependency InvalidationKeys, Maybe StoredIntrospection) `arr` BuildOutputs
buildAndCollectInfo = proc (serverConfigCtx, metadataDep, invalidationKeys, storedIntrospection) -> do
(CacheDynamicConfig, Inc.Dependency Metadata, Inc.Dependency InvalidationKeys, Maybe StoredIntrospection) `arr` BuildOutputs
buildAndCollectInfo = proc (dynamicConfig, metadataDep, invalidationKeys, storedIntrospection) -> do
sources <- Inc.dependOn -< Inc.selectD #_metaSources metadataDep
remoteSchemas <- Inc.dependOn -< Inc.selectD #_metaRemoteSchemas metadataDep
customTypes <- Inc.dependOn -< Inc.selectD #_metaCustomTypes metadataDep
@ -860,8 +870,8 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
let remoteSchemaInvalidationKeys = Inc.selectD #_ikRemoteSchemas invalidationKeys
remoteSchemaMap <- buildRemoteSchemas env -< ((remoteSchemaInvalidationKeys, orderedRoles, fmap encJToLBS . siRemotes <$> storedIntrospection), OMap.elems remoteSchemas)
let remoteSchemaCtxMap = M.map fst remoteSchemaMap
!defaultNC = _sccDefaultNamingConvention serverConfigCtx
!isNamingConventionEnabled = EFNamingConventions `elem` (_sccExperimentalFeatures serverConfigCtx)
!defaultNC = _cdcDefaultNamingConvention dynamicConfig
!isNamingConventionEnabled = EFNamingConventions `elem` (_cdcExperimentalFeatures dynamicConfig)
let backendInvalidationKeys = Inc.selectD #_ikBackends invalidationKeys
backendCache <- resolveBackendCache -< (backendInvalidationKeys, BackendMap.elems backendConfigs)
@ -875,7 +885,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
Inc.keyed
( \_ exists ->
AB.dispatchAnyBackendArrow @BackendMetadata @BackendEventTrigger
( proc (backendInfoAndSourceMetadata :: BackendInfoAndSourceMetadata b, (serverConfigCtx, invalidationKeys, storedIntrospection, defaultNC, isNamingConventionEnabled)) -> do
( proc (backendInfoAndSourceMetadata :: BackendInfoAndSourceMetadata b, (dynamicConfig, invalidationKeys, storedIntrospection, defaultNC, isNamingConventionEnabled)) -> do
let sourceMetadata = _bcasmSourceMetadata backendInfoAndSourceMetadata
sourceName = _smName sourceMetadata
sourceInvalidationsKeys = Inc.selectD #_ikSources invalidationKeys
@ -904,7 +914,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
eventTriggers = map (_tmTable &&& OMap.elems . _tmEventTriggers) tablesMetadata
numEventTriggers = sum $ map (length . snd) eventTriggers
(recreateEventTriggers, sourceCatalogMigrationState) <- initCatalogIfNeeded -< (Proxy :: Proxy b, serverConfigCtx, numEventTriggers > 0, sourceConfig)
(recreateEventTriggers, sourceCatalogMigrationState) <- initCatalogIfNeeded -< (Proxy :: Proxy b, numEventTriggers > 0, sourceConfig)
bindA -< unLogger logger (sourceName, sourceCatalogMigrationState)
@ -915,7 +925,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
(|
Inc.keyed
( \_ (tableCoreInfo, (_, eventTriggerConfs)) ->
buildTableEventTriggers -< (serverConfigCtx, sourceName, sourceConfig, tableCoreInfo, eventTriggerConfs, metadataInvalidationKey, recreateEventTriggers)
buildTableEventTriggers -< (dynamicConfig, sourceName, sourceConfig, tableCoreInfo, eventTriggerConfs, metadataInvalidationKey, recreateEventTriggers)
)
|) (tablesCoreInfo `alignTableMap` mapFromL fst eventTriggers)
@ -926,7 +936,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
PartiallyResolvedSource sourceMetadata sourceConfig source tablesCoreInfo eventTriggerInfoMaps
)
-<
(exists, (serverConfigCtx, invalidationKeys, storedIntrospection, defaultNC, isNamingConventionEnabled))
(exists, (dynamicConfig, invalidationKeys, storedIntrospection, defaultNC, isNamingConventionEnabled))
)
|) (M.fromList $ OMap.toList backendInfoAndSourceMetadata)
let partiallyResolvedSources = catMaybes partiallyResolvedSourcesMaybes
@ -946,7 +956,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
AB.dispatchAnyBackendArrow @BackendMetadata @GetAggregationPredicatesDeps
( proc
( partiallyResolvedSource :: PartiallyResolvedSource b,
(serverConfigCtx, allResolvedSources, remoteSchemaCtxMap, orderedRoles)
(dynamicConfig, allResolvedSources, remoteSchemaCtxMap, orderedRoles)
)
-> do
let PartiallyResolvedSource sourceMetadata sourceConfig introspection tablesInfo eventTriggers = partiallyResolvedSource
@ -954,7 +964,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
so <-
Inc.cache buildSource
-<
( serverConfigCtx,
( dynamicConfig,
allResolvedSources,
sourceMetadata,
sourceConfig,
@ -969,7 +979,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
)
-<
( exists,
(serverConfigCtx, partiallyResolvedSources, remoteSchemaCtxMap, orderedRoles)
(dynamicConfig, partiallyResolvedSources, remoteSchemaCtxMap, orderedRoles)
)
)
|) partiallyResolvedSources
@ -1098,7 +1108,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
mkEventTriggerMetadataObject ::
forall b a c.
Backend b =>
(ServerConfigCtx, a, SourceName, c, TableName b, RecreateEventTriggers, EventTriggerConf b) ->
(CacheDynamicConfig, a, SourceName, c, TableName b, RecreateEventTriggers, EventTriggerConf b) ->
MetadataObject
mkEventTriggerMetadataObject (_, _, source, _, table, _, eventTriggerConf) =
let objectId =
@ -1133,9 +1143,10 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
MonadBaseControl IO m,
MonadReader BuildReason m,
BackendMetadata b,
BackendEventTrigger b
BackendEventTrigger b,
HasCacheStaticConfig m
) =>
( ServerConfigCtx,
( CacheDynamicConfig,
SourceName,
SourceConfig b,
TableCoreInfoG b (ColumnInfo b) (ColumnInfo b),
@ -1144,15 +1155,15 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
RecreateEventTriggers
)
`arr` (EventTriggerInfoMap b)
buildTableEventTriggers = proc (serverConfigCtx, sourceName, sourceConfig, tableInfo, eventTriggerConfs, metadataInvalidationKey, migrationRecreateEventTriggers) ->
buildTableEventTriggers = proc (dynamicConfig, sourceName, sourceConfig, tableInfo, eventTriggerConfs, metadataInvalidationKey, migrationRecreateEventTriggers) ->
buildInfoMap (etcName . (^. _7)) (mkEventTriggerMetadataObject @b) buildEventTrigger
-<
(tableInfo, map (serverConfigCtx,metadataInvalidationKey,sourceName,sourceConfig,_tciName tableInfo,migrationRecreateEventTriggers,) eventTriggerConfs)
(tableInfo, map (dynamicConfig,metadataInvalidationKey,sourceName,sourceConfig,_tciName tableInfo,migrationRecreateEventTriggers,) eventTriggerConfs)
where
buildEventTrigger = proc (tableInfo, (serverConfigCtx, metadataInvalidationKey, source, sourceConfig, table, migrationRecreateEventTriggers, eventTriggerConf)) -> do
buildEventTrigger = proc (tableInfo, (dynamicConfig, metadataInvalidationKey, source, sourceConfig, table, migrationRecreateEventTriggers, eventTriggerConf)) -> do
let triggerName = etcName eventTriggerConf
triggerOnReplication = etcTriggerOnReplication eventTriggerConf
metadataObject = mkEventTriggerMetadataObject @b (serverConfigCtx, metadataInvalidationKey, source, sourceConfig, table, migrationRecreateEventTriggers, eventTriggerConf)
metadataObject = mkEventTriggerMetadataObject @b (dynamicConfig, metadataInvalidationKey, source, sourceConfig, table, migrationRecreateEventTriggers, eventTriggerConf)
schemaObjectId =
SOSourceObj source $
AB.mkAnyBackend $
@ -1169,13 +1180,14 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
withRecordInconsistency
( do
(info, dependencies) <- bindErrorA -< modifyErr (addTableContext @b table . addTriggerContext) $ buildEventTriggerInfo @b env source table eventTriggerConf
staticConfig <- bindA -< askCacheStaticConfig
let isCatalogUpdate =
case buildReason of
CatalogUpdate _ -> True
CatalogSync -> False
tableColumns = M.elems $ _tciFieldInfoMap tableInfo
if ( _sccMaintenanceMode serverConfigCtx == MaintenanceModeDisabled
&& _sccReadOnlyMode serverConfigCtx == ReadOnlyModeDisabled
if ( _cscMaintenanceMode staticConfig == MaintenanceModeDisabled
&& _cscReadOnlyMode staticConfig == ReadOnlyModeDisabled
)
then do
bindA
@ -1187,7 +1199,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
liftEitherM $
createTableEventTrigger
@b
serverConfigCtx
(_cdcSQLGenCtx dynamicConfig)
sourceConfig
table
tableColumns
@ -1199,7 +1211,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
then do
recreateTriggerIfNeeded
-<
( serverConfigCtx,
( dynamicConfig,
table,
tableColumns,
triggerName,
@ -1214,7 +1226,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
bindA
-<
createMissingSQLTriggers
serverConfigCtx
(_cdcSQLGenCtx dynamicConfig)
sourceConfig
table
(tableColumns, _tciPrimaryKey tableInfo)
@ -1234,7 +1246,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
-- computation will not be done again.
Inc.cache
proc
( serverConfigCtx,
( dynamicConfig,
tableName,
tableColumns,
triggerName,
@ -1248,7 +1260,7 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
-< do
liftEitherM $
createTableEventTrigger @b
serverConfigCtx
(_cdcSQLGenCtx dynamicConfig)
sourceConfig
tableName
tableColumns

14
server/src-lib/Hasura/RQL/DDL/Schema/Cache/Common.hs
View File

@ -59,6 +59,7 @@ import Hasura.CustomReturnType.Types (CustomReturnTypeName)
import Hasura.EncJSON
import Hasura.Incremental qualified as Inc
import Hasura.Prelude
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.Column
import Hasura.RQL.Types.Common
@ -79,7 +80,6 @@ import Hasura.SQL.AnyBackend
import Hasura.SQL.Backend
import Hasura.SQL.BackendMap (BackendMap)
import Hasura.SQL.BackendMap qualified as BackendMap
import Hasura.Server.Types
import Hasura.Services
import Hasura.Session
import Network.HTTP.Client.Transformable qualified as HTTP
@ -257,7 +257,8 @@ $(makeLenses ''BuildOutputs)
data CacheBuildParams = CacheBuildParams
{ _cbpManager :: HTTP.Manager,
_cbpPGSourceResolver :: SourceResolver ('Postgres 'Vanilla),
_cbpMSSQLSourceResolver :: SourceResolver 'MSSQL
_cbpMSSQLSourceResolver :: SourceResolver 'MSSQL,
_cbpStaticConfig :: CacheStaticConfig
}
-- | The monad in which @'RebuildableSchemaCache' is being run
@ -273,6 +274,9 @@ newtype CacheBuild a = CacheBuild (ReaderT CacheBuildParams (ExceptT QErr IO) a)
MonadBaseControl IO
)
instance HasCacheStaticConfig CacheBuild where
askCacheStaticConfig = asks _cbpStaticConfig
instance ProvidesNetwork CacheBuild where
askHTTPManager = asks _cbpManager
@ -294,7 +298,8 @@ runCacheBuildM ::
( MonadIO m,
MonadError QErr m,
MonadResolveSource m,
ProvidesNetwork m
ProvidesNetwork m,
HasCacheStaticConfig m
) =>
CacheBuild a ->
m a
@ -304,12 +309,13 @@ runCacheBuildM m = do
<$> askHTTPManager
<*> getPGSourceResolver
<*> getMSSQLSourceResolver
<*> askCacheStaticConfig
runCacheBuild params m
data RebuildableSchemaCache = RebuildableSchemaCache
{ lastBuiltSchemaCache :: SchemaCache,
_rscInvalidationMap :: InvalidationKeys,
_rscRebuild :: Inc.Rule (ReaderT BuildReason CacheBuild) (MetadataWithResourceVersion, ServerConfigCtx, InvalidationKeys, Maybe StoredIntrospection) SchemaCache
_rscRebuild :: Inc.Rule (ReaderT BuildReason CacheBuild) (MetadataWithResourceVersion, CacheDynamicConfig, InvalidationKeys, Maybe StoredIntrospection) SchemaCache
}
bindErrorA ::

70
server/src-lib/Hasura/RQL/DDL/Schema/Cache/Config.hs Normal file
View File

@ -0,0 +1,70 @@
module Hasura.RQL.DDL.Schema.Cache.Config
( -- * static config
CacheStaticConfig (..),
HasCacheStaticConfig (..),
-- * dynamic config
CacheDynamicConfig (..),
)
where
import Hasura.GraphQL.Schema.NamingCase (NamingCase)
import Hasura.GraphQL.Schema.Options qualified as Options
import Hasura.Prelude
import Hasura.RQL.Types.Common (SQLGenCtx)
import Hasura.RQL.Types.Metadata (MetadataDefaults)
import Hasura.Server.Types
--------------------------------------------------------------------------------
-- static config
-- | This type aggregates all of the "static" configuration of the cache build.
--
-- Static arguments are the ones that will not change during the execution of
-- the engine. They are a subset of the environment of the engine (see 'AppEnv'
-- and Note [Hasura Application State] for more information).
--
-- While 'AppEnv' has access to the union of *all* the static configuration of
-- the engine, more specific parts of the code should avoid relying directly on
-- it to avoid being tied to unrelated parts of the codebase. (See FIXME).
data CacheStaticConfig = CacheStaticConfig
{ _cscMaintenanceMode :: MaintenanceMode (),
_cscEventingMode :: EventingMode,
_cscReadOnlyMode :: ReadOnlyMode,
_cscCheckFeatureFlag :: CheckFeatureFlag
}
class Monad m => HasCacheStaticConfig m where
askCacheStaticConfig :: m CacheStaticConfig
instance HasCacheStaticConfig m => HasCacheStaticConfig (ReaderT r m) where
askCacheStaticConfig = lift askCacheStaticConfig
instance HasCacheStaticConfig m => HasCacheStaticConfig (ExceptT e m) where
askCacheStaticConfig = lift askCacheStaticConfig
instance HasCacheStaticConfig m => HasCacheStaticConfig (StateT s m) where
askCacheStaticConfig = lift askCacheStaticConfig
--------------------------------------------------------------------------------
-- dynamic config
-- | This type aggregates all of the "dynamic" configuration of the cache build.
--
-- Dynamic arguments are the ones that might change during the execution of the
-- engine. They are a subset of the 'AppContext' (see
-- Note [Hasura Application State] for more information).
--
-- While 'AppContext' has access to the union of *all* the dynamic configuration
-- of the engine, more specific parts of the code should avoid relying directly
-- on it to avoid being tied to unrelated parts of the codebase. (See FIXME).
data CacheDynamicConfig = CacheDynamicConfig
{ _cdcFunctionPermsCtx :: Options.InferFunctionPermissions,
_cdcRemoteSchemaPermsCtx :: Options.RemoteSchemaPermissions,
_cdcSQLGenCtx :: SQLGenCtx,
_cdcExperimentalFeatures :: HashSet ExperimentalFeature,
_cdcDefaultNamingConvention :: NamingCase,
_cdcMetadataDefaults :: MetadataDefaults,
_cdcApolloFederationStatus :: ApolloFederationStatus
}
deriving (Eq)

7
server/src-lib/Hasura/RQL/DML/Delete.hs
View File

@ -29,7 +29,6 @@ import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Metadata
import Hasura.RQL.Types.SchemaCache
import Hasura.SQL.Backend
import Hasura.Server.Types
import Hasura.Session
import Hasura.Tracing qualified as Tracing
@ -109,17 +108,17 @@ runDelete ::
( QErrM m,
UserInfoM m,
CacheRM m,
HasServerConfigCtx m,
MonadIO m,
Tracing.MonadTrace m,
MonadBaseControl IO m,
MetadataM m
) =>
SQLGenCtx ->
DeleteQuery ->
m EncJSON
runDelete q = do
runDelete sqlGen q = do
sourceConfig <- askSourceConfig @('Postgres 'Vanilla) (doSource q)
strfyNum <- stringifyNum . _sccSQLGenCtx <$> askServerConfigCtx
let strfyNum = stringifyNum sqlGen
userInfo <- askUserInfo
validateDeleteQ q
>>= runTxWithCtx (_pscExecCtx sourceConfig) (Tx PG.ReadWrite Nothing) LegacyRQLQuery

7
server/src-lib/Hasura/RQL/DML/Insert.hs
View File

@ -29,7 +29,6 @@ import Hasura.RQL.Types.Metadata
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.Table
import Hasura.SQL.Backend
import Hasura.Server.Types
import Hasura.Session
import Hasura.Tracing qualified as Tracing
@ -243,19 +242,19 @@ runInsert ::
( QErrM m,
UserInfoM m,
CacheRM m,
HasServerConfigCtx m,
MonadIO m,
Tracing.MonadTrace m,
MonadBaseControl IO m,
MetadataM m
) =>
SQLGenCtx ->
InsertQuery ->
m EncJSON
runInsert q = do
runInsert sqlGen q = do
sourceConfig <- askSourceConfig @('Postgres 'Vanilla) (iqSource q)
userInfo <- askUserInfo
res <- convInsQ q
strfyNum <- stringifyNum . _sccSQLGenCtx <$> askServerConfigCtx
let strfyNum = stringifyNum sqlGen
runTxWithCtx (_pscExecCtx sourceConfig) (Tx PG.ReadWrite Nothing) LegacyRQLQuery $
flip runReaderT emptyQueryTagsComment $
execInsertQuery strfyNum Nothing userInfo res

4
server/src-lib/Hasura/RQL/DML/Internal.hs
View File

@ -55,7 +55,6 @@ import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.Table
import Hasura.SQL.Backend
import Hasura.SQL.Types
import Hasura.Server.Types
import Hasura.Session
newtype DMLP1T m a = DMLP1T {unDMLP1T :: StateT (DS.Seq PG.PrepArg) m a}
@ -69,8 +68,7 @@ newtype DMLP1T m a = DMLP1T {unDMLP1T :: StateT (DS.Seq PG.PrepArg) m a}
TableCoreInfoRM b,
TableInfoRM b,
CacheRM,
UserInfoM,
HasServerConfigCtx
UserInfoM
)
runDMLP1T :: DMLP1T m a -> m (a, DS.Seq PG.PrepArg)

40
server/src-lib/Hasura/RQL/DML/Select.hs
View File

@ -31,7 +31,6 @@ import Hasura.RQL.Types.Relationships.Local
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.Table
import Hasura.SQL.Backend
import Hasura.Server.Types
import Hasura.Session
import Hasura.Tracing qualified as Tracing
@ -174,9 +173,9 @@ convOrderByElem sessVarBldr (flds, spi) = \case
convSelectQ ::
( UserInfoM m,
QErrM m,
TableInfoRM ('Postgres 'Vanilla) m,
HasServerConfigCtx m
TableInfoRM ('Postgres 'Vanilla) m
) =>
SQLGenCtx ->
TableName ('Postgres 'Vanilla) ->
FieldInfoMap (FieldInfo ('Postgres 'Vanilla)) -> -- Table information of current table
SelPermInfo ('Postgres 'Vanilla) -> -- Additional select permission info
@ -184,7 +183,7 @@ convSelectQ ::
SessionVariableBuilder m ->
ValueParser ('Postgres 'Vanilla) m S.SQLExp ->
m (AnnSimpleSelect ('Postgres 'Vanilla))
convSelectQ table fieldInfoMap selPermInfo selQ sessVarBldr prepValBldr = do
convSelectQ sqlGen table fieldInfoMap selPermInfo selQ sessVarBldr prepValBldr = do
-- Convert where clause
wClause <- forM (sqWhere selQ) $ \boolExp ->
withPathK "where" $
@ -200,6 +199,7 @@ convSelectQ table fieldInfoMap selPermInfo selQ sessVarBldr prepValBldr = do
(ECRel relName mAlias relSelQ) -> do
annRel <-
convExtRel
sqlGen
fieldInfoMap
relName
mAlias
@ -230,8 +230,7 @@ convSelectQ table fieldInfoMap selPermInfo selQ sessVarBldr prepValBldr = do
let tabFrom = FromTable table
tabPerm = TablePerm resolvedSelFltr mPermLimit
tabArgs = SelectArgs wClause annOrdByM mQueryLimit (fromIntegral <$> mQueryOffset) Nothing
strfyNum <- stringifyNum . _sccSQLGenCtx <$> askServerConfigCtx
strfyNum = stringifyNum sqlGen
pure $ AnnSelectG annFlds tabFrom tabPerm tabArgs strfyNum Nothing
where
mQueryOffset = sqOffset selQ
@ -254,9 +253,9 @@ convExtSimple fieldInfoMap selPermInfo pgCol = do
convExtRel ::
( UserInfoM m,
QErrM m,
TableInfoRM ('Postgres 'Vanilla) m,
HasServerConfigCtx m
TableInfoRM ('Postgres 'Vanilla) m
) =>
SQLGenCtx ->
FieldInfoMap (FieldInfo ('Postgres 'Vanilla)) ->
RelName ->
Maybe RelName ->
@ -264,14 +263,14 @@ convExtRel ::
SessionVariableBuilder m ->
ValueParser ('Postgres 'Vanilla) m S.SQLExp ->
m (Either (ObjectRelationSelect ('Postgres 'Vanilla)) (ArraySelect ('Postgres 'Vanilla)))
convExtRel fieldInfoMap relName mAlias selQ sessVarBldr prepValBldr = do
convExtRel sqlGen fieldInfoMap relName mAlias selQ sessVarBldr prepValBldr = do
-- Point to the name key
relInfo <-
withPathK "name" $
askRelType fieldInfoMap relName pgWhenRelErr
let (RelInfo _ relTy colMapping relTab _ _) = relInfo
(relCIM, relSPI) <- fetchRelDet relName relTab
annSel <- convSelectQ relTab relCIM relSPI selQ sessVarBldr prepValBldr
annSel <- convSelectQ sqlGen relTab relCIM relSPI selQ sessVarBldr prepValBldr
case relTy of
ObjRel -> do
when misused $ throw400 UnexpectedPayload objRelMisuseMsg
@ -304,20 +303,20 @@ convExtRel fieldInfoMap relName mAlias selQ sessVarBldr prepValBldr = do
convSelectQuery ::
( UserInfoM m,
QErrM m,
TableInfoRM ('Postgres 'Vanilla) m,
HasServerConfigCtx m
TableInfoRM ('Postgres 'Vanilla) m
) =>
SQLGenCtx ->
SessionVariableBuilder m ->
ValueParser ('Postgres 'Vanilla) m S.SQLExp ->
SelectQuery ->
m (AnnSimpleSelect ('Postgres 'Vanilla))
convSelectQuery sessVarBldr prepArgBuilder (DMLQuery _ qt selQ) = do
convSelectQuery sqlGen sessVarBldr prepArgBuilder (DMLQuery _ qt selQ) = do
tabInfo <- withPathK "table" $ askTableInfoSource qt
selPermInfo <- askSelPermInfo tabInfo
let fieldInfo = _tciFieldInfoMap $ _tiCoreInfo tabInfo
extSelQ <- resolveStar fieldInfo selPermInfo selQ
validateHeaders $ spiRequiredHeaders selPermInfo
convSelectQ qt fieldInfo selPermInfo extSelQ sessVarBldr prepArgBuilder
convSelectQ sqlGen qt fieldInfo selPermInfo extSelQ sessVarBldr prepArgBuilder
selectP2 :: JsonAggSelect -> (AnnSimpleSelect ('Postgres 'Vanilla), DS.Seq PG.PrepArg) -> PG.TxE QErr EncJSON
selectP2 jsonAggSelect (sel, p) =
@ -330,15 +329,16 @@ selectP2 jsonAggSelect (sel, p) =
mkSQLSelect jsonAggSelect sel
phaseOne ::
(QErrM m, UserInfoM m, CacheRM m, HasServerConfigCtx m) =>
(QErrM m, UserInfoM m, CacheRM m) =>
SQLGenCtx ->
SelectQuery ->
m (AnnSimpleSelect ('Postgres 'Vanilla), DS.Seq PG.PrepArg)
phaseOne query = do
phaseOne sqlGen query = do
let sourceName = getSourceDMLQuery query
tableCache :: TableCache ('Postgres 'Vanilla) <- fold <$> askTableCache sourceName
flip runTableCacheRT tableCache $
runDMLP1T $
convSelectQuery sessVarFromCurrentSetting (valueParserWithCollectableType binRHSBuilder) query
convSelectQuery sqlGen sessVarFromCurrentSetting (valueParserWithCollectableType binRHSBuilder) query
phaseTwo :: (MonadTx m) => (AnnSimpleSelect ('Postgres 'Vanilla), DS.Seq PG.PrepArg) -> m EncJSON
phaseTwo =
@ -348,14 +348,14 @@ runSelect ::
( QErrM m,
UserInfoM m,
CacheRM m,
HasServerConfigCtx m,
MonadIO m,
MonadBaseControl IO m,
Tracing.MonadTrace m,
MetadataM m
) =>
SQLGenCtx ->
SelectQuery ->
m EncJSON
runSelect q = do
runSelect sqlGen q = do
sourceConfig <- askSourceConfig @('Postgres 'Vanilla) (getSourceDMLQuery q)
phaseOne q >>= runTxWithCtx (_pscExecCtx sourceConfig) (Tx PG.ReadOnly Nothing) LegacyRQLQuery . phaseTwo
phaseOne sqlGen q >>= runTxWithCtx (_pscExecCtx sourceConfig) (Tx PG.ReadOnly Nothing) LegacyRQLQuery . phaseTwo

7
server/src-lib/Hasura/RQL/DML/Update.hs
View File

@ -34,7 +34,6 @@ import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.Table
import Hasura.SQL.Backend
import Hasura.SQL.Types
import Hasura.Server.Types
import Hasura.Session
import Hasura.Tracing qualified as Tracing
@ -224,18 +223,18 @@ runUpdate ::
( QErrM m,
UserInfoM m,
CacheRM m,
HasServerConfigCtx m,
MonadBaseControl IO m,
MonadIO m,
Tracing.MonadTrace m,
MetadataM m
) =>
SQLGenCtx ->
UpdateQuery ->
m EncJSON
runUpdate q = do
runUpdate sqlGen q = do
sourceConfig <- askSourceConfig @('Postgres 'Vanilla) (uqSource q)
userInfo <- askUserInfo
strfyNum <- stringifyNum . _sccSQLGenCtx <$> askServerConfigCtx
let strfyNum = stringifyNum sqlGen
validateUpdateQuery q
>>= runTxWithCtx (_pscExecCtx sourceConfig) (Tx PG.ReadWrite Nothing) LegacyRQLQuery
. flip runReaderT emptyQueryTagsComment

6
server/src-lib/Hasura/RQL/Types/Eventing/Backend.hs
View File

@ -19,7 +19,7 @@ import Hasura.RQL.Types.Eventing
import Hasura.RQL.Types.Source
import Hasura.RQL.Types.Table (PrimaryKey)
import Hasura.SQL.Backend
import Hasura.Server.Types (MaintenanceMode, ServerConfigCtx)
import Hasura.Server.Types (MaintenanceMode)
import Hasura.Session (UserInfo)
import Hasura.Tracing qualified as Tracing
@ -188,7 +188,7 @@ class Backend b => BackendEventTrigger (b :: BackendType) where
-- exist then it will create it.
createMissingSQLTriggers ::
(MonadIO m, MonadError QErr m, MonadBaseControl IO m, Backend b) =>
ServerConfigCtx ->
SQLGenCtx ->
SourceConfig b ->
TableName b ->
([ColumnInfo b], Maybe (PrimaryKey b (ColumnInfo b))) ->
@ -199,7 +199,7 @@ class Backend b => BackendEventTrigger (b :: BackendType) where
createTableEventTrigger ::
(MonadBaseControl IO m, MonadIO m, MonadError QErr m) =>
ServerConfigCtx ->
SQLGenCtx ->
SourceConfig b ->
TableName b ->
[ColumnInfo b] ->

3
server/src-lib/Hasura/RQL/Types/SchemaCache.hs
View File

@ -161,7 +161,6 @@ import Hasura.SQL.Backend
import Hasura.SQL.BackendMap (BackendMap)
import Hasura.SQL.BackendMap qualified as BackendMap
import Hasura.SQL.Tag (HasTag (backendTag), reify)
import Hasura.Server.Types
import Hasura.Session
import Hasura.Tracing (TraceT)
import Language.GraphQL.Draft.Syntax qualified as G
@ -651,7 +650,7 @@ instance (TableInfoRM b m) => TableInfoRM b (TraceT m) where
newtype TableCacheRT b m a = TableCacheRT {runTableCacheRT :: TableCache b -> m a}
deriving
(Functor, Applicative, Monad, MonadIO, MonadError e, MonadState s, MonadWriter w, Postgres.MonadTx, UserInfoM, HasServerConfigCtx)
(Functor, Applicative, Monad, MonadIO, MonadError e, MonadState s, MonadWriter w, Postgres.MonadTx, UserInfoM)
via (ReaderT (TableCache b) m)
deriving (MonadTrans) via (ReaderT (TableCache b))

8
server/src-lib/Hasura/RQL/Types/SchemaCache/Build.hs
View File

@ -59,7 +59,7 @@ import Hasura.RQL.Types.Metadata.Object
import Hasura.RQL.Types.QueryCollection
import Hasura.RQL.Types.SchemaCache
import Hasura.RemoteSchema.Metadata (RemoteSchemaName)
import Hasura.Server.Types
import Hasura.Server.Init.FeatureFlag (HasFeatureFlagChecker)
import Hasura.Services.Network
import Hasura.Session
import Hasura.Tracing (TraceT)
@ -239,7 +239,8 @@ newtype MetadataT m a = MetadataT {unMetadataT :: StateT Metadata m a}
Tracing.MonadTrace,
MonadBase b,
MonadBaseControl b,
ProvidesNetwork
ProvidesNetwork,
HasFeatureFlagChecker
)
deriving anyclass (MonadQueryTags)
@ -250,9 +251,6 @@ instance (Monad m) => MetadataM (MetadataT m) where
instance (UserInfoM m) => UserInfoM (MetadataT m) where
askUserInfo = lift askUserInfo
instance HasServerConfigCtx m => HasServerConfigCtx (MetadataT m) where
askServerConfigCtx = lift askServerConfigCtx
-- | @runMetadataT@ puts a stateful metadata in scope. @MetadataDefaults@ is
-- provided so that it can be considered from the --metadataDefaults arguments.
runMetadataT :: Metadata -> MetadataDefaults -> MetadataT m a -> m (a, Metadata)

6
server/src-lib/Hasura/RemoteSchema/MetadataAPI/Permission.hs
View File

@ -23,7 +23,6 @@ import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.SchemaCache.Build
import Hasura.RemoteSchema.Metadata
import Hasura.RemoteSchema.SchemaCache.Permission
import Hasura.Server.Types
import Hasura.Session
data AddRemoteSchemaPermission = AddRemoteSchemaPermission
@ -51,14 +50,13 @@ $(J.deriveJSON hasuraJSON ''DropRemoteSchemaPermissions)
runAddRemoteSchemaPermissions ::
( QErrM m,
CacheRWM m,
HasServerConfigCtx m,
MetadataM m
) =>
Options.RemoteSchemaPermissions ->
AddRemoteSchemaPermission ->
m EncJSON
runAddRemoteSchemaPermissions q = do
runAddRemoteSchemaPermissions remoteSchemaPermsCtx q = do
metadata <- getMetadata
remoteSchemaPermsCtx <- _sccRemoteSchemaPermsCtx <$> askServerConfigCtx
unless (remoteSchemaPermsCtx == Options.EnableRemoteSchemaPermissions) $ do
throw400 ConstraintViolation $
"remote schema permissions can only be added when "

44
server/src-lib/Hasura/Server/API/Metadata.hs
View File

@ -23,6 +23,7 @@ import Hasura.Base.Error
import Hasura.CustomReturnType.API qualified as CustomReturnType
import Hasura.EncJSON
import Hasura.Function.API qualified as Functions
import Hasura.GraphQL.Schema.Options qualified as Options
import Hasura.Logging qualified as L
import Hasura.LogicalModel.API qualified as LogicalModels
import Hasura.Metadata.Class
@ -50,6 +51,7 @@ import Hasura.RQL.DDL.Relationship.Suggest
import Hasura.RQL.DDL.RemoteRelationship
import Hasura.RQL.DDL.ScheduledTrigger
import Hasura.RQL.DDL.Schema
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.DDL.Schema.Source
import Hasura.RQL.DDL.SourceKinds
import Hasura.RQL.DDL.Webhook.Transform.Validation
@ -79,6 +81,7 @@ import Hasura.SQL.AnyBackend
import Hasura.SQL.Backend
import Hasura.Server.API.Backend
import Hasura.Server.API.Instances ()
import Hasura.Server.Init.FeatureFlag (HasFeatureFlagChecker)
import Hasura.Server.Logging (SchemaSyncLog (..), SchemaSyncThreadType (TTMetadataApi))
import Hasura.Server.Types
import Hasura.Server.Utils (APIVersion (..))
@ -388,6 +391,8 @@ runMetadataQuery ::
MonadError QErr m,
MonadBaseControl IO m,
HasAppEnv m,
HasCacheStaticConfig m,
HasFeatureFlagChecker m,
Tracing.MonadTrace m,
MonadMetadataStorage m,
MonadResolveSource m,
@ -401,7 +406,7 @@ runMetadataQuery ::
RQLMetadata ->
m (EncJSON, RebuildableSchemaCache)
runMetadataQuery appContext schemaCache RQLMetadata {..} = do
appEnv@AppEnv {..} <- askAppEnv
AppEnv {..} <- askAppEnv
let logger = _lsLogger appEnvLoggers
MetadataWithResourceVersion metadata currentResourceVersion <- Tracing.newSpan "fetchMetadata" $ liftEitherM fetchMetadata
let exportsMetadata = \case
@ -427,13 +432,18 @@ runMetadataQuery appContext schemaCache RQLMetadata {..} = do
if (exportsMetadata _rqlMetadata || queryModifiesMetadata _rqlMetadata)
then emptyMetadataDefaults
else acMetadataDefaults appContext
serverConfigCtx = buildServerConfigCtx appEnv appContext
dynamicConfig = buildCacheDynamicConfig appContext
((r, modMetadata), modSchemaCache, cacheInvalidations) <-
runMetadataQueryM (acEnvironment appContext) currentResourceVersion _rqlMetadata
runMetadataQueryM
(acEnvironment appContext)
appEnvCheckFeatureFlag
(acRemoteSchemaPermsCtx appContext)
currentResourceVersion
_rqlMetadata
-- TODO: remove this straight runReaderT that provides no actual new info
& flip runReaderT logger
& runMetadataT metadata metadataDefaults
& runCacheRWT serverConfigCtx schemaCache
& runCacheRWT dynamicConfig schemaCache
-- set modified metadata in storage
if queryModifiesMetadata _rqlMetadata
then case (appEnvEnableMaintenanceMode, appEnvEnableReadOnlyMode) of
@ -464,7 +474,7 @@ runMetadataQuery appContext schemaCache RQLMetadata {..} = do
(_, modSchemaCache', _) <-
Tracing.newSpan "setMetadataResourceVersionInSchemaCache" $
setMetadataResourceVersionInSchemaCache newResourceVersion
& runCacheRWT serverConfigCtx modSchemaCache
& runCacheRWT dynamicConfig modSchemaCache
pure (r, modSchemaCache')
(MaintenanceModeEnabled (), ReadOnlyModeDisabled) ->
@ -607,25 +617,27 @@ runMetadataQueryM ::
UserInfoM m,
MetadataM m,
MonadMetadataStorage m,
HasServerConfigCtx m,
MonadReader r m,
Has (L.Logger L.Hasura) r,
MonadError QErr m,
MonadEventLogCleanup m,
ProvidesHasuraServices m,
MonadGetApiTimeLimit m
MonadGetApiTimeLimit m,
HasFeatureFlagChecker m
) =>
Env.Environment ->
CheckFeatureFlag ->
Options.RemoteSchemaPermissions ->
MetadataResourceVersion ->
RQLMetadataRequest ->
m EncJSON
runMetadataQueryM env currentResourceVersion =
runMetadataQueryM env checkFeatureFlag remoteSchemaPerms currentResourceVersion =
withPathK "args" . \case
-- NOTE: This is a good place to install tracing, since it's involved in
-- the recursive case via "bulk":
RMV1 q ->
Tracing.newSpan ("v1 " <> T.pack (constrName q)) $
runMetadataQueryV1M env currentResourceVersion q
runMetadataQueryV1M env checkFeatureFlag remoteSchemaPerms currentResourceVersion q
RMV2 q ->
Tracing.newSpan ("v2 " <> T.pack (constrName q)) $
runMetadataQueryV2M currentResourceVersion q
@ -639,19 +651,21 @@ runMetadataQueryV1M ::
UserInfoM m,
MetadataM m,
MonadMetadataStorage m,
HasServerConfigCtx m,
MonadReader r m,
Has (L.Logger L.Hasura) r,
MonadError QErr m,
MonadEventLogCleanup m,
ProvidesHasuraServices m,
MonadGetApiTimeLimit m
MonadGetApiTimeLimit m,
HasFeatureFlagChecker m
) =>
Env.Environment ->
CheckFeatureFlag ->
Options.RemoteSchemaPermissions ->
MetadataResourceVersion ->
RQLMetadataV1 ->
m EncJSON
runMetadataQueryV1M env currentResourceVersion = \case
runMetadataQueryV1M env checkFeatureFlag remoteSchemaPerms currentResourceVersion = \case
RMAddSource q -> dispatchMetadata (runAddSource env) q
RMDropSource q -> runDropSource q
RMRenameSource q -> runRenameSource q
@ -718,7 +732,7 @@ runMetadataQueryV1M env currentResourceVersion = \case
RMRemoveRemoteSchema q -> runRemoveRemoteSchema q
RMReloadRemoteSchema q -> runReloadRemoteSchema q
RMIntrospectRemoteSchema q -> runIntrospectRemoteSchema q
RMAddRemoteSchemaPermissions q -> runAddRemoteSchemaPermissions q
RMAddRemoteSchemaPermissions q -> runAddRemoteSchemaPermissions remoteSchemaPerms q
RMDropRemoteSchemaPermissions q -> runDropRemoteSchemaPermissions q
RMCreateRemoteSchemaRemoteRelationship q -> runCreateRemoteSchemaRemoteRelationship q
RMUpdateRemoteSchemaRemoteRelationship q -> runUpdateRemoteSchemaRemoteRelationship q
@ -790,8 +804,8 @@ runMetadataQueryV1M env currentResourceVersion = \case
RMSetQueryTagsConfig q -> runSetQueryTagsConfig q
RMSetOpenTelemetryConfig q -> runSetOpenTelemetryConfig q
RMSetOpenTelemetryStatus q -> runSetOpenTelemetryStatus q
RMGetFeatureFlag q -> runGetFeatureFlag q
RMBulk q -> encJFromList <$> indexedMapM (runMetadataQueryM env currentResourceVersion) q
RMGetFeatureFlag q -> runGetFeatureFlag checkFeatureFlag q
RMBulk q -> encJFromList <$> indexedMapM (runMetadataQueryM env checkFeatureFlag remoteSchemaPerms currentResourceVersion) q
where
dispatch ::
(forall b. Backend b => i b -> a) ->

26
server/src-lib/Hasura/Server/API/Query.hs
View File

@ -38,6 +38,7 @@ import Hasura.RQL.DDL.Relationship.Rename
import Hasura.RQL.DDL.RemoteRelationship
import Hasura.RQL.DDL.ScheduledTrigger
import Hasura.RQL.DDL.Schema
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.DML.Count
import Hasura.RQL.DML.Delete
import Hasura.RQL.DML.Insert
@ -180,6 +181,7 @@ runQuery ::
( MonadIO m,
MonadError QErr m,
HasAppEnv m,
HasCacheStaticConfig m,
Tracing.MonadTrace m,
MonadBaseControl IO m,
MonadMetadataStorage m,
@ -195,7 +197,7 @@ runQuery ::
RQLQuery ->
m (EncJSON, RebuildableSchemaCache)
runQuery appContext sc query = do
appEnv@AppEnv {..} <- askAppEnv
AppEnv {..} <- askAppEnv
let logger = _lsLogger appEnvLoggers
when ((appEnvEnableReadOnlyMode == ReadOnlyModeEnabled) && queryModifiesUserDB query) $
throw400 NotSupported "Cannot run write queries when read-only mode is enabled"
@ -207,15 +209,15 @@ runQuery appContext sc query = do
if (exportsMetadata query)
then emptyMetadataDefaults
else acMetadataDefaults appContext
serverConfigCtx = buildServerConfigCtx appEnv appContext
dynamicConfig = buildCacheDynamicConfig appContext
MetadataWithResourceVersion metadata currentResourceVersion <- liftEitherM fetchMetadata
((result, updatedMetadata), updatedCache, invalidations) <-
runQueryM (acEnvironment appContext) query
runQueryM (acEnvironment appContext) (acSQLGenCtx appContext) query
-- TODO: remove this straight runReaderT that provides no actual new info
& flip runReaderT logger
& runMetadataT metadata metadataDefaults
& runCacheRWT serverConfigCtx sc
& runCacheRWT dynamicConfig sc
when (queryModifiesSchemaCache query) $ do
case appEnvEnableMaintenanceMode of
MaintenanceModeDisabled -> do
@ -391,7 +393,6 @@ runQueryM ::
UserInfoM m,
MonadBaseControl IO m,
MonadIO m,
HasServerConfigCtx m,
Tracing.MonadTrace m,
MetadataM m,
MonadMetadataStorage m,
@ -404,9 +405,10 @@ runQueryM ::
MonadGetApiTimeLimit m
) =>
Env.Environment ->
SQLGenCtx ->
RQLQuery ->
m EncJSON
runQueryM env rq = withPathK "args" $ case rq of
runQueryM env sqlGen rq = withPathK "args" $ case rq of
RQV1 q -> runQueryV1M q
RQV2 q -> runQueryV2M q
where
@ -436,10 +438,10 @@ runQueryM env rq = withPathK "args" $ case rq of
RQSetPermissionComment q -> runSetPermComment q
RQGetInconsistentMetadata q -> runGetInconsistentMetadata q
RQDropInconsistentMetadata q -> runDropInconsistentMetadata q
RQInsert q -> runInsert q
RQSelect q -> runSelect q
RQUpdate q -> runUpdate q
RQDelete q -> runDelete q
RQInsert q -> runInsert sqlGen q
RQSelect q -> runSelect sqlGen q
RQUpdate q -> runUpdate sqlGen q
RQDelete q -> runDelete sqlGen q
RQCount q -> runCount q
RQAddRemoteSchema q -> runAddRemoteSchema env q
RQUpdateRemoteSchema q -> runUpdateRemoteSchema env q
@ -475,9 +477,9 @@ runQueryM env rq = withPathK "args" $ case rq of
RQCreateRestEndpoint q -> runCreateEndpoint q
RQDropRestEndpoint q -> runDropEndpoint q
RQDumpInternalState q -> runDumpInternalState q
RQRunSql q -> runRunSQL @'Vanilla q
RQRunSql q -> runRunSQL @'Vanilla sqlGen q
RQSetCustomTypes q -> runSetCustomTypes q
RQBulk qs -> encJFromList <$> indexedMapM (runQueryM env) qs
RQBulk qs -> encJFromList <$> indexedMapM (runQueryM env sqlGen) qs
runQueryV2M = \case
RQV2TrackTable q -> runTrackTableV2Q q

35
server/src-lib/Hasura/Server/API/V2Query.hs
View File

@ -13,7 +13,6 @@ import Control.Lens (preview, _Right)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson
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
@ -29,6 +28,7 @@ import Hasura.Metadata.Class
import Hasura.Prelude
import Hasura.QueryTags
import Hasura.RQL.DDL.Schema
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.DML.Count
import Hasura.RQL.DML.Delete
import Hasura.RQL.DML.Insert
@ -41,6 +41,7 @@ import Hasura.RQL.DML.Types
UpdateQuery,
)
import Hasura.RQL.DML.Update
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Metadata
import Hasura.RQL.Types.SchemaCache (MetadataWithResourceVersion (MetadataWithResourceVersion))
import Hasura.RQL.Types.SchemaCache.Build
@ -107,6 +108,7 @@ runQuery ::
MonadBaseControl IO m,
MonadError QErr m,
HasAppEnv m,
HasCacheStaticConfig m,
Tracing.MonadTrace m,
MonadMetadataStorage m,
MonadResolveSource m,
@ -119,17 +121,17 @@ runQuery ::
RQLQuery ->
m (EncJSON, RebuildableSchemaCache)
runQuery appContext schemaCache rqlQuery = do
appEnv@AppEnv {..} <- askAppEnv
AppEnv {..} <- askAppEnv
when ((appEnvEnableReadOnlyMode == ReadOnlyModeEnabled) && queryModifiesUserDB rqlQuery) $
throw400 NotSupported "Cannot run write queries when read-only mode is enabled"
let serverConfigCtx = buildServerConfigCtx appEnv appContext
let dynamicConfig = buildCacheDynamicConfig appContext
MetadataWithResourceVersion metadata currentResourceVersion <- Tracing.newSpan "fetchMetadata" $ liftEitherM fetchMetadata
((result, updatedMetadata), updatedCache, invalidations) <-
runQueryM (acEnvironment appContext) rqlQuery
runQueryM (acSQLGenCtx appContext) rqlQuery
-- We can use defaults here unconditionally, since there is no MD export function in V2Query
& runMetadataT metadata (acMetadataDefaults appContext)
& runCacheRWT serverConfigCtx schemaCache
& runCacheRWT dynamicConfig schemaCache
when (queryModifiesSchema rqlQuery) $ do
case appEnvEnableMaintenanceMode of
MaintenanceModeDisabled -> do
@ -170,33 +172,32 @@ runQueryM ::
MonadBaseControl IO m,
UserInfoM m,
CacheRWM m,
HasServerConfigCtx m,
Tracing.MonadTrace m,
MetadataM m,
MonadQueryTags m
) =>
Env.Environment ->
SQLGenCtx ->
RQLQuery ->
m EncJSON
runQueryM env rq = Tracing.newSpan (T.pack $ constrName rq) $ case rq of
RQInsert q -> runInsert q
RQSelect q -> runSelect q
RQUpdate q -> runUpdate q
RQDelete q -> runDelete q
runQueryM sqlGen rq = Tracing.newSpan (T.pack $ constrName rq) $ case rq of
RQInsert q -> runInsert sqlGen q
RQSelect q -> runSelect sqlGen q
RQUpdate q -> runUpdate sqlGen q
RQDelete q -> runDelete sqlGen q
RQCount q -> runCount q
RQRunSql q -> Postgres.runRunSQL @'Vanilla q
RQRunSql q -> Postgres.runRunSQL @'Vanilla sqlGen q
RQMssqlRunSql q -> MSSQL.runSQL q
RQMysqlRunSql q -> MySQL.runSQL q
RQCitusRunSql q -> Postgres.runRunSQL @'Citus q
RQCockroachRunSql q -> Postgres.runRunSQL @'Cockroach q
RQCitusRunSql q -> Postgres.runRunSQL @'Citus sqlGen q
RQCockroachRunSql q -> Postgres.runRunSQL @'Cockroach sqlGen q
RQBigqueryRunSql q -> BigQuery.runSQL q
RQDataConnectorRunSql t q -> DataConnector.runSQL t q
RQBigqueryDatabaseInspection q -> BigQuery.runDatabaseInspection q
RQBulk l -> encJFromList <$> indexedMapM (runQueryM env) l
RQBulk l -> encJFromList <$> indexedMapM (runQueryM sqlGen) l
RQConcurrentBulk l -> do
when (queryModifiesSchema rq) $
throw500 "Only read-only queries are allowed in a concurrent_bulk"
encJFromList <$> mapConcurrently (runQueryM env) l
encJFromList <$> mapConcurrently (runQueryM sqlGen) l
queryModifiesUserDB :: RQLQuery -> Bool
queryModifiesUserDB = \case

11
server/src-lib/Hasura/Server/App.hs
View File

@ -68,6 +68,7 @@ import Hasura.QueryTags
import Hasura.RQL.DDL.ApiLimit (MonadGetApiTimeLimit)
import Hasura.RQL.DDL.EventTrigger (MonadEventLogCleanup)
import Hasura.RQL.DDL.Schema
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.Types.Endpoint as EP
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.Source
@ -134,6 +135,8 @@ newtype Handler m a = Handler (ReaderT HandlerCtx (ExceptT QErr m) a)
MonadError QErr,
MonadTrace,
HasAppEnv,
HasCacheStaticConfig,
HasFeatureFlagChecker,
HasResourceLimits,
MonadResolveSource,
E.MonadGQLExecutionCheck,
@ -423,6 +426,7 @@ v1QueryHandler ::
MonadMetadataStorage m,
MonadResolveSource m,
HasAppEnv m,
HasCacheStaticConfig m,
MonadQueryTags m,
MonadEventLogCleanup m,
ProvidesNetwork m,
@ -457,6 +461,8 @@ v1MetadataHandler ::
MonadMetadataApiAuthorization m,
MonadEventLogCleanup m,
HasAppEnv m,
HasCacheStaticConfig m,
HasFeatureFlagChecker m,
ProvidesNetwork m,
MonadGetApiTimeLimit m,
UserInfoM m
@ -486,6 +492,7 @@ v2QueryHandler ::
MonadMetadataStorage m,
MonadResolveSource m,
HasAppEnv m,
HasCacheStaticConfig m,
MonadQueryTags m,
ProvidesNetwork m,
UserInfoM m
@ -713,6 +720,8 @@ mkWaiApp ::
MonadVersionAPIWithExtraData m,
HttpLog m,
HasAppEnv m,
HasCacheStaticConfig m,
HasFeatureFlagChecker m,
UserAuthentication m,
MonadMetadataApiAuthorization m,
E.MonadGQLExecutionCheck m,
@ -759,6 +768,8 @@ httpApp ::
MonadVersionAPIWithExtraData m,
HttpLog m,
HasAppEnv m,
HasCacheStaticConfig m,
HasFeatureFlagChecker m,
UserAuthentication m,
MonadMetadataApiAuthorization m,
E.MonadGQLExecutionCheck m,

15
server/src-lib/Hasura/Server/Init/FeatureFlag.hs
View File

@ -7,6 +7,7 @@ module Hasura.Server.Init.FeatureFlag
checkFeatureFlag,
Identifier (..),
FeatureFlags (..),
HasFeatureFlagChecker (..),
featureFlags,
logicalModelInterface,
)
@ -59,6 +60,20 @@ featureFlags =
--------------------------------------------------------------------------------
class Monad m => HasFeatureFlagChecker m where
checkFlag :: FeatureFlag -> m Bool
instance HasFeatureFlagChecker m => HasFeatureFlagChecker (ReaderT r m) where
checkFlag = lift . checkFlag
instance HasFeatureFlagChecker m => HasFeatureFlagChecker (ExceptT e m) where
checkFlag = lift . checkFlag
instance HasFeatureFlagChecker m => HasFeatureFlagChecker (StateT s m) where
checkFlag = lift . checkFlag
--------------------------------------------------------------------------------
testFlag :: FeatureFlag
testFlag =
FeatureFlag

10
server/src-lib/Hasura/Server/SchemaUpdate.hs
View File

@ -27,6 +27,7 @@ import Hasura.Logging
import Hasura.Metadata.Class
import Hasura.Prelude
import Hasura.RQL.DDL.Schema (runCacheRWT)
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.DDL.Schema.Catalog
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.SchemaCache.Build
@ -139,6 +140,7 @@ startSchemaSyncListenerThread logger pool instanceId interval metaVersionRef = d
startSchemaSyncProcessorThread ::
( C.ForkableMonadIO m,
HasAppEnv m,
HasCacheStaticConfig m,
MonadMetadataStorage m,
MonadResolveSource m,
ProvidesNetwork m
@ -244,6 +246,7 @@ processor ::
forall m void impl.
( C.ForkableMonadIO m,
HasAppEnv m,
HasCacheStaticConfig m,
MonadMetadataStorage m,
MonadResolveSource m,
ProvidesNetwork m
@ -263,6 +266,7 @@ refreshSchemaCache ::
( MonadIO m,
MonadBaseControl IO m,
HasAppEnv m,
HasCacheStaticConfig m,
MonadMetadataStorage m,
MonadResolveSource m,
ProvidesNetwork m
@ -277,15 +281,15 @@ refreshSchemaCache
appStateRef
threadType
logTVar = do
appEnv@AppEnv {..} <- askAppEnv
AppEnv {..} <- askAppEnv
let logger = _lsLogger appEnvLoggers
respErr <- runExceptT $
withSchemaCacheUpdate appStateRef logger (Just logTVar) $ do
rebuildableCache <- liftIO $ fst <$> getRebuildableSchemaCacheWithVersion appStateRef
appContext <- liftIO $ getAppContext appStateRef
let serverConfigCtx = buildServerConfigCtx appEnv appContext
let dynamicConfig = buildCacheDynamicConfig appContext
(msg, cache, _) <-
runCacheRWT serverConfigCtx rebuildableCache $ do
runCacheRWT dynamicConfig rebuildableCache $ do
schemaCache <- askSchemaCache
let engineResourceVersion = scMetadataResourceVersion schemaCache
unless (engineResourceVersion == resourceVersion) $ do

71
server/src-lib/Hasura/Server/Types.hs
View File

@ -13,10 +13,7 @@ module Hasura.Server.Types
PGVersion (PGVersion),
pgToDbVersion,
RequestId (..),
ServerConfigCtx (..),
HasServerConfigCtx (..),
CheckFeatureFlag (..),
askMetadataDefaults,
getRequestId,
ApolloFederationStatus (..),
isApolloFederationEnabled,
@ -24,14 +21,9 @@ module Hasura.Server.Types
where
import Data.Aeson
import Data.HashSet qualified as Set
import Data.Text (intercalate, unpack)
import Database.PG.Query qualified as PG
import Hasura.GraphQL.Schema.NamingCase
import Hasura.GraphQL.Schema.Options qualified as Options
import Hasura.Prelude hiding (intercalate)
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Metadata (MetadataDefaults)
import Hasura.Server.Init.FeatureFlag (CheckFeatureFlag (..))
import Hasura.Server.Utils
import Network.HTTP.Types qualified as HTTP
@ -141,69 +133,6 @@ data ReadOnlyMode = ReadOnlyModeEnabled | ReadOnlyModeDisabled
data EventingMode = EventingEnabled | EventingDisabled
deriving (Show, Eq)
-- | This type represents an aggregate of different configuration options used
-- throughout the engine. The fields are the union of a subset of 'AppEnv' and a
-- subset of 'AppContext'.
--
-- This type should be considered as deprecated: avoid using it directly when
-- you can use 'AppEnv' or 'AppContext', and avoid using the entirety of it when
-- you only need a subset of the fields. Also avoid adding new fields if
-- possible, but if you do so, make sure to adjust the @Eq@ instance
-- accordingly.
data ServerConfigCtx = ServerConfigCtx
{ _sccFunctionPermsCtx :: Options.InferFunctionPermissions,
_sccRemoteSchemaPermsCtx :: Options.RemoteSchemaPermissions,
_sccSQLGenCtx :: SQLGenCtx,
_sccMaintenanceMode :: MaintenanceMode (),
_sccExperimentalFeatures :: Set.HashSet ExperimentalFeature,
_sccEventingMode :: EventingMode,
_sccReadOnlyMode :: ReadOnlyMode,
-- | stores global default naming convention
_sccDefaultNamingConvention :: NamingCase,
_sccMetadataDefaults :: MetadataDefaults,
_sccCheckFeatureFlag :: CheckFeatureFlag,
_sccApolloFederationStatus :: ApolloFederationStatus
}
-- We are currently using the entire 'ServerConfigCtx' as an input to the schema
-- cache build, and it therefore requires an 'Eq' instance. However, only a few
-- fields will change over time: those coming from the 'AppContext', and not
-- those coming from the 'AppEnv'. Consequently, this instance only checks the
-- relevant fields.
--
-- The way to fix this will be to use a smaller type as the input to the schema
-- build, such as 'AppContext' (or, rather, a relevant subset), on which a
-- "correct" @Eq@ instance can be defined.
instance Eq ServerConfigCtx where
(==) = (==) `on` extractDynamicFields
where
extractDynamicFields ServerConfigCtx {..} =
( _sccFunctionPermsCtx,
_sccRemoteSchemaPermsCtx,
_sccSQLGenCtx,
_sccExperimentalFeatures,
_sccDefaultNamingConvention,
_sccMetadataDefaults,
_sccApolloFederationStatus
)
askMetadataDefaults :: HasServerConfigCtx m => m MetadataDefaults
askMetadataDefaults = do
ServerConfigCtx {_sccMetadataDefaults} <- askServerConfigCtx
pure _sccMetadataDefaults
class (Monad m) => HasServerConfigCtx m where
askServerConfigCtx :: m ServerConfigCtx
instance HasServerConfigCtx m => HasServerConfigCtx (ReaderT r m) where
askServerConfigCtx = lift askServerConfigCtx
instance HasServerConfigCtx m => HasServerConfigCtx (ExceptT e m) where
askServerConfigCtx = lift askServerConfigCtx
instance HasServerConfigCtx m => HasServerConfigCtx (StateT s m) where
askServerConfigCtx = lift askServerConfigCtx
-- | Whether or not to enable apollo federation fields.
data ApolloFederationStatus = ApolloFederationEnabled | ApolloFederationDisabled
deriving stock (Show, Eq, Ord, Generic)

22
server/test-postgres/Main.hs
View File

@ -31,13 +31,13 @@ import Hasura.Logging
import Hasura.Prelude
import Hasura.RQL.DDL.Schema.Cache
import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Metadata (emptyMetadataDefaults)
import Hasura.RQL.Types.ResizePool
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.SchemaCache.Build
import Hasura.Server.Init
import Hasura.Server.Init.FeatureFlag as FF
import Hasura.Server.Metrics (ServerMetricsSpec, createServerMetrics)
import Hasura.Server.Migrate
import Hasura.Server.Prometheus (makeDummyPrometheusMetrics)
@ -107,20 +107,22 @@ main = do
Options.EnableBigQueryStringNumericInput
maintenanceMode = MaintenanceModeDisabled
readOnlyMode = ReadOnlyModeDisabled
serverConfigCtx =
ServerConfigCtx
staticConfig =
CacheStaticConfig
maintenanceMode
EventingEnabled
readOnlyMode
(CheckFeatureFlag $ checkFeatureFlag mempty)
dynamicConfig =
CacheDynamicConfig
Options.InferFunctionPermissions
Options.DisableRemoteSchemaPermissions
sqlGenCtx
maintenanceMode
mempty
EventingEnabled
readOnlyMode
(_default defaultNamingConventionOption)
emptyMetadataDefaults
(CheckFeatureFlag $ FF.checkFeatureFlag mempty)
ApolloFederationDisabled
cacheBuildParams = CacheBuildParams httpManager (mkPgSourceResolver print) mkMSSQLSourceResolver
cacheBuildParams = CacheBuildParams httpManager (mkPgSourceResolver print) mkMSSQLSourceResolver staticConfig
(_appInit, appEnv) <-
lowerManagedT $
@ -145,11 +147,11 @@ main = do
snd
<$> (liftEitherM . runExceptT . _pecRunTx pgContext (PGExecCtxInfo (Tx PG.ReadWrite Nothing) InternalRawQuery))
(migrateCatalog (Just sourceConfig) defaultPostgresExtensionsSchema maintenanceMode =<< liftIO getCurrentTime)
schemaCache <- runCacheBuild cacheBuildParams $ buildRebuildableSchemaCache logger envMap metadataWithVersion serverConfigCtx
schemaCache <- runCacheBuild cacheBuildParams $ buildRebuildableSchemaCache logger envMap metadataWithVersion dynamicConfig
pure (_mwrvMetadata metadataWithVersion, schemaCache)
cacheRef <- newMVar schemaCache
pure $ NT (run . flip MigrateSuite.runCacheRefT (serverConfigCtx, cacheRef) . fmap fst . runMetadataT metadata emptyMetadataDefaults)
pure $ NT (run . flip MigrateSuite.runCacheRefT (dynamicConfig, cacheRef) . fmap fst . runMetadataT metadata emptyMetadataDefaults)
streamingSubscriptionSuite <- StreamingSubscriptionSuite.buildStreamingSubscriptionSuite
eventTriggerLogCleanupSuite <- EventTriggerCleanupSuite.buildEventTriggerCleanupSuite

29
server/test-postgres/Test/Hasura/Server/MigrateSuite.hs
View File

@ -22,6 +22,7 @@ import Hasura.RQL.DDL.EventTrigger (MonadEventLogCleanup (..))
import Hasura.RQL.DDL.Metadata (ClearMetadata (..), runClearMetadata)
import Hasura.RQL.DDL.Schema
import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.DDL.Schema.LegacyCatalog (recreateSystemMetadata)
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.SchemaCache
@ -38,7 +39,7 @@ import Test.Hspec.Expectations.Lifted
-- -- NOTE: downgrade test disabled for now (see #5273)
newtype CacheRefT m a = CacheRefT {runCacheRefT :: (ServerConfigCtx, MVar RebuildableSchemaCache) -> m a}
newtype CacheRefT m a = CacheRefT {runCacheRefT :: (CacheDynamicConfig, MVar RebuildableSchemaCache) -> m a}
deriving
( Functor,
Applicative,
@ -47,18 +48,16 @@ newtype CacheRefT m a = CacheRefT {runCacheRefT :: (ServerConfigCtx, MVar Rebuil
MonadError e,
MonadBase b,
MonadBaseControl b,
MonadReader (ServerConfigCtx, MVar RebuildableSchemaCache),
MonadReader (CacheDynamicConfig, MVar RebuildableSchemaCache),
MonadTx,
HasCacheStaticConfig,
UserInfoM,
MonadMetadataStorage,
MonadResolveSource,
ProvidesNetwork,
MonadGetApiTimeLimit
)
via (ReaderT (ServerConfigCtx, MVar RebuildableSchemaCache) m)
instance Monad m => HasServerConfigCtx (CacheRefT m) where
askServerConfigCtx = asks fst
via (ReaderT (CacheDynamicConfig, MVar RebuildableSchemaCache) m)
instance MonadTrans CacheRefT where
lift = CacheRefT . const
@ -80,20 +79,21 @@ instance
MonadBaseControl IO m,
MonadError QErr m,
MonadResolveSource m,
ProvidesNetwork m
ProvidesNetwork m,
HasCacheStaticConfig m
) =>
CacheRWM (CacheRefT m)
where
buildSchemaCacheWithOptions reason invalidations metadata = do
(serverConfigCtx, scVar) <- ask
(dynamicConfig, scVar) <- ask
modifyMVar scVar \schemaCache -> do
((), cache, _) <- runCacheRWT serverConfigCtx schemaCache (buildSchemaCacheWithOptions reason invalidations metadata)
((), cache, _) <- runCacheRWT dynamicConfig schemaCache (buildSchemaCacheWithOptions reason invalidations metadata)
pure (cache, ())
setMetadataResourceVersionInSchemaCache resourceVersion = do
(serverConfigCtx, scVar) <- ask
(dynamicConfig, scVar) <- ask
modifyMVar scVar \schemaCache -> do
((), cache, _) <- runCacheRWT serverConfigCtx schemaCache (setMetadataResourceVersionInSchemaCache resourceVersion)
((), cache, _) <- runCacheRWT dynamicConfig schemaCache (setMetadataResourceVersionInSchemaCache resourceVersion)
pure (cache, ())
instance Example (MetadataT (CacheRefT m) ()) where
@ -114,7 +114,8 @@ suite ::
MonadMetadataStorage m,
MonadEventLogCleanup m,
ProvidesNetwork m,
MonadGetApiTimeLimit m
MonadGetApiTimeLimit m,
HasCacheStaticConfig m
) =>
PostgresConnConfiguration ->
PGExecCtx ->
@ -127,9 +128,9 @@ suite srcConfig pgExecCtx pgConnInfo = do
liftIO $ putStrLn $ LBS.toString $ encode $ EngineLog t logLevel logType logDetail
migrateCatalogAndBuildCache env time = do
serverConfigCtx <- askServerConfigCtx
dynamicConfig <- asks fst
(migrationResult, metadataWithVersion) <- runTx' pgExecCtx $ migrateCatalog (Just srcConfig) (ExtensionsSchema "public") MaintenanceModeDisabled time
(,migrationResult) <$> runCacheBuildM (buildRebuildableSchemaCache logger env metadataWithVersion serverConfigCtx)
(,migrationResult) <$> runCacheBuildM (buildRebuildableSchemaCache logger env metadataWithVersion dynamicConfig)
dropAndInit env time = lift do
scVar <- asks snd