mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-18 21:12:09 +03:00
5920134dcb
### Motivation #2338 introduced a way to validate REST queries against the metadata after a change, to properly report any inconsistency that would emerge from a change in the underlying structure of our schema. However, the way this was done was quite complex and error-prone. Namely: we would use the generated schema parsers to statically execute an introspection query, similar to the one we use for remote schemas, then parse the resulting bytestring as it were coming from a remote schema. This led to several issues: the code was using remote schema primitives, and was associated with remote schema code, despite being unrelated, which led to absurd situations like creating fake `Variable`s whose type was also their name. A lot of the code had to deal with the fact that we might fail to re-parse our own schema. Additionally, some of it was dead code, that for some reason GHC did not warn about? But more fundamentally, this architecture decision creates a dependency between unrelated pieces of the engine: modifying the internal processing of root fields or the introspection of remote schemas now risks impacting the unrelated `OpenAPI` feature. ### Description This PR decouples that process from the remote schema introspection logic and from the execution engine by making `Analyse` and `OpenAPI` work on the generic `G.SchemaIntrospection` instead. To accomplish this, it: - adds `GraphQL.Parser.Schema.Convert`, to convert from our "live" schema back to a flat `SchemaIntrospection` - persists in the schema cache the `admin` introspection generated when building the schema, and uses it both for validation and for generating the `OpenAPI`. ### Known issues and limitations This adds a bit of memory pressure to the engine, as we persist the entire schema in the schema cache. This might be acceptable in the short-term, but we have several potential ideas going forward should this be a problem: - cache the result of `Analyze`: when it becomes possible to build the `OpenAPI` purely with the result of `Analyze` without any additional schema information, then we could cache that instead, reducing the footprint - caching the `OpenAPI`: if it doesn't need to change every time the endpoint is queried, then it should be possible to cache the entire `OpenAPI` object instead of the schema - cache a copy of the `FieldParsers` used to generate the schema: as those are persisted through the GraphQL `Context`, and are the only input required to generate the `Schema`, making them accessible in the schema cache would allow us to have the exact same feature with no additional memory cost, at the price of a slightly slower and more complicated process (need to rebuild the `Schema` every time we query the OpenAPI endpoint) - cache nothing at all, and rebuild the admin schema from scratch every time. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3962 Co-authored-by: paritosh-08 <85472423+paritosh-08@users.noreply.github.com> GitOrigin-RevId: a8b9808170b231fdf6787983b4a9ed286cde27e0
1275 lines
57 KiB
Haskell
1275 lines
57 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
||
{-# LANGUAGE OverloadedLabels #-}
|
||
{-# LANGUAGE UndecidableInstances #-}
|
||
|
||
-- | Top-level functions concerned specifically with operations on the schema cache, such as
|
||
-- rebuilding it from the catalog and incorporating schema changes. See the module documentation for
|
||
-- "Hasura.RQL.DDL.Schema" for more details.
|
||
--
|
||
-- __Note__: this module is __mutually recursive__ with other @Hasura.RQL.DDL.Schema.*@ modules, which
|
||
-- both define pieces of the implementation of building the schema cache and define handlers that
|
||
-- trigger schema cache rebuilds.
|
||
module Hasura.RQL.DDL.Schema.Cache
|
||
( RebuildableSchemaCache,
|
||
lastBuiltSchemaCache,
|
||
buildRebuildableSchemaCache,
|
||
buildRebuildableSchemaCacheWithReason,
|
||
CacheRWT,
|
||
runCacheRWT,
|
||
mkBooleanPermissionMap,
|
||
)
|
||
where
|
||
|
||
import Control.Arrow.Extended
|
||
import Control.Concurrent.Extended (forConcurrentlyEIO)
|
||
import Control.Lens hiding ((.=))
|
||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||
import Control.Retry qualified as Retry
|
||
import Data.Aeson
|
||
import Data.Align (align)
|
||
import Data.Dependent.Map qualified as DMap
|
||
import Data.Either (isLeft)
|
||
import Data.Environment qualified as Env
|
||
import Data.HashMap.Strict.Extended qualified as M
|
||
import Data.HashMap.Strict.InsOrd.Extended qualified as OMap
|
||
import Data.HashSet qualified as HS
|
||
import Data.Proxy
|
||
import Data.Set qualified as S
|
||
import Data.Text.Extended
|
||
import Data.These (These (..))
|
||
import Data.Time.Clock (getCurrentTime)
|
||
import Database.PG.Query qualified as Q
|
||
import Hasura.Backends.MSSQL.Connection
|
||
import Hasura.Backends.MSSQL.DDL.Source qualified as MSSQL
|
||
import Hasura.Backends.Postgres.Connection
|
||
import Hasura.Backends.Postgres.DDL.Source (initCatalogForSource)
|
||
import Hasura.Base.Error
|
||
import Hasura.GraphQL.Execute.Types
|
||
import Hasura.GraphQL.Schema (buildGQLContext)
|
||
import Hasura.Incremental qualified as Inc
|
||
import Hasura.Logging
|
||
import Hasura.Metadata.Class
|
||
import Hasura.Prelude
|
||
import Hasura.RQL.DDL.Action
|
||
import Hasura.RQL.DDL.CustomTypes
|
||
import Hasura.RQL.DDL.EventTrigger (buildEventTriggerInfo)
|
||
import Hasura.RQL.DDL.InheritedRoles (resolveInheritedRole)
|
||
import Hasura.RQL.DDL.RemoteRelationship (CreateRemoteSchemaRemoteRelationship (..), PartiallyResolvedSource (..), buildRemoteFieldInfo, getRemoteSchemaEntityJoinColumns)
|
||
import Hasura.RQL.DDL.RemoteSchema
|
||
import Hasura.RQL.DDL.RemoteSchema.Permission (resolveRoleBasedRemoteSchema)
|
||
import Hasura.RQL.DDL.ScheduledTrigger
|
||
import Hasura.RQL.DDL.Schema.Cache.Common
|
||
import Hasura.RQL.DDL.Schema.Cache.Dependencies
|
||
import Hasura.RQL.DDL.Schema.Cache.Fields
|
||
import Hasura.RQL.DDL.Schema.Cache.Permission
|
||
import Hasura.RQL.DDL.Schema.Function
|
||
import Hasura.RQL.DDL.Schema.Table
|
||
import Hasura.RQL.Types hiding (fmFunction, tmTable)
|
||
import Hasura.RQL.Types.Endpoint
|
||
import Hasura.RQL.Types.Eventing.Backend
|
||
import Hasura.RQL.Types.Roles.Internal (CheckPermission (..))
|
||
import Hasura.SQL.AnyBackend qualified as AB
|
||
import Hasura.SQL.Tag
|
||
import Hasura.SQL.Tag qualified as Tag
|
||
import Hasura.Server.Types
|
||
( EventingMode (..),
|
||
MaintenanceMode (..),
|
||
ReadOnlyMode (..),
|
||
)
|
||
import Hasura.Session
|
||
import Hasura.Tracing qualified as Tracing
|
||
import Language.GraphQL.Draft.Syntax qualified as G
|
||
import Network.HTTP.Client.Manager (HasHttpManagerM (..))
|
||
|
||
{- Note [Roles Inheritance]
|
||
~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
||
Roles may have parent roles defined from which they can inherit permission and this is
|
||
called as roles inheritance. Roles which have parents can also be parents of other roles.
|
||
So, cycle in roles should be disallowed and this is done in the `orderRoles` function.
|
||
|
||
When the metadata contains a permission for a role for a entity, then it will override the
|
||
inherited permission, if any.
|
||
|
||
Roles inheritance work differently for different features:
|
||
|
||
1. Select permissions
|
||
~~~~~~~~~~~~~~~~~~~~~
|
||
|
||
See note [Inherited roles architecture for read queries]
|
||
|
||
2. Mutation permissions and remote schema permissions
|
||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
||
For mutation and remote schema permissions, an inherited role can only inherit permission
|
||
from its parent roles when the relevant parts of the permissions are equal i.e. the non-relevant
|
||
parts are discarded for the equality, for example, in two remote schema permissions the order
|
||
of the fields in an Object type is discarded.
|
||
|
||
When an inherited role cannot inherit permission from its parents due to a conflict, then we mark
|
||
the inherited role and the entity (remote schema or table) combination as inconsistent in the metadata.
|
||
|
||
3. Actions and Custom function permissions
|
||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
||
Currently, actions and custom function permissions can be thought of as a boolean. Either a role has
|
||
permission to the entity or it doesn't, so in these cases there's no possiblity of a conflict. An inherited
|
||
role will have access to the action/function if any one of the parents have permission to access the
|
||
action/function.
|
||
|
||
-}
|
||
|
||
buildRebuildableSchemaCache ::
|
||
Logger Hasura ->
|
||
Env.Environment ->
|
||
Metadata ->
|
||
CacheBuild RebuildableSchemaCache
|
||
buildRebuildableSchemaCache =
|
||
buildRebuildableSchemaCacheWithReason CatalogSync
|
||
|
||
buildRebuildableSchemaCacheWithReason ::
|
||
BuildReason ->
|
||
Logger Hasura ->
|
||
Env.Environment ->
|
||
Metadata ->
|
||
CacheBuild RebuildableSchemaCache
|
||
buildRebuildableSchemaCacheWithReason reason logger env metadata = do
|
||
result <-
|
||
flip runReaderT reason $
|
||
Inc.build (buildSchemaCacheRule logger env) (metadata, initialInvalidationKeys)
|
||
|
||
pure $ RebuildableSchemaCache (Inc.result result) initialInvalidationKeys (Inc.rebuildRule result)
|
||
|
||
newtype CacheRWT m a
|
||
= -- The CacheInvalidations component of the state could actually be collected using WriterT, but
|
||
-- WriterT implementations prior to transformers-0.5.6.0 (which added
|
||
-- Control.Monad.Trans.Writer.CPS) are leaky, and we don’t have that yet.
|
||
CacheRWT (StateT (RebuildableSchemaCache, CacheInvalidations) m a)
|
||
deriving
|
||
( Functor,
|
||
Applicative,
|
||
Monad,
|
||
MonadIO,
|
||
MonadReader r,
|
||
MonadError e,
|
||
MonadTx,
|
||
UserInfoM,
|
||
HasHttpManagerM,
|
||
HasSystemDefined,
|
||
MonadMetadataStorage,
|
||
MonadMetadataStorageQueryAPI,
|
||
Tracing.MonadTrace,
|
||
HasServerConfigCtx
|
||
)
|
||
|
||
deriving instance (MonadBase IO m) => MonadBase IO (CacheRWT m)
|
||
|
||
deriving instance (MonadBaseControl IO m) => MonadBaseControl IO (CacheRWT m)
|
||
|
||
runCacheRWT ::
|
||
Functor m =>
|
||
RebuildableSchemaCache ->
|
||
CacheRWT m a ->
|
||
m (a, RebuildableSchemaCache, CacheInvalidations)
|
||
runCacheRWT cache (CacheRWT m) =
|
||
runStateT m (cache, mempty) <&> \(v, (newCache, invalidations)) -> (v, newCache, invalidations)
|
||
|
||
instance MonadTrans CacheRWT where
|
||
lift = CacheRWT . lift
|
||
|
||
instance (Monad m) => CacheRM (CacheRWT m) where
|
||
askSchemaCache = CacheRWT $ gets (lastBuiltSchemaCache . (^. _1))
|
||
|
||
instance
|
||
( MonadIO m,
|
||
MonadError QErr m,
|
||
HasHttpManagerM m,
|
||
MonadResolveSource m,
|
||
HasServerConfigCtx m
|
||
) =>
|
||
CacheRWM (CacheRWT m)
|
||
where
|
||
buildSchemaCacheWithOptions buildReason invalidations metadata = CacheRWT do
|
||
(RebuildableSchemaCache lastBuiltSC invalidationKeys rule, oldInvalidations) <- get
|
||
let metadataVersion = scMetadataResourceVersion lastBuiltSC
|
||
newInvalidationKeys = invalidateKeys invalidations invalidationKeys
|
||
result <-
|
||
lift $
|
||
runCacheBuildM $
|
||
flip runReaderT buildReason $
|
||
Inc.build rule (metadata, newInvalidationKeys)
|
||
let schemaCache = (Inc.result result) {scMetadataResourceVersion = metadataVersion}
|
||
prunedInvalidationKeys = pruneInvalidationKeys schemaCache newInvalidationKeys
|
||
!newCache = RebuildableSchemaCache schemaCache prunedInvalidationKeys (Inc.rebuildRule result)
|
||
!newInvalidations = oldInvalidations <> invalidations
|
||
put (newCache, newInvalidations)
|
||
where
|
||
-- Prunes invalidation keys that no longer exist in the schema to avoid leaking memory by
|
||
-- hanging onto unnecessary keys.
|
||
pruneInvalidationKeys schemaCache = over ikRemoteSchemas $ M.filterWithKey \name _ ->
|
||
-- see Note [Keep invalidation keys for inconsistent objects]
|
||
name `elem` getAllRemoteSchemas schemaCache
|
||
|
||
setMetadataResourceVersionInSchemaCache resourceVersion = CacheRWT $ do
|
||
(rebuildableSchemaCache, invalidations) <- get
|
||
put
|
||
( rebuildableSchemaCache
|
||
{ lastBuiltSchemaCache =
|
||
(lastBuiltSchemaCache rebuildableSchemaCache)
|
||
{ scMetadataResourceVersion = Just resourceVersion
|
||
}
|
||
},
|
||
invalidations
|
||
)
|
||
|
||
buildSchemaCacheRule ::
|
||
-- Note: by supplying BuildReason via MonadReader, it does not participate in caching, which is
|
||
-- what we want!
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
Inc.ArrowCache m arr,
|
||
MonadIO m,
|
||
MonadBaseControl IO m,
|
||
MonadError QErr m,
|
||
MonadReader BuildReason m,
|
||
HasHttpManagerM m,
|
||
MonadResolveSource m,
|
||
HasServerConfigCtx m
|
||
) =>
|
||
Logger Hasura ->
|
||
Env.Environment ->
|
||
(Metadata, InvalidationKeys) `arr` SchemaCache
|
||
buildSchemaCacheRule logger env = proc (metadata, invalidationKeys) -> do
|
||
invalidationKeysDep <- Inc.newDependency -< invalidationKeys
|
||
|
||
-- Step 1: Process metadata and collect dependency information.
|
||
(outputs, collectedInfo) <-
|
||
runWriterA buildAndCollectInfo -< (metadata, invalidationKeysDep)
|
||
let (inconsistentObjects, unresolvedDependencies) = partitionCollectedInfo collectedInfo
|
||
|
||
-- Step 2: Resolve dependency information and drop dangling dependents.
|
||
(resolvedOutputs, dependencyInconsistentObjects, resolvedDependencies) <-
|
||
resolveDependencies -< (outputs, unresolvedDependencies)
|
||
|
||
-- Steps 3 and 4: Build the regular and relay GraphQL schemas in parallel
|
||
[(adminIntrospection, gqlContext, gqlContextUnauth, inconsistentRemoteSchemas), (_, relayContext, relayContextUnauth, _)] <-
|
||
bindA
|
||
-< do
|
||
cxt <- askServerConfigCtx
|
||
forConcurrentlyEIO 1 [QueryHasura, QueryRelay] $ \queryType -> do
|
||
buildGQLContext
|
||
cxt
|
||
queryType
|
||
(_boSources resolvedOutputs)
|
||
(_boRemoteSchemas resolvedOutputs)
|
||
(_boActions resolvedOutputs)
|
||
(_boCustomTypes resolvedOutputs)
|
||
|
||
let duplicateVariables :: EndpointMetadata a -> Bool
|
||
duplicateVariables m = any ((> 1) . length) $ group $ sort $ catMaybes $ splitPath Just (const Nothing) (_ceUrl m)
|
||
|
||
endpointObjId :: EndpointMetadata q -> MetadataObjId
|
||
endpointObjId md = MOEndpoint (_ceName md)
|
||
|
||
endpointObject :: EndpointMetadata q -> MetadataObject
|
||
endpointObject md = MetadataObject (endpointObjId md) (toJSON $ OMap.lookup (_ceName md) $ _metaRestEndpoints metadata)
|
||
|
||
listedQueryObjects :: (CollectionName, ListedQuery) -> MetadataObject
|
||
listedQueryObjects (cName, lq) = MetadataObject (MOQueryCollectionsQuery cName lq) (toJSON lq)
|
||
|
||
-- Cases of urls that generate invalid segments:
|
||
|
||
hasInvalidSegments :: EndpointMetadata query -> Bool
|
||
hasInvalidSegments m = any (`elem` ["", ":"]) (splitPath id id (_ceUrl m))
|
||
|
||
ceUrlTxt = toTxt . _ceUrl
|
||
|
||
endpoints = buildEndpointsTrie (M.elems $ _boEndpoints resolvedOutputs)
|
||
|
||
duplicateF md = DuplicateRestVariables (ceUrlTxt md) (endpointObject md)
|
||
duplicateRestVariables = map duplicateF $ filter duplicateVariables (M.elems $ _boEndpoints resolvedOutputs)
|
||
|
||
invalidF md = InvalidRestSegments (ceUrlTxt md) (endpointObject md)
|
||
invalidRestSegments = map invalidF $ filter hasInvalidSegments (M.elems $ _boEndpoints resolvedOutputs)
|
||
|
||
ambiguousF' ep = MetadataObject (endpointObjId ep) (toJSON ep)
|
||
ambiguousF mds = AmbiguousRestEndpoints (commaSeparated $ map _ceUrl mds) (map ambiguousF' mds)
|
||
ambiguousRestEndpoints = map (ambiguousF . S.elems . snd) $ ambiguousPathsGrouped endpoints
|
||
|
||
queryCollections = _boQueryCollections resolvedOutputs
|
||
allowLists = HS.toList . iaGlobal . _boAllowlist $ resolvedOutputs
|
||
inconsistentQueryCollections = getInconsistentQueryCollections adminIntrospection queryCollections listedQueryObjects endpoints allowLists
|
||
|
||
returnA
|
||
-<
|
||
SchemaCache
|
||
{ scSources = _boSources resolvedOutputs,
|
||
scActions = _boActions resolvedOutputs,
|
||
-- TODO this is not the right value: we should track what part of the schema
|
||
-- we can stitch without consistencies, I think.
|
||
scRemoteSchemas = fmap fst (_boRemoteSchemas resolvedOutputs), -- remoteSchemaMap
|
||
scAllowlist = _boAllowlist resolvedOutputs,
|
||
-- , scCustomTypes = _boCustomTypes resolvedOutputs
|
||
scAdminIntrospection = adminIntrospection,
|
||
scGQLContext = gqlContext,
|
||
scUnauthenticatedGQLContext = gqlContextUnauth,
|
||
scRelayContext = relayContext,
|
||
scUnauthenticatedRelayContext = relayContextUnauth,
|
||
-- , scGCtxMap = gqlSchema
|
||
-- , scDefaultRemoteGCtx = remoteGQLSchema
|
||
scDepMap = resolvedDependencies,
|
||
scCronTriggers = _boCronTriggers resolvedOutputs,
|
||
scEndpoints = endpoints,
|
||
scInconsistentObjs =
|
||
inconsistentObjects
|
||
<> dependencyInconsistentObjects
|
||
<> toList inconsistentRemoteSchemas
|
||
<> duplicateRestVariables
|
||
<> invalidRestSegments
|
||
<> ambiguousRestEndpoints
|
||
<> inconsistentQueryCollections,
|
||
scApiLimits = _boApiLimits resolvedOutputs,
|
||
scMetricsConfig = _boMetricsConfig resolvedOutputs,
|
||
scMetadataResourceVersion = Nothing,
|
||
scSetGraphqlIntrospectionOptions = _metaSetGraphqlIntrospectionOptions metadata,
|
||
scTlsAllowlist = _boTlsAllowlist resolvedOutputs,
|
||
scQueryCollections = _boQueryCollections resolvedOutputs
|
||
}
|
||
where
|
||
getSourceConfigIfNeeded ::
|
||
forall b arr m.
|
||
( ArrowChoice arr,
|
||
Inc.ArrowCache m arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
MonadIO m,
|
||
MonadResolveSource m,
|
||
BackendMetadata b
|
||
) =>
|
||
( Inc.Dependency (HashMap SourceName Inc.InvalidationKey),
|
||
SourceName,
|
||
SourceConnConfiguration b
|
||
)
|
||
`arr` Maybe (SourceConfig b)
|
||
getSourceConfigIfNeeded = Inc.cache proc (invalidationKeys, sourceName, sourceConfig) -> do
|
||
let metadataObj = MetadataObject (MOSource sourceName) $ toJSON sourceName
|
||
Inc.dependOn -< Inc.selectKeyD sourceName invalidationKeys
|
||
(|
|
||
withRecordInconsistency
|
||
( liftEitherA <<< bindA -< resolveSourceConfig @b sourceName sourceConfig env
|
||
)
|
||
|) metadataObj
|
||
|
||
resolveSourceIfNeeded ::
|
||
forall b arr m.
|
||
( ArrowChoice arr,
|
||
Inc.ArrowCache m arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
MonadIO m,
|
||
MonadBaseControl IO m,
|
||
MonadResolveSource m,
|
||
BackendMetadata b
|
||
) =>
|
||
( Inc.Dependency (HashMap SourceName Inc.InvalidationKey),
|
||
SourceMetadata b
|
||
)
|
||
`arr` Maybe (ResolvedSource b)
|
||
resolveSourceIfNeeded = Inc.cache proc (invalidationKeys, sourceMetadata) -> do
|
||
let sourceName = _smName sourceMetadata
|
||
metadataObj = MetadataObject (MOSource sourceName) $ toJSON sourceName
|
||
logAndResolveDatabaseMetadata :: SourceConfig b -> SourceTypeCustomization -> m (Either QErr (ResolvedSource b))
|
||
logAndResolveDatabaseMetadata scConfig sType = do
|
||
resSource <- resolveDatabaseMetadata sourceMetadata scConfig sType
|
||
for_ resSource $ liftIO . unLogger logger
|
||
pure resSource
|
||
|
||
maybeSourceConfig <- getSourceConfigIfNeeded @b -< (invalidationKeys, sourceName, _smConfiguration sourceMetadata)
|
||
case maybeSourceConfig of
|
||
Nothing -> returnA -< Nothing
|
||
Just sourceConfig ->
|
||
(|
|
||
withRecordInconsistency
|
||
( liftEitherA <<< bindA -< logAndResolveDatabaseMetadata sourceConfig (getSourceTypeCustomization $ _smCustomization sourceMetadata)
|
||
)
|
||
|) metadataObj
|
||
|
||
-- impl notes (swann):
|
||
--
|
||
-- as our cache invalidation key (in a sense) we use the number of event triggers
|
||
-- present, rerunning catalog init when this changes. this is correct, because we
|
||
-- only care about the transition from zero event triggers to nonzero (not
|
||
-- necessarily one, as Anon has observed, because replace_metadata can add multiple
|
||
-- event triggers in one go)
|
||
--
|
||
-- a future optimisation would be to cache, on a per-source basis, whether or not
|
||
-- the event catalog itself exists, and to then trigger catalog init when an event
|
||
-- trigger is created _but only if_ this cached information says the event catalog
|
||
-- doesn't already exist.
|
||
|
||
initCatalogIfNeeded ::
|
||
forall b arr m.
|
||
( ArrowChoice arr,
|
||
Inc.ArrowCache m arr,
|
||
MonadIO m,
|
||
BackendMetadata b,
|
||
HasServerConfigCtx m,
|
||
MonadError QErr m,
|
||
MonadBaseControl IO m
|
||
) =>
|
||
(Int, SourceConfig b) `arr` RecreateEventTriggers
|
||
initCatalogIfNeeded = Inc.cache proc (numEventTriggers, sourceConfig) -> do
|
||
arrM id
|
||
-< do
|
||
if numEventTriggers > 0
|
||
then do
|
||
migrationTime <- liftIO getCurrentTime
|
||
maintenanceMode <- _sccMaintenanceMode <$> askServerConfigCtx
|
||
eventingMode <- _sccEventingMode <$> askServerConfigCtx
|
||
readOnlyMode <- _sccReadOnlyMode <$> askServerConfigCtx
|
||
|
||
if
|
||
-- when safe mode is enabled, don't perform any migrations
|
||
| readOnlyMode == ReadOnlyModeEnabled -> pure RETDoNothing
|
||
-- when eventing mode is disabled, don't perform any migrations
|
||
| eventingMode == EventingDisabled -> pure RETDoNothing
|
||
-- when maintenance mode is enabled, don't perform any migrations
|
||
| maintenanceMode == MaintenanceModeEnabled -> pure RETDoNothing
|
||
| otherwise -> do
|
||
let initCatalogAction =
|
||
case backendTag @b of
|
||
Tag.PostgresVanillaTag -> do
|
||
runExceptT $ runTx (_pscExecCtx sourceConfig) Q.ReadWrite (initCatalogForSource migrationTime)
|
||
Tag.MSSQLTag -> do
|
||
runExceptT $
|
||
mssqlRunReadWrite (_mscExecCtx sourceConfig) MSSQL.initCatalogForSource
|
||
-- TODO: When event triggers are supported on new databases,
|
||
-- the initialization of the source catalog should also return
|
||
-- if the event triggers are to be re-created or not, essentially
|
||
-- replacing the `RETDoNothing` below
|
||
_ -> pure $ Right RETDoNothing
|
||
-- The `initCatalogForSource` action is retried here because
|
||
-- in cloud there will be multiple workers (graphql-engine instances)
|
||
-- trying to migrate the source catalog, when needed. This introduces
|
||
-- a race condition as both the workers try to migrate the source catalog
|
||
-- concurrently and when one of them succeeds the other ones will fail
|
||
-- and be in an inconsistent state. To avoid the inconsistency, we retry
|
||
-- migrating the catalog on error and in the retry `initCatalogForSource`
|
||
-- will see that the catalog is already migrated, so it won't attempt the
|
||
-- migration again
|
||
liftEither
|
||
=<< Retry.retrying
|
||
( Retry.constantDelay (fromIntegral $ diffTimeToMicroSeconds $ seconds $ Seconds 10)
|
||
<> Retry.limitRetries 3
|
||
)
|
||
(const $ return . isLeft)
|
||
(const initCatalogAction)
|
||
else pure RETDoNothing
|
||
|
||
buildSource ::
|
||
forall b arr m.
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
Inc.ArrowCache m arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
MonadBaseControl IO m,
|
||
HasServerConfigCtx m,
|
||
MonadIO m,
|
||
MonadError QErr m,
|
||
MonadReader BuildReason m,
|
||
BackendMetadata b,
|
||
BackendEventTrigger b
|
||
) =>
|
||
( HashMap SourceName (AB.AnyBackend PartiallyResolvedSource),
|
||
SourceMetadata b,
|
||
SourceConfig b,
|
||
HashMap (TableName b) (TableCoreInfoG b (ColumnInfo b) (ColumnInfo b)),
|
||
DBTablesMetadata b,
|
||
DBFunctionsMetadata b,
|
||
RemoteSchemaMap,
|
||
Inc.Dependency InvalidationKeys,
|
||
OrderedRoles
|
||
)
|
||
`arr` BackendSourceInfo
|
||
buildSource = proc (allSources, sourceMetadata, sourceConfig, tablesRawInfo, _dbTables, dbFunctions, remoteSchemaMap, invalidationKeys, orderedRoles) -> do
|
||
let SourceMetadata sourceName tables functions _ queryTagsConfig sourceCustomization = sourceMetadata
|
||
tablesMetadata = OMap.elems tables
|
||
(_, nonColumnInputs, permissions) = unzip3 $ map mkTableInputs tablesMetadata
|
||
eventTriggers = map (_tmTable &&& OMap.elems . _tmEventTriggers) tablesMetadata
|
||
alignTableMap :: HashMap (TableName b) a -> HashMap (TableName b) c -> HashMap (TableName b) (a, c)
|
||
alignTableMap = M.intersectionWith (,)
|
||
metadataInvalidationKey = Inc.selectD #_ikMetadata invalidationKeys
|
||
numEventTriggers = sum $ map (length . snd) eventTriggers
|
||
|
||
recreateEventTriggers <- initCatalogIfNeeded @b -< (numEventTriggers, sourceConfig)
|
||
|
||
-- relationships and computed fields
|
||
let nonColumnsByTable = mapFromL _nctiTable nonColumnInputs
|
||
tableCoreInfos :: HashMap (TableName b) (TableCoreInfo b) <-
|
||
(|
|
||
Inc.keyed
|
||
( \_ (tableRawInfo, nonColumnInput) -> do
|
||
let columns = _tciFieldInfoMap tableRawInfo
|
||
allFields :: FieldInfoMap (FieldInfo b) <- addNonColumnFields -< (allSources, sourceName, tablesRawInfo, columns, remoteSchemaMap, dbFunctions, nonColumnInput)
|
||
returnA -< (tableRawInfo {_tciFieldInfoMap = allFields})
|
||
)
|
||
|) (tablesRawInfo `alignTableMap` nonColumnsByTable)
|
||
|
||
tableCoreInfosDep <- Inc.newDependency -< tableCoreInfos
|
||
|
||
-- permissions and event triggers
|
||
tableCache <-
|
||
(|
|
||
Inc.keyed
|
||
( \_ ((tableCoreInfo, permissionInputs), (_, eventTriggerConfs)) -> do
|
||
let tableFields = _tciFieldInfoMap tableCoreInfo
|
||
permissionInfos <-
|
||
buildTablePermissions
|
||
-<
|
||
(Proxy :: Proxy b, sourceName, tableCoreInfosDep, tableFields, permissionInputs, orderedRoles)
|
||
eventTriggerInfos <- buildTableEventTriggers -< (sourceName, sourceConfig, tableCoreInfo, eventTriggerConfs, metadataInvalidationKey, recreateEventTriggers)
|
||
returnA -< TableInfo tableCoreInfo permissionInfos eventTriggerInfos (mkAdminRolePermInfo tableCoreInfo)
|
||
)
|
||
|) (tableCoreInfos `alignTableMap` mapFromL _tpiTable permissions `alignTableMap` mapFromL fst eventTriggers)
|
||
|
||
-- sql functions
|
||
functionCache <-
|
||
(mapFromL _fmFunction (OMap.elems functions) >- returnA)
|
||
>-> (|
|
||
Inc.keyed
|
||
( \_ (FunctionMetadata qf config functionPermissions comment) -> do
|
||
let systemDefined = SystemDefined False
|
||
definition = toJSON $ TrackFunction @b qf
|
||
metadataObject =
|
||
MetadataObject
|
||
( MOSourceObjId sourceName $
|
||
AB.mkAnyBackend $
|
||
SMOFunction @b qf
|
||
)
|
||
definition
|
||
schemaObject =
|
||
SOSourceObj sourceName $
|
||
AB.mkAnyBackend $
|
||
SOIFunction @b qf
|
||
addFunctionContext e = "in function " <> qf <<> ": " <> e
|
||
(|
|
||
withRecordInconsistency
|
||
( (|
|
||
modifyErrA
|
||
( do
|
||
let funcDefs = fromMaybe [] $ M.lookup qf dbFunctions
|
||
rawfunctionInfo <- bindErrorA -< handleMultipleFunctions @b qf funcDefs
|
||
let metadataPermissions = mapFromL _fpmRole functionPermissions
|
||
permissionsMap = mkBooleanPermissionMap FunctionPermissionInfo metadataPermissions orderedRoles
|
||
(functionInfo, dep) <- bindErrorA -< buildFunctionInfo sourceName qf systemDefined config permissionsMap rawfunctionInfo comment
|
||
recordDependencies -< (metadataObject, schemaObject, [dep])
|
||
returnA -< functionInfo
|
||
)
|
||
|) addFunctionContext
|
||
)
|
||
|) metadataObject
|
||
)
|
||
|)
|
||
>-> (\infos -> M.catMaybes infos >- returnA)
|
||
|
||
returnA -< AB.mkAnyBackend $ SourceInfo sourceName tableCache functionCache sourceConfig queryTagsConfig sourceCustomization
|
||
|
||
buildAndCollectInfo ::
|
||
forall arr m.
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
Inc.ArrowCache m arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
MonadIO m,
|
||
MonadError QErr m,
|
||
MonadReader BuildReason m,
|
||
MonadBaseControl IO m,
|
||
HasHttpManagerM m,
|
||
HasServerConfigCtx m,
|
||
MonadResolveSource m
|
||
) =>
|
||
(Metadata, Inc.Dependency InvalidationKeys) `arr` BuildOutputs
|
||
buildAndCollectInfo = proc (metadata, invalidationKeys) -> do
|
||
let Metadata
|
||
sources
|
||
remoteSchemas
|
||
collections
|
||
metadataAllowlist
|
||
customTypes
|
||
actions
|
||
cronTriggers
|
||
endpoints
|
||
apiLimits
|
||
metricsConfig
|
||
inheritedRoles
|
||
_introspectionDisabledRoles
|
||
networkConfig = metadata
|
||
actionRoles = map _apmRole . _amPermissions =<< OMap.elems actions
|
||
remoteSchemaRoles = map _rspmRole . _rsmPermissions =<< OMap.elems remoteSchemas
|
||
sourceRoles =
|
||
HS.fromList $
|
||
concat $
|
||
OMap.elems sources >>= \e ->
|
||
AB.dispatchAnyBackend @Backend e \(SourceMetadata _ tables _functions _ _ _) -> do
|
||
table <- OMap.elems tables
|
||
pure $
|
||
OMap.keys (_tmInsertPermissions table)
|
||
<> OMap.keys (_tmSelectPermissions table)
|
||
<> OMap.keys (_tmUpdatePermissions table)
|
||
<> OMap.keys (_tmDeletePermissions table)
|
||
inheritedRoleNames = OMap.keys inheritedRoles
|
||
allRoleNames = sourceRoles <> HS.fromList (remoteSchemaRoles <> actionRoles <> inheritedRoleNames)
|
||
|
||
remoteSchemaPermissions =
|
||
let remoteSchemaPermsList = OMap.toList $ _rsmPermissions <$> remoteSchemas
|
||
in concat $
|
||
flip map remoteSchemaPermsList $
|
||
( \(remoteSchemaName, remoteSchemaPerms) ->
|
||
flip map remoteSchemaPerms $ \(RemoteSchemaPermissionMetadata role defn comment) ->
|
||
AddRemoteSchemaPermission remoteSchemaName role defn comment
|
||
)
|
||
|
||
-- roles which have some kind of permission (action/remote schema/table/function) set in the metadata
|
||
let metadataRoles = mapFromL _rRoleName $ (`Role` ParentRoles mempty) <$> toList allRoleNames
|
||
|
||
resolvedInheritedRoles <- buildInheritedRoles -< (allRoleNames, OMap.elems inheritedRoles)
|
||
|
||
let allRoles = resolvedInheritedRoles `M.union` metadataRoles
|
||
|
||
orderedRoles <- bindA -< orderRoles $ M.elems allRoles
|
||
|
||
-- remote schemas
|
||
let remoteSchemaInvalidationKeys = Inc.selectD #_ikRemoteSchemas invalidationKeys
|
||
remoteSchemaMap <- buildRemoteSchemas -< (remoteSchemaInvalidationKeys, OMap.elems remoteSchemas)
|
||
let remoteSchemaCtxMap = M.map (fst . fst) remoteSchemaMap
|
||
|
||
-- sources are build in two steps
|
||
-- first we resolve them, and build the table cache
|
||
partiallyResolvedSources <-
|
||
(|
|
||
Inc.keyed
|
||
( \_ exists ->
|
||
AB.dispatchAnyBackendArrow @BackendMetadata @BackendMetadata
|
||
( proc (sourceMetadata, invalidationKeys) -> do
|
||
let sourceName = _smName sourceMetadata
|
||
sourceInvalidationsKeys = Inc.selectD #_ikSources invalidationKeys
|
||
maybeResolvedSource <- resolveSourceIfNeeded -< (sourceInvalidationsKeys, sourceMetadata)
|
||
case maybeResolvedSource of
|
||
Nothing -> returnA -< Nothing
|
||
Just (source :: ResolvedSource b) -> do
|
||
let metadataInvalidationKey = Inc.selectD #_ikMetadata invalidationKeys
|
||
(tableInputs, _, _) = unzip3 $ map mkTableInputs $ OMap.elems $ _smTables sourceMetadata
|
||
tablesCoreInfo <-
|
||
buildTableCache
|
||
-<
|
||
( sourceName,
|
||
_rsConfig source,
|
||
_rsTables source,
|
||
tableInputs,
|
||
metadataInvalidationKey
|
||
)
|
||
returnA
|
||
-<
|
||
Just $
|
||
AB.mkAnyBackend @b $
|
||
PartiallyResolvedSource sourceMetadata source tablesCoreInfo
|
||
)
|
||
-<
|
||
(exists, invalidationKeys)
|
||
)
|
||
|) (M.fromList $ OMap.toList sources)
|
||
>-> (\infos -> M.catMaybes infos >- returnA)
|
||
|
||
-- then we can build the entire source output
|
||
-- we need to have the table cache of all sources to build cross-sources relationships
|
||
sourcesOutput <-
|
||
(|
|
||
Inc.keyed
|
||
( \_ exists ->
|
||
AB.dispatchAnyBackendArrow @BackendMetadata @BackendEventTrigger
|
||
( proc
|
||
( partiallyResolvedSource :: PartiallyResolvedSource b,
|
||
(allResolvedSources, invalidationKeys, remoteSchemaCtxMap, orderedRoles)
|
||
)
|
||
-> do
|
||
let PartiallyResolvedSource sourceMetadata resolvedSource tablesInfo = partiallyResolvedSource
|
||
ResolvedSource sourceConfig _sourceCustomization tablesMeta functionsMeta scalars = resolvedSource
|
||
so <-
|
||
buildSource
|
||
-<
|
||
( allResolvedSources,
|
||
sourceMetadata,
|
||
sourceConfig,
|
||
tablesInfo,
|
||
tablesMeta,
|
||
functionsMeta,
|
||
remoteSchemaCtxMap,
|
||
invalidationKeys,
|
||
orderedRoles
|
||
)
|
||
returnA -< (so, DMap.singleton (backendTag @b) $ ScalarSet scalars)
|
||
)
|
||
-<
|
||
( exists,
|
||
(partiallyResolvedSources, invalidationKeys, remoteSchemaCtxMap, orderedRoles)
|
||
)
|
||
)
|
||
|) partiallyResolvedSources
|
||
|
||
remoteSchemaCache <-
|
||
(remoteSchemaMap >- returnA)
|
||
>-> ( \info ->
|
||
(info, M.groupOn _arspRemoteSchema remoteSchemaPermissions)
|
||
>-
|
||
alignExtraRemoteSchemaInfo mkRemoteSchemaPermissionMetadataObject
|
||
)
|
||
>-> (|
|
||
Inc.keyed
|
||
( \_ (((remoteSchemaCtx, relationships), metadataObj), remoteSchemaPerms) -> do
|
||
metadataPermissionsMap <-
|
||
buildRemoteSchemaPermissions -< (remoteSchemaCtx, remoteSchemaPerms)
|
||
-- convert to the intermediate form `CheckPermission` whose `Semigroup`
|
||
-- instance is used to combine permissions
|
||
let metadataCheckPermissionsMap = CPDefined <$> metadataPermissionsMap
|
||
allRolesUnresolvedPermissionsMap <-
|
||
bindA
|
||
-<
|
||
foldM
|
||
( \accumulatedRolePermMap (Role roleName (ParentRoles parentRoles)) -> do
|
||
rolePermission <- onNothing (M.lookup roleName accumulatedRolePermMap) $ do
|
||
parentRolePermissions <-
|
||
for (toList parentRoles) $ \role ->
|
||
onNothing (M.lookup role accumulatedRolePermMap) $
|
||
throw500 $
|
||
"remote schema permissions: bad ordering of roles, could not find the permission of role: " <>> role
|
||
let combinedPermission = sconcat <$> nonEmpty parentRolePermissions
|
||
pure $ fromMaybe CPUndefined combinedPermission
|
||
pure $ M.insert roleName rolePermission accumulatedRolePermMap
|
||
)
|
||
metadataCheckPermissionsMap
|
||
(_unOrderedRoles orderedRoles)
|
||
-- traverse through `allRolesUnresolvedPermissionsMap` to record any inconsistencies (if exists)
|
||
resolvedPermissions <-
|
||
(|
|
||
traverseA
|
||
( \(roleName, checkPermission) -> do
|
||
let inconsistentRoleEntity = InconsistentRemoteSchemaPermission $ _rscName remoteSchemaCtx
|
||
resolvedCheckPermission <- resolveCheckPermission -< (checkPermission, roleName, inconsistentRoleEntity)
|
||
returnA -< (roleName, resolvedCheckPermission)
|
||
)
|
||
|) (M.toList allRolesUnresolvedPermissionsMap)
|
||
let remoteSchemaIntrospection = irDoc $ _rscIntroOriginal remoteSchemaCtx
|
||
resolvedRelationships <-
|
||
(|
|
||
traverseA
|
||
( \(typeName, typeRelationships) -> do
|
||
resolvedRelationships <-
|
||
(|
|
||
traverseA
|
||
( \fromSchemaDef ->
|
||
buildRemoteSchemaRemoteRelationship
|
||
-<
|
||
( (partiallyResolvedSources, remoteSchemaCtxMap),
|
||
(_rscName remoteSchemaCtx, remoteSchemaIntrospection, typeName, fromSchemaDef)
|
||
)
|
||
)
|
||
|) (_rstrsRelationships typeRelationships)
|
||
returnA -< (typeName, resolvedRelationships)
|
||
)
|
||
|) (OMap.toList relationships)
|
||
returnA
|
||
-<
|
||
( remoteSchemaCtx
|
||
{ _rscPermissions = M.catMaybes $ M.fromList resolvedPermissions,
|
||
_rscRemoteRelationships = OMap.catMaybes <$> OMap.fromList resolvedRelationships
|
||
},
|
||
metadataObj
|
||
)
|
||
)
|
||
|)
|
||
|
||
-- allowlist
|
||
let inlinedAllowlist = inlineAllowlist collections metadataAllowlist
|
||
|
||
resolvedEndpoints <- buildInfoMap fst mkEndpointMetadataObject buildEndpoint -< (collections, OMap.toList endpoints)
|
||
|
||
-- custom types
|
||
let scalarsMap = mconcat $ map snd $ M.elems sourcesOutput
|
||
sourcesCache = M.map fst sourcesOutput
|
||
maybeResolvedCustomTypes <-
|
||
(|
|
||
withRecordInconsistency
|
||
( bindErrorA -< resolveCustomTypes sourcesCache customTypes scalarsMap
|
||
)
|
||
|) (MetadataObject MOCustomTypes $ toJSON customTypes)
|
||
|
||
-- actions
|
||
let actionList = OMap.elems actions
|
||
(actionCache, annotatedCustomTypes) <- case maybeResolvedCustomTypes of
|
||
Just resolvedCustomTypes -> do
|
||
actionCache' <- buildActions -< ((resolvedCustomTypes, scalarsMap, orderedRoles), actionList)
|
||
returnA -< (actionCache', resolvedCustomTypes)
|
||
|
||
-- If the custom types themselves are inconsistent, we can’t really do
|
||
-- anything with actions, so just mark them all inconsistent.
|
||
Nothing -> do
|
||
recordInconsistencies
|
||
-<
|
||
( map mkActionMetadataObject actionList,
|
||
"custom types are inconsistent"
|
||
)
|
||
returnA -< (M.empty, emptyAnnotatedCustomTypes)
|
||
|
||
cronTriggersMap <- buildCronTriggers -< ((), OMap.elems cronTriggers)
|
||
|
||
returnA
|
||
-<
|
||
BuildOutputs
|
||
{ _boSources = M.map fst sourcesOutput,
|
||
_boActions = actionCache,
|
||
_boRemoteSchemas = remoteSchemaCache,
|
||
_boAllowlist = inlinedAllowlist,
|
||
_boCustomTypes = annotatedCustomTypes,
|
||
_boCronTriggers = cronTriggersMap,
|
||
_boEndpoints = resolvedEndpoints,
|
||
_boApiLimits = apiLimits,
|
||
_boMetricsConfig = metricsConfig,
|
||
_boRoles = mapFromL _rRoleName $ _unOrderedRoles orderedRoles,
|
||
_boTlsAllowlist = (networkTlsAllowlist networkConfig),
|
||
_boQueryCollections = collections
|
||
}
|
||
|
||
mkEndpointMetadataObject (name, createEndpoint) =
|
||
let objectId = MOEndpoint name
|
||
in MetadataObject objectId (toJSON createEndpoint)
|
||
|
||
buildEndpoint ::
|
||
(ArrowChoice arr, ArrowKleisli m arr, MonadError QErr m, ArrowWriter (Seq CollectedInfo) arr) =>
|
||
(InsOrdHashMap CollectionName CreateCollection, (EndpointName, CreateEndpoint)) `arr` Maybe (EndpointMetadata GQLQueryWithText)
|
||
buildEndpoint = proc (collections, e@(name, createEndpoint)) -> do
|
||
let endpoint = createEndpoint
|
||
-- QueryReference collName queryName = _edQuery endpoint
|
||
addContext err = "in endpoint " <> toTxt (unEndpointName name) <> ": " <> err
|
||
(|
|
||
withRecordInconsistency
|
||
( (|
|
||
modifyErrA
|
||
(bindErrorA -< resolveEndpoint collections endpoint)
|
||
|) addContext
|
||
)
|
||
|) (mkEndpointMetadataObject e)
|
||
|
||
resolveEndpoint ::
|
||
QErrM m =>
|
||
InsOrdHashMap CollectionName CreateCollection ->
|
||
EndpointMetadata QueryReference ->
|
||
m (EndpointMetadata GQLQueryWithText)
|
||
resolveEndpoint collections = traverse $ \(QueryReference collName queryName) -> do
|
||
collection <-
|
||
onNothing
|
||
(OMap.lookup collName collections)
|
||
(throw400 NotExists $ "collection with name " <> toTxt collName <> " does not exist")
|
||
listedQuery <-
|
||
flip
|
||
onNothing
|
||
( throw400 NotExists $
|
||
"query with name "
|
||
<> toTxt queryName
|
||
<> " does not exist in collection "
|
||
<> toTxt collName
|
||
)
|
||
$ find ((== queryName) . _lqName) (_cdQueries (_ccDefinition collection))
|
||
|
||
let lq@(GQLQueryWithText lqq) = _lqQuery listedQuery
|
||
ds = G.getExecutableDefinitions $ unGQLQuery $ snd lqq
|
||
|
||
case ds of
|
||
[G.ExecutableDefinitionOperation (G.OperationDefinitionTyped d)]
|
||
| G._todType d == G.OperationTypeSubscription ->
|
||
throw405 $ "query with name " <> toTxt queryName <> " is a subscription"
|
||
| otherwise -> pure ()
|
||
[] -> throw400 BadRequest $ "query with name " <> toTxt queryName <> " has no definitions."
|
||
_ -> throw400 BadRequest $ "query with name " <> toTxt queryName <> " has multiple definitions."
|
||
|
||
pure lq
|
||
|
||
mkEventTriggerMetadataObject ::
|
||
forall b a c.
|
||
Backend b =>
|
||
(a, SourceName, c, TableName b, RecreateEventTriggers, EventTriggerConf b) ->
|
||
MetadataObject
|
||
mkEventTriggerMetadataObject (_, source, _, table, _, eventTriggerConf) =
|
||
let objectId =
|
||
MOSourceObjId source $
|
||
AB.mkAnyBackend $
|
||
SMOTableObj @b table $
|
||
MTOTrigger $
|
||
etcName eventTriggerConf
|
||
definition = object ["table" .= table, "configuration" .= eventTriggerConf]
|
||
in MetadataObject objectId definition
|
||
|
||
mkCronTriggerMetadataObject catalogCronTrigger =
|
||
let definition = toJSON catalogCronTrigger
|
||
in MetadataObject
|
||
(MOCronTrigger (ctName catalogCronTrigger))
|
||
definition
|
||
|
||
mkActionMetadataObject (ActionMetadata name comment defn _) =
|
||
MetadataObject (MOAction name) (toJSON $ CreateAction name defn comment)
|
||
|
||
mkRemoteSchemaMetadataObject remoteSchema =
|
||
MetadataObject (MORemoteSchema (_rsmName remoteSchema)) (toJSON remoteSchema)
|
||
|
||
mkInheritedRoleMetadataObject inheritedRole@(Role roleName _) =
|
||
MetadataObject (MOInheritedRole roleName) (toJSON inheritedRole)
|
||
|
||
alignExtraRemoteSchemaInfo ::
|
||
forall a b arr.
|
||
(ArrowChoice arr, Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr) =>
|
||
(b -> MetadataObject) ->
|
||
( M.HashMap RemoteSchemaName a,
|
||
M.HashMap RemoteSchemaName [b]
|
||
)
|
||
`arr` M.HashMap RemoteSchemaName (a, [b])
|
||
alignExtraRemoteSchemaInfo mkMetadataObject = proc (baseInfo, extraInfo) -> do
|
||
combinedInfo <-
|
||
(|
|
||
Inc.keyed
|
||
(\remoteSchemaName infos -> combine -< (remoteSchemaName, infos))
|
||
|) (align baseInfo extraInfo)
|
||
returnA -< M.catMaybes combinedInfo
|
||
where
|
||
combine :: (RemoteSchemaName, These a [b]) `arr` Maybe (a, [b])
|
||
combine = proc (remoteSchemaName, infos) -> case infos of
|
||
This base -> returnA -< Just (base, [])
|
||
These base extras -> returnA -< Just (base, extras)
|
||
That extras -> do
|
||
let errorMessage = "remote schema " <> unRemoteSchemaName remoteSchemaName <<> " does not exist"
|
||
recordInconsistencies -< (map mkMetadataObject extras, errorMessage)
|
||
returnA -< Nothing
|
||
|
||
buildRemoteSchemaPermissions ::
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
Inc.ArrowCache m arr,
|
||
MonadError QErr m
|
||
) =>
|
||
(RemoteSchemaCtx, [AddRemoteSchemaPermission]) `arr` M.HashMap RoleName IntrospectionResult
|
||
buildRemoteSchemaPermissions = buildInfoMap _arspRole mkRemoteSchemaPermissionMetadataObject buildRemoteSchemaPermission
|
||
where
|
||
buildRemoteSchemaPermission = proc (remoteSchemaCtx, remoteSchemaPerm) -> do
|
||
let AddRemoteSchemaPermission rsName roleName defn _ = remoteSchemaPerm
|
||
metadataObject = mkRemoteSchemaPermissionMetadataObject remoteSchemaPerm
|
||
schemaObject = SORemoteSchemaPermission rsName roleName
|
||
providedSchemaDoc = _rspdSchema defn
|
||
addPermContext err = "in remote schema permission for role " <> roleName <<> ": " <> err
|
||
(|
|
||
withRecordInconsistency
|
||
( (|
|
||
modifyErrA
|
||
( do
|
||
bindErrorA
|
||
-<
|
||
when (roleName == adminRoleName) $
|
||
throw400 ConstraintViolation $ "cannot define permission for admin role"
|
||
(resolvedSchemaIntrospection, dependencies) <-
|
||
bindErrorA -< resolveRoleBasedRemoteSchema providedSchemaDoc remoteSchemaCtx
|
||
recordDependencies -< (metadataObject, schemaObject, dependencies)
|
||
returnA -< resolvedSchemaIntrospection
|
||
)
|
||
|) addPermContext
|
||
)
|
||
|) metadataObject
|
||
|
||
buildTableEventTriggers ::
|
||
forall arr m b.
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
Inc.ArrowCache m arr,
|
||
MonadIO m,
|
||
MonadError QErr m,
|
||
MonadBaseControl IO m,
|
||
MonadReader BuildReason m,
|
||
HasServerConfigCtx m,
|
||
BackendMetadata b,
|
||
BackendEventTrigger b
|
||
) =>
|
||
( SourceName,
|
||
SourceConfig b,
|
||
TableCoreInfo b,
|
||
[EventTriggerConf b],
|
||
Inc.Dependency Inc.InvalidationKey,
|
||
RecreateEventTriggers
|
||
)
|
||
`arr` (EventTriggerInfoMap b)
|
||
buildTableEventTriggers = proc (sourceName, sourceConfig, tableInfo, eventTriggerConfs, metadataInvalidationKey, recreateEventTriggers) ->
|
||
buildInfoMap (etcName . (^. _6)) (mkEventTriggerMetadataObject @b) buildEventTrigger
|
||
-<
|
||
(tableInfo, map (metadataInvalidationKey,sourceName,sourceConfig,_tciName tableInfo,recreateEventTriggers,) eventTriggerConfs)
|
||
where
|
||
buildEventTrigger = proc (tableInfo, (metadataInvalidationKey, source, sourceConfig, table, recreateEventTriggers, eventTriggerConf)) -> do
|
||
let triggerName = etcName eventTriggerConf
|
||
metadataObject = mkEventTriggerMetadataObject @b (metadataInvalidationKey, source, sourceConfig, table, recreateEventTriggers, eventTriggerConf)
|
||
schemaObjectId =
|
||
SOSourceObj source $
|
||
AB.mkAnyBackend $
|
||
SOITableObj @b table $
|
||
TOTrigger triggerName
|
||
addTriggerContext e = "in event trigger " <> triggerName <<> ": " <> e
|
||
buildReason <- bindA -< ask
|
||
let reloadMetadataRecreateEventTrigger =
|
||
case buildReason of
|
||
CatalogSync -> RETDoNothing
|
||
CatalogUpdate Nothing -> RETDoNothing
|
||
CatalogUpdate (Just sources) -> if source `elem` sources then RETRecreate else RETDoNothing
|
||
(|
|
||
withRecordInconsistency
|
||
( (|
|
||
modifyErrA
|
||
( do
|
||
(info, dependencies) <- bindErrorA -< buildEventTriggerInfo @b env source table eventTriggerConf
|
||
recreateTriggerIfNeeded
|
||
-<
|
||
( table,
|
||
(_tciFieldInfoMap tableInfo),
|
||
triggerName,
|
||
etcDefinition eventTriggerConf,
|
||
sourceConfig,
|
||
(_tciPrimaryKey tableInfo),
|
||
recreateEventTriggers <> reloadMetadataRecreateEventTrigger
|
||
)
|
||
recordDependencies -< (metadataObject, schemaObjectId, dependencies)
|
||
returnA -< info
|
||
)
|
||
|) (addTableContext @b table . addTriggerContext)
|
||
)
|
||
|) metadataObject
|
||
|
||
recreateTriggerIfNeeded =
|
||
-- using `Inc.cache` here means that the response will be cached for the given output and the
|
||
-- next time this arrow recieves the same input, the cached response will be returned and the
|
||
-- computation will not be done again.
|
||
Inc.cache
|
||
proc
|
||
( tableName,
|
||
tableFieldInfoMap,
|
||
triggerName,
|
||
triggerDefinition,
|
||
sourceConfig,
|
||
primaryKey,
|
||
recreateEventTriggers
|
||
)
|
||
-> do
|
||
bindA
|
||
-< do
|
||
let tableColumns = M.elems $ M.mapMaybe (^? _FIColumn) tableFieldInfoMap
|
||
buildReason <- ask
|
||
serverConfigCtx <- askServerConfigCtx
|
||
let isCatalogUpdate =
|
||
case buildReason of
|
||
CatalogUpdate _ -> True
|
||
CatalogSync -> False
|
||
-- we don't modify the existing event trigger definitions in the maintenance mode or in read-only mode
|
||
when
|
||
( (isCatalogUpdate || recreateEventTriggers == RETRecreate)
|
||
&& _sccMaintenanceMode serverConfigCtx == MaintenanceModeDisabled
|
||
&& _sccReadOnlyMode serverConfigCtx == ReadOnlyModeDisabled
|
||
)
|
||
$ liftEitherM $
|
||
createTableEventTrigger
|
||
serverConfigCtx
|
||
sourceConfig
|
||
tableName
|
||
tableColumns
|
||
triggerName
|
||
triggerDefinition
|
||
primaryKey
|
||
|
||
buildCronTriggers ::
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
Inc.ArrowCache m arr,
|
||
MonadError QErr m
|
||
) =>
|
||
((), [CronTriggerMetadata])
|
||
`arr` HashMap TriggerName CronTriggerInfo
|
||
buildCronTriggers = buildInfoMap ctName mkCronTriggerMetadataObject buildCronTrigger
|
||
where
|
||
buildCronTrigger = proc (_, cronTrigger) -> do
|
||
let triggerName = triggerNameToTxt $ ctName cronTrigger
|
||
addCronTriggerContext e = "in cron trigger " <> triggerName <> ": " <> e
|
||
(|
|
||
withRecordInconsistency
|
||
( (|
|
||
modifyErrA
|
||
(bindErrorA -< resolveCronTrigger env cronTrigger)
|
||
|) addCronTriggerContext
|
||
)
|
||
|) (mkCronTriggerMetadataObject cronTrigger)
|
||
|
||
buildInheritedRoles ::
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
Inc.ArrowCache m arr,
|
||
MonadError QErr m
|
||
) =>
|
||
(HashSet RoleName, [InheritedRole])
|
||
`arr` HashMap RoleName Role
|
||
buildInheritedRoles = buildInfoMap _rRoleName mkInheritedRoleMetadataObject buildInheritedRole
|
||
where
|
||
buildInheritedRole = proc (allRoles, inheritedRole) -> do
|
||
let addInheritedRoleContext e = "in inherited role " <> roleNameToTxt (_rRoleName inheritedRole) <> ": " <> e
|
||
metadataObject = mkInheritedRoleMetadataObject inheritedRole
|
||
schemaObject = SORole $ _rRoleName inheritedRole
|
||
(|
|
||
withRecordInconsistency
|
||
( (|
|
||
modifyErrA
|
||
( do
|
||
(resolvedInheritedRole, dependencies) <- bindA -< resolveInheritedRole allRoles inheritedRole
|
||
recordDependencies -< (metadataObject, schemaObject, dependencies)
|
||
returnA -< resolvedInheritedRole
|
||
)
|
||
|) addInheritedRoleContext
|
||
)
|
||
|) metadataObject
|
||
|
||
buildActions ::
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
Inc.ArrowCache m arr,
|
||
ArrowWriter (Seq CollectedInfo) arr
|
||
) =>
|
||
( (AnnotatedCustomTypes, DMap.DMap BackendTag ScalarSet, OrderedRoles),
|
||
[ActionMetadata]
|
||
)
|
||
`arr` HashMap ActionName ActionInfo
|
||
buildActions = buildInfoMap _amName mkActionMetadataObject buildAction
|
||
where
|
||
buildAction = proc ((resolvedCustomTypes, scalarsMap, orderedRoles), action) -> do
|
||
let ActionMetadata name comment def actionPermissions = action
|
||
addActionContext e = "in action " <> name <<> "; " <> e
|
||
(|
|
||
withRecordInconsistency
|
||
( (|
|
||
modifyErrA
|
||
( do
|
||
(resolvedDef, outObject) <-
|
||
liftEitherA <<< bindA
|
||
-<
|
||
runExceptT $ resolveAction env resolvedCustomTypes def scalarsMap
|
||
let permissionInfos = map (ActionPermissionInfo . _apmRole) actionPermissions
|
||
metadataPermissionMap = mapFromL _apiRole permissionInfos
|
||
permissionsMap = mkBooleanPermissionMap ActionPermissionInfo metadataPermissionMap orderedRoles
|
||
forwardClientHeaders = _adForwardClientHeaders resolvedDef
|
||
outputType = unGraphQLType $ _adOutputType def
|
||
returnA -< ActionInfo name (outputType, outObject) resolvedDef permissionsMap forwardClientHeaders comment
|
||
)
|
||
|) addActionContext
|
||
)
|
||
|) (mkActionMetadataObject action)
|
||
|
||
buildRemoteSchemas ::
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
Inc.ArrowCache m arr,
|
||
MonadIO m,
|
||
HasHttpManagerM m
|
||
) =>
|
||
( Inc.Dependency (HashMap RemoteSchemaName Inc.InvalidationKey),
|
||
[RemoteSchemaMetadata]
|
||
)
|
||
`arr` HashMap RemoteSchemaName ((RemoteSchemaCtx, SchemaRemoteRelationships), MetadataObject)
|
||
buildRemoteSchemas =
|
||
buildInfoMapPreservingMetadata _rsmName mkRemoteSchemaMetadataObject buildRemoteSchema
|
||
where
|
||
-- We want to cache this call because it fetches the remote schema over HTTP, and we don’t
|
||
-- want to re-run that if the remote schema definition hasn’t changed.
|
||
buildRemoteSchema = Inc.cache proc (invalidationKeys, remoteSchema@(RemoteSchemaMetadata name defn comment _ relationships)) -> do
|
||
-- TODO is it strange how we convert from RemoteSchemaMetadata back
|
||
-- to AddRemoteSchemaQuery here? Document types please.
|
||
let addRemoteSchemaQuery = AddRemoteSchemaQuery name defn comment
|
||
Inc.dependOn -< Inc.selectKeyD name invalidationKeys
|
||
(|
|
||
withRecordInconsistency
|
||
( liftEitherA <<< bindA
|
||
-<
|
||
(fmap . fmap) (,relationships) $
|
||
runExceptT $ noopTrace $ addRemoteSchemaP2Setup env addRemoteSchemaQuery
|
||
)
|
||
|) (mkRemoteSchemaMetadataObject remoteSchema)
|
||
-- TODO continue propagating MonadTrace up calls so that we can get tracing for remote schema introspection.
|
||
-- This will require modifying CacheBuild.
|
||
noopTrace = Tracing.runTraceTWithReporter Tracing.noReporter "buildSchemaCacheRule"
|
||
|
||
buildRemoteSchemaRemoteRelationship ::
|
||
forall arr m.
|
||
( ArrowChoice arr,
|
||
ArrowWriter (Seq CollectedInfo) arr,
|
||
ArrowKleisli m arr,
|
||
MonadError QErr m
|
||
) =>
|
||
( (HashMap SourceName (AB.AnyBackend PartiallyResolvedSource), RemoteSchemaMap),
|
||
(RemoteSchemaName, RemoteSchemaIntrospection, G.Name, RemoteRelationship)
|
||
)
|
||
`arr` Maybe (RemoteFieldInfo G.Name)
|
||
buildRemoteSchemaRemoteRelationship =
|
||
proc
|
||
( (allSources, remoteSchemaMap),
|
||
(remoteSchema, remoteSchemaIntrospection, typeName, rr@RemoteRelationship {..})
|
||
)
|
||
-> do
|
||
let metadataObject = mkRemoteSchemaRemoteRelationshipMetadataObject (remoteSchema, typeName, rr)
|
||
schemaObj = SORemoteSchemaRemoteRelationship remoteSchema typeName _rrName
|
||
addRemoteRelationshipContext e = "in remote relationship" <> _rrName <<> ": " <> e
|
||
(|
|
||
withRecordInconsistency
|
||
( (|
|
||
modifyErrA
|
||
( do
|
||
allowedLHSJoinFields <-
|
||
bindErrorA
|
||
-<
|
||
getRemoteSchemaEntityJoinColumns remoteSchema remoteSchemaIntrospection typeName
|
||
(remoteField, rhsDependencies) <-
|
||
bindErrorA
|
||
-<
|
||
buildRemoteFieldInfo (remoteSchemaToLHSIdentifier remoteSchema) allowedLHSJoinFields rr allSources remoteSchemaMap
|
||
-- buildRemoteFieldInfo only knows how to construct dependencies on the RHS of the join condition,
|
||
-- so the dependencies on the remote relationship on the LHS entity have to be computed here
|
||
let lhsDependencies =
|
||
-- a direct dependency on the remote schema on which this is defined
|
||
[SchemaDependency (SORemoteSchema remoteSchema) DRRemoteRelationship]
|
||
recordDependencies -< (metadataObject, schemaObj, lhsDependencies <> rhsDependencies)
|
||
returnA -< remoteField
|
||
)
|
||
|) addRemoteRelationshipContext
|
||
)
|
||
|) metadataObject
|
||
|
||
mkRemoteSchemaRemoteRelationshipMetadataObject ::
|
||
(RemoteSchemaName, G.Name, RemoteRelationship) ->
|
||
MetadataObject
|
||
mkRemoteSchemaRemoteRelationshipMetadataObject (remoteSchemaName, typeName, RemoteRelationship {..}) =
|
||
let objectId =
|
||
MORemoteSchemaRemoteRelationship remoteSchemaName typeName _rrName
|
||
in MetadataObject objectId $
|
||
toJSON $
|
||
CreateRemoteSchemaRemoteRelationship remoteSchemaName typeName _rrName _rrDefinition
|
||
|
||
{- Note [Keep invalidation keys for inconsistent objects]
|
||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
After building the schema cache, we prune InvalidationKeys for objects
|
||
that no longer exist in the schema to avoid leaking memory for objects
|
||
that have been dropped. However, note that we *don’t* want to drop
|
||
keys for objects that are simply inconsistent!
|
||
|
||
Why? The object is still in the metadata, so next time we reload it,
|
||
we’ll reprocess that object. We want to reuse the cache if its
|
||
definition hasn’t changed, but if we dropped the invalidation key, it
|
||
will incorrectly be reprocessed (since the invalidation key changed
|
||
from present to absent). -}
|