mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-15 01:12:56 +03:00
Clean AppEnv
and AppContext
passing, remove RunT
, reduce ServerConfigCtx
uses
## Description This PR does several different things that happen to overlap; the most important being: - it removes `RunT`: it was redundant in places where we already had `Handler`, and only used in one other place, `SchemaUpdate`, for which a local `SchemaUpdateT` is more than enough; - it reduces the number of places where we create a `ServerConfigCtx`, since now `HasServerConfigCtx` can be implemented directly by `SchemaUpdateT` and `Handler` based on the full `AppContext`; - it drastically reduces the number of arguments we pass around in the app init code, by introducing `HasAppEnv`; - it simplifies `HandlerCtx` to reduce duplication In doing so, this changes paves the way towards removing `ServerConfigCtx`, since there are only very few places where we construct it: we can now introduce smaller classes than `HasServerConfigCtx`, that expose only a relevant subset of fields, and implement them where we now implement `HasServerConfigCtx`. This PR is loosely based on ideas in #8337, that are no longer applicable due to the changes introduced in #8159. A challenge of this PR was the postgres tests, which were running in `PGMetadataStorageAppT CacheBuild` 🙀 PR-URL: https://github.com/hasura/graphql-engine-mono/pull/8392 GitOrigin-RevId: b90c1359066d20dbea329c87762ccdd1217b4d69
This commit is contained in:
parent
eba0a3fb33
commit
0a1628c0cc
@ -731,7 +731,6 @@ library
|
||||
, Hasura.GraphQL.Logging.QueryLog
|
||||
, Hasura.GraphQL.Logging.ExecutionLog
|
||||
, Hasura.RQL.DML.Select
|
||||
, Hasura.RQL.Types.Run
|
||||
, Hasura.Session
|
||||
|
||||
, Hasura.Server.API.Config
|
||||
|
@ -294,6 +294,9 @@ newtype PGMetadataStorageAppT m a = PGMetadataStorageAppT (ReaderT AppEnv (Trace
|
||||
MonadBaseControl b
|
||||
)
|
||||
|
||||
instance Monad m => HasAppEnv (PGMetadataStorageAppT m) where
|
||||
askAppEnv = ask
|
||||
|
||||
instance (MonadIO m, MonadBaseControl IO m) => MonadTrace (PGMetadataStorageAppT m) where
|
||||
newTraceWith c p n (PGMetadataStorageAppT a) = PGMetadataStorageAppT $ newTraceWith c p n a
|
||||
newSpanWith i n (PGMetadataStorageAppT a) = PGMetadataStorageAppT $ newSpanWith i n a
|
||||
@ -306,9 +309,6 @@ instance MonadTrans PGMetadataStorageAppT where
|
||||
instance Monad m => ProvidesNetwork (PGMetadataStorageAppT m) where
|
||||
askHTTPManager = asks appEnvManager
|
||||
|
||||
instance HasServerConfigCtx m => HasServerConfigCtx (PGMetadataStorageAppT m) where
|
||||
askServerConfigCtx = lift askServerConfigCtx
|
||||
|
||||
runPGMetadataStorageAppT :: AppEnv -> PGMetadataStorageAppT m a -> m a
|
||||
runPGMetadataStorageAppT c (PGMetadataStorageAppT a) = ignoreTraceT $ runReaderT a c
|
||||
|
||||
@ -595,6 +595,7 @@ runHGEServer ::
|
||||
LA.Forall (LA.Pure m),
|
||||
UserAuthentication m,
|
||||
HttpLog m,
|
||||
HasAppEnv m,
|
||||
ConsoleRenderer m,
|
||||
MonadVersionAPIWithExtraData m,
|
||||
MonadMetadataApiAuthorization m,
|
||||
@ -687,6 +688,7 @@ mkHGEServer ::
|
||||
LA.Forall (LA.Pure m),
|
||||
UserAuthentication m,
|
||||
HttpLog m,
|
||||
HasAppEnv m,
|
||||
ConsoleRenderer m,
|
||||
MonadVersionAPIWithExtraData m,
|
||||
MonadMetadataApiAuthorization m,
|
||||
@ -757,18 +759,7 @@ mkHGEServer setupHook appStateRef appEnv@AppEnv {..} ekgStore = do
|
||||
newLogTVar <- liftIO $ STM.newTVarIO False
|
||||
|
||||
-- Start a background thread for processing schema sync event present in the '_sscSyncEventRef'
|
||||
_ <-
|
||||
startSchemaSyncProcessorThread
|
||||
logger
|
||||
appEnvManager
|
||||
appEnvMetaVersionRef
|
||||
appStateRef
|
||||
appEnvInstanceId
|
||||
appEnvEnableMaintenanceMode
|
||||
appEnvEventingMode
|
||||
appEnvEnableReadOnlyMode
|
||||
newLogTVar
|
||||
appEnvCheckFeatureFlag
|
||||
_ <- startSchemaSyncProcessorThread appStateRef newLogTVar
|
||||
|
||||
case appEnvEventingMode of
|
||||
EventingEnabled -> do
|
||||
|
@ -1,10 +1,16 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
|
||||
module Hasura.App.State
|
||||
( RebuildableAppContext (..),
|
||||
( -- * application state
|
||||
RebuildableAppContext (..),
|
||||
AppEnv (..),
|
||||
AppContext (..),
|
||||
Loggers (..),
|
||||
|
||||
-- * env access
|
||||
HasAppEnv (..),
|
||||
|
||||
-- * init functions
|
||||
buildRebuildableAppContext,
|
||||
initSQLGenCtx,
|
||||
)
|
||||
@ -44,6 +50,9 @@ import Network.Wai.Handler.Warp (HostPreference)
|
||||
import Network.WebSockets.Connection qualified as WebSockets
|
||||
import Refined (NonNegative, Refined)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- application state
|
||||
|
||||
{- Note [Hasura Application State]
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
Hasura Application state represents the entire state of hasura.
|
||||
@ -151,6 +160,35 @@ data Loggers = Loggers
|
||||
|
||||
data InvalidationKeys = InvalidationKeys
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- env access
|
||||
|
||||
-- | Provides access to the 'AppEnv'.
|
||||
--
|
||||
-- This class is nothing more than an equivalent of @MonadReader AppEnv m@, but
|
||||
-- it abstracts it, so that application code can be written without explicitly
|
||||
-- relying on an explicit implementation of the app monad. It allows for the app
|
||||
-- env to be passed implicitly instead of explictly in all of the app init code.
|
||||
--
|
||||
-- This class is not meant to be used across the entirety of the codebase, as
|
||||
-- using it brings in scope the types of all fields, creating dependencies
|
||||
-- between unrelated parts of the codebase. It is only meant to be used at the
|
||||
-- top level; more specific parts of the code should only rely on the relevant
|
||||
-- subset of the environment, exposed by small, local typeclasses. For instance,
|
||||
-- at time of writing, this can be used to implement 'HasServerConfigCtx', as a
|
||||
-- first step towards breaking it down.
|
||||
class Monad m => HasAppEnv m where
|
||||
askAppEnv :: m AppEnv
|
||||
|
||||
instance (HasAppEnv m) => HasAppEnv (ReaderT r m) where
|
||||
askAppEnv = lift askAppEnv
|
||||
|
||||
instance (HasAppEnv m) => HasAppEnv (ExceptT e m) where
|
||||
askAppEnv = lift askAppEnv
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- init functions
|
||||
|
||||
initInvalidationKeys :: InvalidationKeys
|
||||
initInvalidationKeys = InvalidationKeys
|
||||
|
||||
|
@ -40,7 +40,6 @@ import Hasura.RQL.Types.Column (ColumnType, fromCol)
|
||||
import Hasura.RQL.Types.Common
|
||||
import Hasura.RQL.Types.QueryTags (QueryTagsConfig)
|
||||
import Hasura.RQL.Types.ResultCustomization
|
||||
import Hasura.RQL.Types.Run (RunT (..))
|
||||
import Hasura.RQL.Types.SchemaCache.Build (MetadataT (..))
|
||||
import Hasura.RemoteSchema.SchemaCache
|
||||
import Hasura.SQL.AnyBackend qualified as AB
|
||||
@ -330,6 +329,7 @@ data ExecutionStep where
|
||||
-- this will need to be changed into an annotated tree.
|
||||
type ExecutionPlan = RootFieldMap ExecutionStep
|
||||
|
||||
-- TODO: move this to a new module.
|
||||
class (Monad m) => MonadQueryTags m where
|
||||
-- | Creates Query Tags. These are appended to the Generated SQL.
|
||||
-- Helps users to use native database monitoring tools to get some 'application-context'.
|
||||
@ -353,6 +353,3 @@ instance (MonadQueryTags m) => MonadQueryTags (MetadataT m) where
|
||||
|
||||
instance (MonadQueryTags m) => MonadQueryTags (CacheRWT m) where
|
||||
createQueryTags qtSourceConfig attr = retag (createQueryTags @m qtSourceConfig attr) :: Tagged (CacheRWT m) QueryTagsComment
|
||||
|
||||
instance (MonadQueryTags m) => MonadQueryTags (RunT m) where
|
||||
createQueryTags qtSourceConfig attr = retag (createQueryTags @m qtSourceConfig attr) :: Tagged (RunT m) QueryTagsComment
|
||||
|
@ -1,57 +0,0 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Hasura.RQL.Types.Run
|
||||
( RunT (..),
|
||||
RunCtx (..),
|
||||
peelRun,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Trans
|
||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||
import Hasura.Metadata.Class
|
||||
import Hasura.Prelude
|
||||
import Hasura.RQL.DDL.ApiLimit (MonadGetApiTimeLimit (..))
|
||||
import Hasura.RQL.DDL.EventTrigger (MonadEventLogCleanup (..))
|
||||
import Hasura.RQL.Types.Source
|
||||
import Hasura.Server.Types
|
||||
import Hasura.Services
|
||||
import Hasura.Session
|
||||
import Hasura.Tracing qualified as Tracing
|
||||
|
||||
data RunCtx = RunCtx
|
||||
{ _rcUserInfo :: UserInfo,
|
||||
_rcServerConfigCtx :: ServerConfigCtx
|
||||
}
|
||||
|
||||
newtype RunT m a = RunT {unRunT :: RunCtx -> m a}
|
||||
deriving
|
||||
( Functor,
|
||||
Applicative,
|
||||
Monad,
|
||||
MonadError e,
|
||||
MonadIO,
|
||||
Tracing.MonadTrace,
|
||||
MonadBase b,
|
||||
MonadBaseControl b,
|
||||
MonadMetadataStorage,
|
||||
MonadMetadataStorageQueryAPI,
|
||||
ProvidesNetwork,
|
||||
MonadResolveSource,
|
||||
MonadEventLogCleanup,
|
||||
MonadGetApiTimeLimit
|
||||
)
|
||||
via (ReaderT RunCtx m)
|
||||
deriving (MonadTrans) via (ReaderT RunCtx)
|
||||
|
||||
instance (Monad m) => UserInfoM (RunT m) where
|
||||
askUserInfo = RunT $ pure . _rcUserInfo
|
||||
|
||||
instance (Monad m) => HasServerConfigCtx (RunT m) where
|
||||
askServerConfigCtx = RunT $ pure . _rcServerConfigCtx
|
||||
|
||||
peelRun ::
|
||||
RunCtx ->
|
||||
RunT m a ->
|
||||
m a
|
||||
peelRun = flip unRunT
|
@ -18,6 +18,7 @@ import Data.Has (Has)
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Extended qualified as T
|
||||
import GHC.Generics.Extended (constrName)
|
||||
import Hasura.App.State
|
||||
import Hasura.Base.Error
|
||||
import Hasura.EncJSON
|
||||
import Hasura.Logging qualified as L
|
||||
@ -66,7 +67,6 @@ import Hasura.RQL.Types.OpenTelemetry
|
||||
import Hasura.RQL.Types.Permission
|
||||
import Hasura.RQL.Types.QueryCollection
|
||||
import Hasura.RQL.Types.Roles
|
||||
import Hasura.RQL.Types.Run
|
||||
import Hasura.RQL.Types.ScheduledTrigger
|
||||
import Hasura.RQL.Types.SchemaCache
|
||||
import Hasura.RQL.Types.SchemaCache.Build
|
||||
@ -381,22 +381,23 @@ runMetadataQuery ::
|
||||
( MonadIO m,
|
||||
MonadError QErr m,
|
||||
MonadBaseControl IO m,
|
||||
HasAppEnv m,
|
||||
Tracing.MonadTrace m,
|
||||
MonadMetadataStorageQueryAPI m,
|
||||
MonadResolveSource m,
|
||||
MonadEventLogCleanup m,
|
||||
ProvidesHasuraServices m,
|
||||
MonadGetApiTimeLimit m
|
||||
MonadGetApiTimeLimit m,
|
||||
UserInfoM m,
|
||||
HasServerConfigCtx m
|
||||
) =>
|
||||
Env.Environment ->
|
||||
L.Logger L.Hasura ->
|
||||
InstanceId ->
|
||||
UserInfo ->
|
||||
ServerConfigCtx ->
|
||||
AppContext ->
|
||||
RebuildableSchemaCache ->
|
||||
RQLMetadata ->
|
||||
m (EncJSON, RebuildableSchemaCache)
|
||||
runMetadataQuery env logger instanceId userInfo serverConfigCtx schemaCache RQLMetadata {..} = do
|
||||
runMetadataQuery appContext schemaCache RQLMetadata {..} = do
|
||||
AppEnv {..} <- askAppEnv
|
||||
let logger = _lsLogger appEnvLoggers
|
||||
(metadata, currentResourceVersion) <- Tracing.newSpan "fetchMetadata" $ liftEitherM fetchMetadata
|
||||
let exportsMetadata = \case
|
||||
RMV1 (RMExportMetadata _) -> True
|
||||
@ -420,16 +421,16 @@ runMetadataQuery env logger instanceId userInfo serverConfigCtx schemaCache RQLM
|
||||
--
|
||||
if (exportsMetadata _rqlMetadata || queryModifiesMetadata _rqlMetadata)
|
||||
then emptyMetadataDefaults
|
||||
else _sccMetadataDefaults serverConfigCtx
|
||||
else acMetadataDefaults appContext
|
||||
((r, modMetadata), modSchemaCache, cacheInvalidations) <-
|
||||
runMetadataQueryM env currentResourceVersion _rqlMetadata
|
||||
runMetadataQueryM (acEnvironment appContext) currentResourceVersion _rqlMetadata
|
||||
-- TODO: remove this straight runReaderT that provides no actual new info
|
||||
& flip runReaderT logger
|
||||
& runMetadataT metadata metadataDefaults
|
||||
& runCacheRWT schemaCache
|
||||
& peelRun (RunCtx userInfo serverConfigCtx)
|
||||
-- set modified metadata in storage
|
||||
if queryModifiesMetadata _rqlMetadata
|
||||
then case (_sccMaintenanceMode serverConfigCtx, _sccReadOnlyMode serverConfigCtx) of
|
||||
then case (appEnvEnableMaintenanceMode, appEnvEnableReadOnlyMode) of
|
||||
(MaintenanceModeDisabled, ReadOnlyModeDisabled) -> do
|
||||
-- set modified metadata in storage
|
||||
L.unLogger logger $
|
||||
@ -448,7 +449,7 @@ runMetadataQuery env logger instanceId userInfo serverConfigCtx schemaCache RQLM
|
||||
-- notify schema cache sync
|
||||
Tracing.newSpan "notifySchemaCacheSync" $
|
||||
liftEitherM $
|
||||
notifySchemaCacheSync newResourceVersion instanceId cacheInvalidations
|
||||
notifySchemaCacheSync newResourceVersion appEnvInstanceId cacheInvalidations
|
||||
L.unLogger logger $
|
||||
SchemaSyncLog L.LevelInfo TTMetadataApi $
|
||||
String $
|
||||
@ -458,7 +459,6 @@ runMetadataQuery env logger instanceId userInfo serverConfigCtx schemaCache RQLM
|
||||
Tracing.newSpan "setMetadataResourceVersionInSchemaCache" $
|
||||
setMetadataResourceVersionInSchemaCache newResourceVersion
|
||||
& runCacheRWT modSchemaCache
|
||||
& peelRun (RunCtx userInfo serverConfigCtx)
|
||||
|
||||
pure (r, modSchemaCache')
|
||||
(MaintenanceModeEnabled (), ReadOnlyModeDisabled) ->
|
||||
|
@ -15,6 +15,7 @@ import Data.Aeson.Casing
|
||||
import Data.Aeson.TH
|
||||
import Data.Environment qualified as Env
|
||||
import Data.Has (Has)
|
||||
import Hasura.App.State
|
||||
import Hasura.Backends.Postgres.DDL.RunSQL
|
||||
import Hasura.Base.Error
|
||||
import Hasura.EncJSON
|
||||
@ -49,7 +50,6 @@ import Hasura.RQL.Types.Endpoint
|
||||
import Hasura.RQL.Types.Metadata
|
||||
import Hasura.RQL.Types.Permission
|
||||
import Hasura.RQL.Types.QueryCollection
|
||||
import Hasura.RQL.Types.Run
|
||||
import Hasura.RQL.Types.ScheduledTrigger
|
||||
import Hasura.RQL.Types.SchemaCache.Build
|
||||
import Hasura.RQL.Types.Source
|
||||
@ -177,6 +177,7 @@ $( concat
|
||||
runQuery ::
|
||||
( MonadIO m,
|
||||
MonadError QErr m,
|
||||
HasAppEnv m,
|
||||
Tracing.MonadTrace m,
|
||||
MonadBaseControl IO m,
|
||||
MonadMetadataStorageQueryAPI m,
|
||||
@ -184,18 +185,18 @@ runQuery ::
|
||||
MonadQueryTags m,
|
||||
MonadEventLogCleanup m,
|
||||
ProvidesHasuraServices m,
|
||||
MonadGetApiTimeLimit m
|
||||
MonadGetApiTimeLimit m,
|
||||
UserInfoM m,
|
||||
HasServerConfigCtx m
|
||||
) =>
|
||||
Env.Environment ->
|
||||
L.Logger L.Hasura ->
|
||||
InstanceId ->
|
||||
UserInfo ->
|
||||
AppContext ->
|
||||
RebuildableSchemaCache ->
|
||||
ServerConfigCtx ->
|
||||
RQLQuery ->
|
||||
m (EncJSON, RebuildableSchemaCache)
|
||||
runQuery env logger instanceId userInfo sc serverConfigCtx query = do
|
||||
when ((_sccReadOnlyMode serverConfigCtx == ReadOnlyModeEnabled) && queryModifiesUserDB query) $
|
||||
runQuery appContext sc query = do
|
||||
AppEnv {..} <- askAppEnv
|
||||
let logger = _lsLogger appEnvLoggers
|
||||
when ((appEnvEnableReadOnlyMode == ReadOnlyModeEnabled) && queryModifiesUserDB query) $
|
||||
throw400 NotSupported "Cannot run write queries when read-only mode is enabled"
|
||||
|
||||
let exportsMetadata = \case
|
||||
@ -204,32 +205,25 @@ runQuery env logger instanceId userInfo sc serverConfigCtx query = do
|
||||
metadataDefaults =
|
||||
if (exportsMetadata query)
|
||||
then emptyMetadataDefaults
|
||||
else _sccMetadataDefaults serverConfigCtx
|
||||
else acMetadataDefaults appContext
|
||||
|
||||
(metadata, currentResourceVersion) <- liftEitherM fetchMetadata
|
||||
result <-
|
||||
runReaderT (runQueryM env query) logger & \x -> do
|
||||
((js, meta), rsc, ci) <-
|
||||
x
|
||||
& runMetadataT metadata metadataDefaults
|
||||
& runCacheRWT sc
|
||||
& peelRun runCtx
|
||||
pure (js, rsc, ci, meta)
|
||||
withReload currentResourceVersion result
|
||||
where
|
||||
runCtx = RunCtx userInfo serverConfigCtx
|
||||
|
||||
withReload currentResourceVersion (result, updatedCache, invalidations, updatedMetadata) = do
|
||||
when (queryModifiesSchemaCache query) $ do
|
||||
case (_sccMaintenanceMode serverConfigCtx) of
|
||||
MaintenanceModeDisabled -> do
|
||||
-- set modified metadata in storage
|
||||
newResourceVersion <- liftEitherM $ setMetadata currentResourceVersion updatedMetadata
|
||||
-- notify schema cache sync
|
||||
liftEitherM $ notifySchemaCacheSync newResourceVersion instanceId invalidations
|
||||
MaintenanceModeEnabled () ->
|
||||
throw500 "metadata cannot be modified in maintenance mode"
|
||||
pure (result, updatedCache)
|
||||
((result, updatedMetadata), updatedCache, invalidations) <-
|
||||
runQueryM (acEnvironment appContext) query
|
||||
-- TODO: remove this straight runReaderT that provides no actual new info
|
||||
& flip runReaderT logger
|
||||
& runMetadataT metadata metadataDefaults
|
||||
& runCacheRWT sc
|
||||
when (queryModifiesSchemaCache query) $ do
|
||||
case appEnvEnableMaintenanceMode of
|
||||
MaintenanceModeDisabled -> do
|
||||
-- set modified metadata in storage
|
||||
newResourceVersion <- liftEitherM $ setMetadata currentResourceVersion updatedMetadata
|
||||
-- notify schema cache sync
|
||||
liftEitherM $ notifySchemaCacheSync newResourceVersion appEnvInstanceId invalidations
|
||||
MaintenanceModeEnabled () ->
|
||||
throw500 "metadata cannot be modified in maintenance mode"
|
||||
pure (result, updatedCache)
|
||||
|
||||
-- | A predicate that determines whether the given query might modify/rebuild the schema cache. If
|
||||
-- so, it needs to acquire the global lock on the schema cache so that other queries do not modify
|
||||
|
@ -16,6 +16,7 @@ import Data.Aeson.Types (Parser)
|
||||
import Data.Environment qualified as Env
|
||||
import Data.Text qualified as T
|
||||
import GHC.Generics.Extended (constrName)
|
||||
import Hasura.App.State
|
||||
import Hasura.Backends.BigQuery.DDL.RunSQL qualified as BigQuery
|
||||
import Hasura.Backends.DataConnector.Adapter.RunSQL qualified as DataConnector
|
||||
import Hasura.Backends.DataConnector.Adapter.Types (DataConnectorName, mkDataConnectorName)
|
||||
@ -41,7 +42,6 @@ import Hasura.RQL.DML.Types
|
||||
)
|
||||
import Hasura.RQL.DML.Update
|
||||
import Hasura.RQL.Types.Metadata
|
||||
import Hasura.RQL.Types.Run
|
||||
import Hasura.RQL.Types.SchemaCache.Build
|
||||
import Hasura.RQL.Types.Source
|
||||
import Hasura.SQL.Backend
|
||||
@ -105,53 +105,45 @@ runQuery ::
|
||||
( MonadIO m,
|
||||
MonadBaseControl IO m,
|
||||
MonadError QErr m,
|
||||
HasAppEnv m,
|
||||
Tracing.MonadTrace m,
|
||||
MonadMetadataStorage m,
|
||||
MonadResolveSource m,
|
||||
MonadQueryTags m,
|
||||
ProvidesHasuraServices m
|
||||
ProvidesHasuraServices m,
|
||||
UserInfoM m,
|
||||
HasServerConfigCtx m
|
||||
) =>
|
||||
Env.Environment ->
|
||||
InstanceId ->
|
||||
UserInfo ->
|
||||
AppContext ->
|
||||
RebuildableSchemaCache ->
|
||||
ServerConfigCtx ->
|
||||
RQLQuery ->
|
||||
m (EncJSON, RebuildableSchemaCache)
|
||||
runQuery env instanceId userInfo schemaCache serverConfigCtx rqlQuery = do
|
||||
when ((_sccReadOnlyMode serverConfigCtx == ReadOnlyModeEnabled) && queryModifiesUserDB rqlQuery) $
|
||||
runQuery appContext schemaCache rqlQuery = do
|
||||
AppEnv {..} <- askAppEnv
|
||||
when ((appEnvEnableReadOnlyMode == ReadOnlyModeEnabled) && queryModifiesUserDB rqlQuery) $
|
||||
throw400 NotSupported "Cannot run write queries when read-only mode is enabled"
|
||||
|
||||
(metadata, currentResourceVersion) <- Tracing.newSpan "fetchMetadata" $ liftEitherM fetchMetadata
|
||||
result <-
|
||||
runQueryM env rqlQuery & \x -> do
|
||||
((js, meta), rsc, ci) <-
|
||||
-- We can use defaults here unconditionally, since there is no MD export function in V2Query
|
||||
x
|
||||
& runMetadataT metadata (_sccMetadataDefaults serverConfigCtx)
|
||||
& runCacheRWT schemaCache
|
||||
& peelRun runCtx
|
||||
pure (js, rsc, ci, meta)
|
||||
withReload currentResourceVersion result
|
||||
where
|
||||
runCtx = RunCtx userInfo serverConfigCtx
|
||||
|
||||
withReload currentResourceVersion (result, updatedCache, invalidations, updatedMetadata) = do
|
||||
when (queryModifiesSchema rqlQuery) $ do
|
||||
case _sccMaintenanceMode serverConfigCtx of
|
||||
MaintenanceModeDisabled -> do
|
||||
-- set modified metadata in storage
|
||||
newResourceVersion <-
|
||||
Tracing.newSpan "setMetadata" $
|
||||
liftEitherM $
|
||||
setMetadata currentResourceVersion updatedMetadata
|
||||
-- notify schema cache sync
|
||||
Tracing.newSpan "notifySchemaCacheSync" $
|
||||
liftEitherM $
|
||||
notifySchemaCacheSync newResourceVersion instanceId invalidations
|
||||
MaintenanceModeEnabled () ->
|
||||
throw500 "metadata cannot be modified in maintenance mode"
|
||||
pure (result, updatedCache)
|
||||
((result, updatedMetadata), updatedCache, invalidations) <-
|
||||
runQueryM (acEnvironment appContext) rqlQuery
|
||||
-- We can use defaults here unconditionally, since there is no MD export function in V2Query
|
||||
& runMetadataT metadata (acMetadataDefaults appContext)
|
||||
& runCacheRWT schemaCache
|
||||
when (queryModifiesSchema rqlQuery) $ do
|
||||
case appEnvEnableMaintenanceMode of
|
||||
MaintenanceModeDisabled -> do
|
||||
-- set modified metadata in storage
|
||||
newResourceVersion <-
|
||||
Tracing.newSpan "setMetadata" $
|
||||
liftEitherM $
|
||||
setMetadata currentResourceVersion updatedMetadata
|
||||
-- notify schema cache sync
|
||||
Tracing.newSpan "notifySchemaCacheSync" $
|
||||
liftEitherM $
|
||||
notifySchemaCacheSync newResourceVersion appEnvInstanceId invalidations
|
||||
MaintenanceModeEnabled () ->
|
||||
throw500 "metadata cannot be modified in maintenance mode"
|
||||
pure (result, updatedCache)
|
||||
|
||||
queryModifiesSchema :: RQLQuery -> Bool
|
||||
queryModifiesSchema = \case
|
||||
|
@ -6,7 +6,7 @@ module Hasura.Server.App
|
||||
ConsoleRenderer (..),
|
||||
MonadVersionAPIWithExtraData (..),
|
||||
Handler,
|
||||
HandlerCtx (hcReqHeaders, hcAppContext, hcSchemaCache, hcAppEnv, hcUser),
|
||||
HandlerCtx (hcReqHeaders, hcAppContext, hcSchemaCache, hcUser),
|
||||
HasuraApp (HasuraApp),
|
||||
Loggers (..),
|
||||
MonadConfigApiHandler (..),
|
||||
@ -113,14 +113,13 @@ import Web.Spock.Core ((<//>))
|
||||
import Web.Spock.Core qualified as Spock
|
||||
|
||||
data HandlerCtx = HandlerCtx
|
||||
{ hcAppContext :: !AppContext,
|
||||
hcSchemaCache :: !RebuildableSchemaCache,
|
||||
hcSchemaCacheVersion :: !SchemaCacheVer,
|
||||
hcAppEnv :: !AppEnv,
|
||||
hcUser :: !UserInfo,
|
||||
hcReqHeaders :: ![HTTP.Header],
|
||||
hcRequestId :: !RequestId,
|
||||
hcSourceIpAddress :: !Wai.IpAddress
|
||||
{ hcAppContext :: AppContext,
|
||||
hcSchemaCache :: RebuildableSchemaCache,
|
||||
hcSchemaCacheVersion :: SchemaCacheVer,
|
||||
hcUser :: UserInfo,
|
||||
hcReqHeaders :: [HTTP.Header],
|
||||
hcRequestId :: RequestId,
|
||||
hcSourceIpAddress :: Wai.IpAddress
|
||||
}
|
||||
|
||||
newtype Handler m a = Handler (ReaderT HandlerCtx (ExceptT QErr m) a)
|
||||
@ -135,9 +134,9 @@ newtype Handler m a = Handler (ReaderT HandlerCtx (ExceptT QErr m) a)
|
||||
MonadReader HandlerCtx,
|
||||
MonadError QErr,
|
||||
MonadTrace,
|
||||
HasAppEnv,
|
||||
HasResourceLimits,
|
||||
MonadResolveSource,
|
||||
HasServerConfigCtx,
|
||||
E.MonadGQLExecutionCheck,
|
||||
MonadEventLogCleanup,
|
||||
MonadQueryLog,
|
||||
@ -154,6 +153,28 @@ newtype Handler m a = Handler (ReaderT HandlerCtx (ExceptT QErr m) a)
|
||||
instance MonadTrans Handler where
|
||||
lift = Handler . lift . lift
|
||||
|
||||
instance Monad m => UserInfoM (Handler m) where
|
||||
askUserInfo = asks hcUser
|
||||
|
||||
instance (HasAppEnv m) => HasServerConfigCtx (Handler m) where
|
||||
askServerConfigCtx = Handler do
|
||||
AppEnv {..} <- askAppEnv
|
||||
AppContext {..} <- asks hcAppContext
|
||||
pure
|
||||
ServerConfigCtx
|
||||
{ _sccFunctionPermsCtx = acFunctionPermsCtx,
|
||||
_sccRemoteSchemaPermsCtx = acRemoteSchemaPermsCtx,
|
||||
_sccSQLGenCtx = acSQLGenCtx,
|
||||
_sccMaintenanceMode = appEnvEnableMaintenanceMode,
|
||||
_sccExperimentalFeatures = acExperimentalFeatures,
|
||||
_sccEventingMode = appEnvEventingMode,
|
||||
_sccReadOnlyMode = appEnvEnableReadOnlyMode,
|
||||
_sccDefaultNamingConvention = acDefaultNamingConvention,
|
||||
_sccMetadataDefaults = acMetadataDefaults,
|
||||
_sccCheckFeatureFlag = appEnvCheckFeatureFlag,
|
||||
_sccApolloFederationStatus = acApolloFederationStatus
|
||||
}
|
||||
|
||||
runHandler :: (HasResourceLimits m, MonadBaseControl IO m) => HandlerCtx -> Handler m a -> m (Either QErr a)
|
||||
runHandler ctx (Handler r) = do
|
||||
handlerLimit <- askHTTPHandlerLimit
|
||||
@ -268,6 +289,7 @@ mkSpockAction ::
|
||||
forall m a impl.
|
||||
( MonadIO m,
|
||||
MonadBaseControl IO m,
|
||||
HasAppEnv m,
|
||||
FromJSON a,
|
||||
UserAuthentication m,
|
||||
HttpLog m,
|
||||
@ -275,20 +297,20 @@ mkSpockAction ::
|
||||
MonadTrace m
|
||||
) =>
|
||||
AppStateRef impl ->
|
||||
AppEnv ->
|
||||
-- | `QErr` JSON encoder function
|
||||
(Bool -> QErr -> Value) ->
|
||||
-- | `QErr` modifier
|
||||
(QErr -> QErr) ->
|
||||
APIHandler m a ->
|
||||
Spock.ActionT m ()
|
||||
mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler = do
|
||||
mkSpockAction appStateRef qErrEncoder qErrModifier apiHandler = do
|
||||
AppEnv {..} <- lift askAppEnv
|
||||
AppContext {..} <- liftIO $ getAppContext appStateRef
|
||||
req <- Spock.request
|
||||
let origHeaders = Wai.requestHeaders req
|
||||
ipAddress = Wai.getSourceFromFallback req
|
||||
pathInfo = Wai.rawPathInfo req
|
||||
|
||||
AppContext {..} <- liftIO $ getAppContext appStateRef
|
||||
-- Bytes are actually read from the socket here. Time this.
|
||||
(ioWaitTime, reqBody) <- withElapsedTime $ liftIO $ Wai.strictRequestBody req
|
||||
|
||||
@ -330,7 +352,7 @@ mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler
|
||||
pure
|
||||
( userInfo,
|
||||
authHeaders,
|
||||
HandlerCtx appContext schemaCache schemaCacheVer appEnv userInfo headers requestId ipAddress,
|
||||
HandlerCtx appContext schemaCache schemaCacheVer userInfo headers requestId ipAddress,
|
||||
shouldIncludeInternal (_uiRole userInfo) acResponseInternalErrorsConfig,
|
||||
extraUserInfo
|
||||
)
|
||||
@ -378,8 +400,7 @@ mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler
|
||||
logSuccessAndResp (Just userInfo) requestId req (reqBody, queryJSON) res (Just (ioWaitTime, serviceTime)) origHeaders authHeaders httpLogMetadata
|
||||
where
|
||||
logErrorAndResp ::
|
||||
forall n a3 ctx.
|
||||
(MonadIO n, HttpLog n) =>
|
||||
forall any ctx.
|
||||
Maybe UserInfo ->
|
||||
RequestId ->
|
||||
Wai.Request ->
|
||||
@ -388,9 +409,10 @@ mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler
|
||||
[HTTP.Header] ->
|
||||
ExtraUserInfo ->
|
||||
QErr ->
|
||||
Spock.ActionCtxT ctx n a3
|
||||
Spock.ActionCtxT ctx m any
|
||||
logErrorAndResp userInfo reqId waiReq req includeInternal headers extraUserInfo qErr = do
|
||||
let httpLogMetadata = buildHttpLogMetadata @n emptyHttpLogGraphQLInfo extraUserInfo
|
||||
AppEnv {..} <- lift askAppEnv
|
||||
let httpLogMetadata = buildHttpLogMetadata @m emptyHttpLogGraphQLInfo extraUserInfo
|
||||
jsonResponse = J.encode $ qErrEncoder includeInternal qErr
|
||||
contentLength = ("Content-Length", B8.toStrict $ BB.toLazyByteString $ BB.int64Dec $ BL.length jsonResponse)
|
||||
allHeaders = [contentLength, jsonHeader]
|
||||
@ -400,6 +422,7 @@ mkSpockAction appStateRef appEnv@AppEnv {..} qErrEncoder qErrModifier apiHandler
|
||||
Spock.lazyBytes jsonResponse
|
||||
|
||||
logSuccessAndResp userInfo reqId waiReq req result qTime reqHeaders authHdrs httpLoggingMetadata = do
|
||||
AppEnv {..} <- lift askAppEnv
|
||||
let (respBytes, respHeaders) = case result of
|
||||
JSONResp (HttpResponse encJson h) -> (encJToLBS encJson, pure jsonHeader <> h)
|
||||
RawResp (HttpResponse rawBytes h) -> (rawBytes, h)
|
||||
@ -431,49 +454,29 @@ v1QueryHandler ::
|
||||
MonadReader HandlerCtx m,
|
||||
MonadMetadataStorageQueryAPI m,
|
||||
MonadResolveSource m,
|
||||
HasAppEnv m,
|
||||
EB.MonadQueryTags m,
|
||||
MonadEventLogCleanup m,
|
||||
ProvidesNetwork m,
|
||||
MonadGetApiTimeLimit m
|
||||
MonadGetApiTimeLimit m,
|
||||
UserInfoM m,
|
||||
HasServerConfigCtx m
|
||||
) =>
|
||||
AppStateRef impl ->
|
||||
RQLQuery ->
|
||||
m (HttpResponse EncJSON)
|
||||
v1QueryHandler appStateRef query = do
|
||||
(liftEitherM . authorizeV1QueryApi query) =<< ask
|
||||
logger <- asks (_lsLogger . appEnvLoggers . hcAppEnv)
|
||||
res <- bool (fst <$> (action logger)) (withSchemaCacheUpdate appStateRef logger Nothing (action logger)) $ queryModifiesSchemaCache query
|
||||
logger <- _lsLogger . appEnvLoggers <$> askAppEnv
|
||||
res <- bool (fst <$> action) (withSchemaCacheUpdate appStateRef logger Nothing action) $ queryModifiesSchemaCache query
|
||||
return $ HttpResponse res []
|
||||
where
|
||||
action logger = do
|
||||
userInfo <- asks hcUser
|
||||
AppContext {..} <- asks hcAppContext
|
||||
action = do
|
||||
appContext <- asks hcAppContext
|
||||
schemaCache <- asks hcSchemaCache
|
||||
instanceId <- asks (appEnvInstanceId . hcAppEnv)
|
||||
maintenanceMode <- asks (appEnvEnableMaintenanceMode . hcAppEnv)
|
||||
eventingMode <- asks (appEnvEventingMode . hcAppEnv)
|
||||
readOnlyMode <- asks (appEnvEnableReadOnlyMode . hcAppEnv)
|
||||
checkFeatureFlag <- asks (appEnvCheckFeatureFlag . hcAppEnv)
|
||||
let serverConfigCtx =
|
||||
ServerConfigCtx
|
||||
acFunctionPermsCtx
|
||||
acRemoteSchemaPermsCtx
|
||||
acSQLGenCtx
|
||||
maintenanceMode
|
||||
acExperimentalFeatures
|
||||
eventingMode
|
||||
readOnlyMode
|
||||
acDefaultNamingConvention
|
||||
acMetadataDefaults
|
||||
checkFeatureFlag
|
||||
acApolloFederationStatus
|
||||
runQuery
|
||||
acEnvironment
|
||||
logger
|
||||
instanceId
|
||||
userInfo
|
||||
appContext
|
||||
schemaCache
|
||||
serverConfigCtx
|
||||
query
|
||||
|
||||
-- | See Note [Explicitly passing AppStateRef]
|
||||
@ -487,47 +490,27 @@ v1MetadataHandler ::
|
||||
MonadResolveSource m,
|
||||
MonadMetadataApiAuthorization m,
|
||||
MonadEventLogCleanup m,
|
||||
HasAppEnv m,
|
||||
ProvidesNetwork m,
|
||||
MonadGetApiTimeLimit m
|
||||
MonadGetApiTimeLimit m,
|
||||
UserInfoM m,
|
||||
HasServerConfigCtx m
|
||||
) =>
|
||||
AppStateRef impl ->
|
||||
RQLMetadata ->
|
||||
m (HttpResponse EncJSON)
|
||||
v1MetadataHandler appStateRef query = Tracing.newSpan "Metadata" $ do
|
||||
(liftEitherM . authorizeV1MetadataApi query) =<< ask
|
||||
userInfo <- asks hcUser
|
||||
AppContext {..} <- asks hcAppContext
|
||||
logger <- _lsLogger . appEnvLoggers <$> askAppEnv
|
||||
appContext <- asks hcAppContext
|
||||
schemaCache <- asks hcSchemaCache
|
||||
instanceId <- asks (appEnvInstanceId . hcAppEnv)
|
||||
logger <- asks (_lsLogger . appEnvLoggers . hcAppEnv)
|
||||
maintenanceMode <- asks (appEnvEnableMaintenanceMode . hcAppEnv)
|
||||
eventingMode <- asks (appEnvEventingMode . hcAppEnv)
|
||||
readOnlyMode <- asks (appEnvEnableReadOnlyMode . hcAppEnv)
|
||||
checkFeatureFlag <- asks (appEnvCheckFeatureFlag . hcAppEnv)
|
||||
let serverConfigCtx =
|
||||
ServerConfigCtx
|
||||
acFunctionPermsCtx
|
||||
acRemoteSchemaPermsCtx
|
||||
acSQLGenCtx
|
||||
maintenanceMode
|
||||
acExperimentalFeatures
|
||||
eventingMode
|
||||
readOnlyMode
|
||||
acDefaultNamingConvention
|
||||
acMetadataDefaults
|
||||
checkFeatureFlag
|
||||
acApolloFederationStatus
|
||||
r <-
|
||||
withSchemaCacheUpdate
|
||||
appStateRef
|
||||
logger
|
||||
Nothing
|
||||
$ runMetadataQuery
|
||||
acEnvironment
|
||||
logger
|
||||
instanceId
|
||||
userInfo
|
||||
serverConfigCtx
|
||||
appContext
|
||||
schemaCache
|
||||
query
|
||||
pure $ HttpResponse r []
|
||||
@ -541,15 +524,18 @@ v2QueryHandler ::
|
||||
MonadReader HandlerCtx m,
|
||||
MonadMetadataStorage m,
|
||||
MonadResolveSource m,
|
||||
HasAppEnv m,
|
||||
EB.MonadQueryTags m,
|
||||
ProvidesNetwork m
|
||||
ProvidesNetwork m,
|
||||
UserInfoM m,
|
||||
HasServerConfigCtx m
|
||||
) =>
|
||||
AppStateRef impl ->
|
||||
V2Q.RQLQuery ->
|
||||
m (HttpResponse EncJSON)
|
||||
v2QueryHandler appStateRef query = Tracing.newSpan "v2 Query" $ do
|
||||
(liftEitherM . authorizeV2QueryApi query) =<< ask
|
||||
logger <- asks (_lsLogger . appEnvLoggers . hcAppEnv)
|
||||
logger <- _lsLogger . appEnvLoggers <$> askAppEnv
|
||||
res <-
|
||||
bool (fst <$> dbAction) (withSchemaCacheUpdate appStateRef logger Nothing dbAction) $
|
||||
V2Q.queryModifiesSchema query
|
||||
@ -557,29 +543,12 @@ v2QueryHandler appStateRef query = Tracing.newSpan "v2 Query" $ do
|
||||
where
|
||||
-- Hit postgres
|
||||
dbAction = do
|
||||
userInfo <- asks hcUser
|
||||
AppContext {..} <- asks hcAppContext
|
||||
schemaCache <- asks hcSchemaCache
|
||||
instanceId <- asks (appEnvInstanceId . hcAppEnv)
|
||||
maintenanceMode <- asks (appEnvEnableMaintenanceMode . hcAppEnv)
|
||||
eventingMode <- asks (appEnvEventingMode . hcAppEnv)
|
||||
readOnlyMode <- asks (appEnvEnableReadOnlyMode . hcAppEnv)
|
||||
checkFeatureFlag <- asks (appEnvCheckFeatureFlag . hcAppEnv)
|
||||
let serverConfigCtx =
|
||||
ServerConfigCtx
|
||||
acFunctionPermsCtx
|
||||
acRemoteSchemaPermsCtx
|
||||
acSQLGenCtx
|
||||
maintenanceMode
|
||||
acExperimentalFeatures
|
||||
eventingMode
|
||||
readOnlyMode
|
||||
acDefaultNamingConvention
|
||||
acMetadataDefaults
|
||||
checkFeatureFlag
|
||||
acApolloFederationStatus
|
||||
|
||||
V2Q.runQuery acEnvironment instanceId userInfo schemaCache serverConfigCtx query
|
||||
appContext <- asks hcAppContext
|
||||
V2Q.runQuery
|
||||
appContext
|
||||
schemaCache
|
||||
query
|
||||
|
||||
v1Alpha1GQHandler ::
|
||||
( MonadIO m,
|
||||
@ -588,6 +557,7 @@ v1Alpha1GQHandler ::
|
||||
MonadQueryLog m,
|
||||
MonadExecutionLog m,
|
||||
MonadTrace m,
|
||||
HasAppEnv m,
|
||||
GH.MonadExecuteQuery m,
|
||||
MonadError QErr m,
|
||||
MonadReader HandlerCtx m,
|
||||
@ -600,9 +570,9 @@ v1Alpha1GQHandler ::
|
||||
GH.GQLBatchedReqs (GH.GQLReq GH.GQLQueryText) ->
|
||||
m (HttpLogGraphQLInfo, HttpResponse EncJSON)
|
||||
v1Alpha1GQHandler queryType query = do
|
||||
userInfo <- asks hcUser
|
||||
appEnv <- askAppEnv
|
||||
appCtx@AppContext {..} <- asks hcAppContext
|
||||
appEnv <- asks hcAppEnv
|
||||
userInfo <- asks hcUser
|
||||
schemaCache <- asks hcSchemaCache
|
||||
schemaCacheVer <- asks hcSchemaCacheVersion
|
||||
reqHeaders <- asks hcReqHeaders
|
||||
@ -638,6 +608,7 @@ v1GQHandler ::
|
||||
MonadQueryLog m,
|
||||
MonadExecutionLog m,
|
||||
MonadTrace m,
|
||||
HasAppEnv m,
|
||||
GH.MonadExecuteQuery m,
|
||||
MonadError QErr m,
|
||||
MonadReader HandlerCtx m,
|
||||
@ -657,6 +628,7 @@ v1GQRelayHandler ::
|
||||
MonadQueryLog m,
|
||||
MonadExecutionLog m,
|
||||
MonadTrace m,
|
||||
HasAppEnv m,
|
||||
GH.MonadExecuteQuery m,
|
||||
MonadError QErr m,
|
||||
MonadReader HandlerCtx m,
|
||||
@ -755,6 +727,7 @@ configApiGetHandler ::
|
||||
forall m impl.
|
||||
( MonadIO m,
|
||||
MonadBaseControl IO m,
|
||||
HasAppEnv m,
|
||||
UserAuthentication m,
|
||||
HttpLog m,
|
||||
HasResourceLimits m,
|
||||
@ -763,10 +736,10 @@ configApiGetHandler ::
|
||||
AppStateRef impl ->
|
||||
AppEnv ->
|
||||
Spock.SpockCtxT () m ()
|
||||
configApiGetHandler appStateRef appEnv = do
|
||||
configApiGetHandler appStateRef AppEnv {..} = do
|
||||
AppContext {..} <- liftIO $ getAppContext appStateRef
|
||||
Spock.get "v1alpha1/config" $
|
||||
mkSpockAction appStateRef appEnv encodeQErr id $
|
||||
mkSpockAction appStateRef encodeQErr id $
|
||||
mkGetHandler $ do
|
||||
onlyAdmin
|
||||
let res =
|
||||
@ -777,7 +750,7 @@ configApiGetHandler appStateRef appEnv = do
|
||||
acEnableAllowlist
|
||||
acLiveQueryOptions
|
||||
acStreamQueryOptions
|
||||
(appEnvConsoleAssetsDir appEnv)
|
||||
appEnvConsoleAssetsDir
|
||||
acExperimentalFeatures
|
||||
acEnabledAPIs
|
||||
acDefaultNamingConvention
|
||||
@ -798,6 +771,7 @@ mkWaiApp ::
|
||||
ConsoleRenderer m,
|
||||
MonadVersionAPIWithExtraData m,
|
||||
HttpLog m,
|
||||
HasAppEnv m,
|
||||
UserAuthentication m,
|
||||
MonadMetadataApiAuthorization m,
|
||||
E.MonadGQLExecutionCheck m,
|
||||
@ -849,6 +823,7 @@ httpApp ::
|
||||
ConsoleRenderer m,
|
||||
MonadVersionAPIWithExtraData m,
|
||||
HttpLog m,
|
||||
HasAppEnv m,
|
||||
UserAuthentication m,
|
||||
MonadMetadataApiAuthorization m,
|
||||
E.MonadGQLExecutionCheck m,
|
||||
@ -932,25 +907,11 @@ httpApp setupHook appStateRef appEnv@AppEnv {..} ekgStore = do
|
||||
Spock.lazyBytes $ encode $ object $ ["version" .= currentVersion] <> extraData
|
||||
|
||||
let customEndpointHandler ::
|
||||
forall n.
|
||||
( MonadIO n,
|
||||
MonadBaseControl IO n,
|
||||
E.MonadGQLExecutionCheck n,
|
||||
MonadQueryLog n,
|
||||
MonadExecutionLog n,
|
||||
GH.MonadExecuteQuery n,
|
||||
MonadMetadataStorage n,
|
||||
EB.MonadQueryTags n,
|
||||
HasResourceLimits n,
|
||||
ProvidesNetwork n,
|
||||
MonadTrace n
|
||||
) =>
|
||||
RestRequest Spock.SpockMethod ->
|
||||
Handler n (HttpLogGraphQLInfo, APIResp)
|
||||
Handler m (HttpLogGraphQLInfo, APIResp)
|
||||
customEndpointHandler restReq = do
|
||||
endpoints <- liftIO $ scEndpoints <$> getSchemaCache appStateRef
|
||||
appCtx' <- asks hcAppContext
|
||||
appEnv' <- asks hcAppEnv
|
||||
schemaCache <- asks hcSchemaCache
|
||||
schemaCacheVer <- asks hcSchemaCacheVersion
|
||||
requestId <- asks hcRequestId
|
||||
@ -958,7 +919,7 @@ httpApp setupHook appStateRef appEnv@AppEnv {..} ekgStore = do
|
||||
reqHeaders <- asks hcReqHeaders
|
||||
ipAddress <- asks hcSourceIpAddress
|
||||
|
||||
let execCtx = mkExecutionContext appCtx' appEnv' schemaCache schemaCacheVer
|
||||
let execCtx = mkExecutionContext appCtx' appEnv schemaCache schemaCacheVer
|
||||
|
||||
req <-
|
||||
restReq & traverse \case
|
||||
@ -1113,20 +1074,13 @@ httpApp setupHook appStateRef appEnv@AppEnv {..} ekgStore = do
|
||||
logHttpError logger appEnvLoggingSettings Nothing reqId req (reqBody, Nothing) err headers (emptyHttpLogMetadata @m)
|
||||
|
||||
spockAction ::
|
||||
forall a n.
|
||||
( FromJSON a,
|
||||
MonadIO n,
|
||||
MonadBaseControl IO n,
|
||||
UserAuthentication n,
|
||||
HttpLog n,
|
||||
MonadTrace n,
|
||||
HasResourceLimits n
|
||||
) =>
|
||||
forall a.
|
||||
(FromJSON a) =>
|
||||
(Bool -> QErr -> Value) ->
|
||||
(QErr -> QErr) ->
|
||||
APIHandler n a ->
|
||||
Spock.ActionT n ()
|
||||
spockAction qErrEncoder qErrModifier apiHandler = mkSpockAction appStateRef appEnv qErrEncoder qErrModifier apiHandler
|
||||
APIHandler m a ->
|
||||
Spock.ActionT m ()
|
||||
spockAction qErrEncoder qErrModifier apiHandler = mkSpockAction appStateRef qErrEncoder qErrModifier apiHandler
|
||||
|
||||
-- all graphql errors should be of type 200
|
||||
allMod200 qe = qe {qeStatus = HTTP.status200}
|
||||
|
@ -27,7 +27,6 @@ import Hasura.Metadata.Class
|
||||
import Hasura.Prelude
|
||||
import Hasura.RQL.DDL.Schema (runCacheRWT)
|
||||
import Hasura.RQL.DDL.Schema.Catalog
|
||||
import Hasura.RQL.Types.Run
|
||||
import Hasura.RQL.Types.SchemaCache
|
||||
import Hasura.RQL.Types.SchemaCache.Build
|
||||
import Hasura.RQL.Types.Source
|
||||
@ -39,12 +38,10 @@ import Hasura.Server.AppStateRef
|
||||
readSchemaCacheRef,
|
||||
withSchemaCacheUpdate,
|
||||
)
|
||||
import Hasura.Server.Init (FeatureFlag)
|
||||
import Hasura.Server.Logging
|
||||
import Hasura.Server.Types
|
||||
import Hasura.Services
|
||||
import Hasura.Session
|
||||
import Network.HTTP.Client qualified as HTTP
|
||||
import Refined (NonNegative, Refined, unrefine)
|
||||
|
||||
data ThreadError
|
||||
@ -141,38 +138,23 @@ startSchemaSyncListenerThread logger pool instanceId interval metaVersionRef = d
|
||||
-- See Note [Schema Cache Sync]
|
||||
startSchemaSyncProcessorThread ::
|
||||
( C.ForkableMonadIO m,
|
||||
HasAppEnv m,
|
||||
MonadMetadataStorage m,
|
||||
MonadResolveSource m,
|
||||
ProvidesNetwork m
|
||||
) =>
|
||||
Logger Hasura ->
|
||||
HTTP.Manager ->
|
||||
STM.TMVar MetadataResourceVersion ->
|
||||
AppStateRef impl ->
|
||||
InstanceId ->
|
||||
(MaintenanceMode ()) ->
|
||||
EventingMode ->
|
||||
ReadOnlyMode ->
|
||||
STM.TVar Bool ->
|
||||
(FeatureFlag -> IO Bool) ->
|
||||
ManagedT m Immortal.Thread
|
||||
startSchemaSyncProcessorThread
|
||||
logger
|
||||
httpMgr
|
||||
schemaSyncEventRef
|
||||
appStateRef
|
||||
instanceId
|
||||
maintenanceMode
|
||||
eventingMode
|
||||
readOnlyMode
|
||||
logTVar
|
||||
checkFeatureFlag = do
|
||||
-- Start processor thread
|
||||
processorThread <-
|
||||
C.forkManagedT "SchemeUpdate.processor" logger $
|
||||
processor logger httpMgr schemaSyncEventRef appStateRef instanceId maintenanceMode eventingMode readOnlyMode logTVar checkFeatureFlag
|
||||
logThreadStarted logger instanceId TTProcessor processorThread
|
||||
pure processorThread
|
||||
startSchemaSyncProcessorThread appStateRef logTVar = do
|
||||
AppEnv {..} <- lift askAppEnv
|
||||
let logger = _lsLogger appEnvLoggers
|
||||
-- Start processor thread
|
||||
processorThread <-
|
||||
C.forkManagedT "SchemeUpdate.processor" logger $
|
||||
processor appEnvMetadataVersionRef appStateRef logTVar
|
||||
logThreadStarted logger appEnvInstanceId TTProcessor processorThread
|
||||
pure processorThread
|
||||
|
||||
-- TODO: This is also defined in multitenant, consider putting it in a library somewhere
|
||||
forcePut :: STM.TMVar a -> a -> IO ()
|
||||
@ -261,76 +243,85 @@ listener logger pool metaVersionRef interval = L.iterateM_ listenerLoop defaultE
|
||||
processor ::
|
||||
forall m void impl.
|
||||
( C.ForkableMonadIO m,
|
||||
HasAppEnv m,
|
||||
MonadMetadataStorage m,
|
||||
MonadResolveSource m,
|
||||
ProvidesNetwork m
|
||||
) =>
|
||||
Logger Hasura ->
|
||||
HTTP.Manager ->
|
||||
STM.TMVar MetadataResourceVersion ->
|
||||
AppStateRef impl ->
|
||||
InstanceId ->
|
||||
(MaintenanceMode ()) ->
|
||||
EventingMode ->
|
||||
ReadOnlyMode ->
|
||||
STM.TVar Bool ->
|
||||
(FeatureFlag -> IO Bool) ->
|
||||
m void
|
||||
processor
|
||||
logger
|
||||
_httpMgr
|
||||
metaVersionRef
|
||||
appStateRef
|
||||
instanceId
|
||||
maintenanceMode
|
||||
eventingMode
|
||||
readOnlyMode
|
||||
logTVar
|
||||
checkFeatureFlag = forever $ do
|
||||
logTVar = forever do
|
||||
metaVersion <- liftIO $ STM.atomically $ STM.takeTMVar metaVersionRef
|
||||
AppContext {..} <- liftIO $ getAppContext appStateRef
|
||||
let serverConfigCtx =
|
||||
ServerConfigCtx
|
||||
acFunctionPermsCtx
|
||||
acRemoteSchemaPermsCtx
|
||||
acSQLGenCtx
|
||||
maintenanceMode
|
||||
acExperimentalFeatures
|
||||
eventingMode
|
||||
readOnlyMode
|
||||
acDefaultNamingConvention
|
||||
acMetadataDefaults
|
||||
checkFeatureFlag
|
||||
acApolloFederationStatus
|
||||
refreshSchemaCache metaVersion instanceId logger appStateRef TTProcessor serverConfigCtx logTVar
|
||||
refreshSchemaCache metaVersion appStateRef TTProcessor logTVar
|
||||
|
||||
newtype SchemaUpdateT m a = SchemaUpdateT (AppContext -> m a)
|
||||
deriving
|
||||
( Functor,
|
||||
Applicative,
|
||||
Monad,
|
||||
MonadError e,
|
||||
MonadIO,
|
||||
MonadMetadataStorage,
|
||||
ProvidesNetwork,
|
||||
MonadResolveSource
|
||||
)
|
||||
via (ReaderT AppContext m)
|
||||
deriving (MonadTrans) via (ReaderT AppContext)
|
||||
|
||||
runSchemaUpdate :: AppContext -> SchemaUpdateT m a -> m a
|
||||
runSchemaUpdate appContext (SchemaUpdateT action) = action appContext
|
||||
|
||||
instance (Monad m) => UserInfoM (SchemaUpdateT m) where
|
||||
askUserInfo = pure adminUserInfo
|
||||
|
||||
instance (HasAppEnv m) => HasServerConfigCtx (SchemaUpdateT m) where
|
||||
askServerConfigCtx = SchemaUpdateT \AppContext {..} -> do
|
||||
AppEnv {..} <- askAppEnv
|
||||
pure
|
||||
ServerConfigCtx
|
||||
{ _sccFunctionPermsCtx = acFunctionPermsCtx,
|
||||
_sccRemoteSchemaPermsCtx = acRemoteSchemaPermsCtx,
|
||||
_sccSQLGenCtx = acSQLGenCtx,
|
||||
_sccMaintenanceMode = appEnvEnableMaintenanceMode,
|
||||
_sccExperimentalFeatures = acExperimentalFeatures,
|
||||
_sccEventingMode = appEnvEventingMode,
|
||||
_sccReadOnlyMode = appEnvEnableReadOnlyMode,
|
||||
_sccDefaultNamingConvention = acDefaultNamingConvention,
|
||||
_sccMetadataDefaults = acMetadataDefaults,
|
||||
_sccCheckFeatureFlag = appEnvCheckFeatureFlag,
|
||||
_sccApolloFederationStatus = acApolloFederationStatus
|
||||
}
|
||||
|
||||
refreshSchemaCache ::
|
||||
( MonadIO m,
|
||||
MonadBaseControl IO m,
|
||||
HasAppEnv m,
|
||||
MonadMetadataStorage m,
|
||||
MonadResolveSource m,
|
||||
ProvidesNetwork m
|
||||
) =>
|
||||
MetadataResourceVersion ->
|
||||
InstanceId ->
|
||||
Logger Hasura ->
|
||||
AppStateRef impl ->
|
||||
SchemaSyncThreadType ->
|
||||
ServerConfigCtx ->
|
||||
STM.TVar Bool ->
|
||||
m ()
|
||||
refreshSchemaCache
|
||||
resourceVersion
|
||||
instanceId
|
||||
logger
|
||||
appStateRef
|
||||
threadType
|
||||
serverConfigCtx
|
||||
logTVar = do
|
||||
AppEnv {..} <- askAppEnv
|
||||
let logger = _lsLogger appEnvLoggers
|
||||
respErr <- runExceptT $
|
||||
withSchemaCacheUpdate appStateRef logger (Just logTVar) $ do
|
||||
rebuildableCache <- liftIO $ fst <$> readSchemaCacheRef appStateRef
|
||||
(msg, cache, _) <- peelRun runCtx $
|
||||
appContext <- liftIO $ getAppContext appStateRef
|
||||
(msg, cache, _) <- runSchemaUpdate appContext $
|
||||
runCacheRWT rebuildableCache $ do
|
||||
schemaCache <- askSchemaCache
|
||||
case scMetadataResourceVersion schemaCache of
|
||||
@ -360,7 +351,7 @@ refreshSchemaCache
|
||||
"Fetched metadata with resource version "
|
||||
<> tshow latestResourceVersion
|
||||
|
||||
notifications <- liftEitherM $ fetchMetadataNotifications engineResourceVersion instanceId
|
||||
notifications <- liftEitherM $ fetchMetadataNotifications engineResourceVersion appEnvInstanceId
|
||||
|
||||
case notifications of
|
||||
[] -> do
|
||||
@ -395,8 +386,6 @@ refreshSchemaCache
|
||||
logInfo logger threadType $ object ["message" .= ("Schema Version changed with notifications" :: Text)]
|
||||
pure (msg, cache)
|
||||
onLeft respErr (logError logger threadType . TEQueryError)
|
||||
where
|
||||
runCtx = RunCtx adminUserInfo serverConfigCtx
|
||||
|
||||
logInfo :: (MonadIO m) => Logger Hasura -> SchemaSyncThreadType -> Value -> m ()
|
||||
logInfo logger threadType val =
|
||||
@ -408,10 +397,3 @@ logError logger threadType err =
|
||||
unLogger logger $
|
||||
SchemaSyncLog LevelError threadType $
|
||||
object ["error" .= toJSON err]
|
||||
|
||||
-- Currently unused
|
||||
_logDebug :: (MonadIO m) => Logger Hasura -> SchemaSyncThreadType -> String -> m ()
|
||||
_logDebug logger threadType msg =
|
||||
unLogger logger $
|
||||
SchemaSyncLog LevelDebug threadType $
|
||||
object ["message" .= msg]
|
||||
|
@ -131,25 +131,22 @@ main = do
|
||||
)
|
||||
$ \(appStateRef, appEnv) -> return (appStateRef, appEnv)
|
||||
|
||||
let run :: ExceptT QErr (PGMetadataStorageAppT CacheBuild) a -> IO a
|
||||
let run :: ExceptT QErr (PGMetadataStorageAppT IO) a -> IO a
|
||||
run =
|
||||
runExceptT
|
||||
>>> runPGMetadataStorageAppT appEnv
|
||||
>>> runCacheBuild cacheBuildParams
|
||||
>>> runExceptT
|
||||
>=> flip onLeft printErrJExit
|
||||
>=> flip onLeft printErrJExit
|
||||
>>> flip onLeftM printErrJExit
|
||||
|
||||
(metadata, schemaCache) <- run do
|
||||
metadata <-
|
||||
snd
|
||||
<$> (liftEitherM . runExceptT . _pecRunTx pgContext (PGExecCtxInfo (Tx PG.ReadWrite Nothing) InternalRawQuery))
|
||||
(migrateCatalog (Just sourceConfig) defaultPostgresExtensionsSchema maintenanceMode =<< liftIO getCurrentTime)
|
||||
schemaCache <- lift $ lift $ buildRebuildableSchemaCache logger envMap metadata
|
||||
schemaCache <- runCacheBuild cacheBuildParams $ buildRebuildableSchemaCache logger envMap metadata
|
||||
pure (metadata, schemaCache)
|
||||
|
||||
cacheRef <- newMVar schemaCache
|
||||
pure $ NT (run . flip MigrateSuite.runCacheRefT cacheRef . fmap fst . runMetadataT metadata emptyMetadataDefaults)
|
||||
pure $ NT (run . flip MigrateSuite.runCacheRefT (serverConfigCtx, cacheRef) . fmap fst . runMetadataT metadata emptyMetadataDefaults)
|
||||
|
||||
streamingSubscriptionSuite <- StreamingSubscriptionSuite.buildStreamingSubscriptionSuite
|
||||
eventTriggerLogCleanupSuite <- EventTriggerCleanupSuite.buildEventTriggerCleanupSuite
|
||||
|
@ -38,7 +38,7 @@ import Test.Hspec.Expectations.Lifted
|
||||
|
||||
-- -- NOTE: downgrade test disabled for now (see #5273)
|
||||
|
||||
newtype CacheRefT m a = CacheRefT {runCacheRefT :: MVar RebuildableSchemaCache -> m a}
|
||||
newtype CacheRefT m a = CacheRefT {runCacheRefT :: (ServerConfigCtx, MVar RebuildableSchemaCache) -> m a}
|
||||
deriving
|
||||
( Functor,
|
||||
Applicative,
|
||||
@ -47,15 +47,19 @@ newtype CacheRefT m a = CacheRefT {runCacheRefT :: MVar RebuildableSchemaCache -
|
||||
MonadError e,
|
||||
MonadBase b,
|
||||
MonadBaseControl b,
|
||||
MonadReader (ServerConfigCtx, MVar RebuildableSchemaCache),
|
||||
MonadTx,
|
||||
UserInfoM,
|
||||
HasServerConfigCtx,
|
||||
MonadMetadataStorage,
|
||||
MonadMetadataStorageQueryAPI,
|
||||
MonadResolveSource,
|
||||
ProvidesNetwork,
|
||||
MonadGetApiTimeLimit
|
||||
)
|
||||
via (ReaderT (MVar RebuildableSchemaCache) m)
|
||||
via (ReaderT (ServerConfigCtx, MVar RebuildableSchemaCache) m)
|
||||
|
||||
instance Monad m => HasServerConfigCtx (CacheRefT m) where
|
||||
askServerConfigCtx = asks fst
|
||||
|
||||
instance MonadTrans CacheRefT where
|
||||
lift = CacheRefT . const
|
||||
@ -65,7 +69,7 @@ instance MFunctor CacheRefT where
|
||||
|
||||
-- instance (MonadBase IO m) => TableCoreInfoRM 'Postgres (CacheRefT m)
|
||||
instance (MonadBase IO m) => CacheRM (CacheRefT m) where
|
||||
askSchemaCache = CacheRefT (fmap lastBuiltSchemaCache . readMVar)
|
||||
askSchemaCache = CacheRefT (fmap lastBuiltSchemaCache . readMVar . snd)
|
||||
|
||||
instance (MonadEventLogCleanup m) => MonadEventLogCleanup (CacheRefT m) where
|
||||
runLogCleaner conf = lift $ runLogCleaner conf
|
||||
@ -77,18 +81,19 @@ instance
|
||||
MonadBaseControl IO m,
|
||||
MonadError QErr m,
|
||||
MonadResolveSource m,
|
||||
HasServerConfigCtx m,
|
||||
ProvidesNetwork m
|
||||
) =>
|
||||
CacheRWM (CacheRefT m)
|
||||
where
|
||||
buildSchemaCacheWithOptions reason invalidations metadata =
|
||||
CacheRefT $ flip modifyMVar \schemaCache -> do
|
||||
buildSchemaCacheWithOptions reason invalidations metadata = do
|
||||
scVar <- asks snd
|
||||
modifyMVar scVar \schemaCache -> do
|
||||
((), cache, _) <- runCacheRWT schemaCache (buildSchemaCacheWithOptions reason invalidations metadata)
|
||||
pure (cache, ())
|
||||
|
||||
setMetadataResourceVersionInSchemaCache resourceVersion =
|
||||
CacheRefT $ flip modifyMVar \schemaCache -> do
|
||||
setMetadataResourceVersionInSchemaCache resourceVersion = do
|
||||
scVar <- asks snd
|
||||
modifyMVar scVar \schemaCache -> do
|
||||
((), cache, _) <- runCacheRWT schemaCache (setMetadataResourceVersionInSchemaCache resourceVersion)
|
||||
pure (cache, ())
|
||||
|
||||
@ -106,7 +111,6 @@ suite ::
|
||||
( MonadIO m,
|
||||
MonadError QErr m,
|
||||
MonadBaseControl IO m,
|
||||
HasServerConfigCtx m,
|
||||
MonadResolveSource m,
|
||||
MonadMetadataStorageQueryAPI m,
|
||||
MonadEventLogCleanup m,
|
||||
@ -127,9 +131,9 @@ suite srcConfig pgExecCtx pgConnInfo = do
|
||||
(migrationResult, metadata) <- runTx' pgExecCtx $ migrateCatalog (Just srcConfig) (ExtensionsSchema "public") MaintenanceModeDisabled time
|
||||
(,migrationResult) <$> runCacheBuildM (buildRebuildableSchemaCache logger env metadata)
|
||||
|
||||
dropAndInit env time = lift $
|
||||
CacheRefT $ flip modifyMVar \_ ->
|
||||
(runTx' pgExecCtx dropHdbCatalogSchema) *> (migrateCatalogAndBuildCache env time)
|
||||
dropAndInit env time = lift do
|
||||
scVar <- asks snd
|
||||
modifyMVar scVar $ const $ (runTx' pgExecCtx dropHdbCatalogSchema) *> (migrateCatalogAndBuildCache env time)
|
||||
downgradeTo v = runTx' pgExecCtx . downgradeCatalog (Just srcConfig) DowngradeOptions {dgoDryRun = False, dgoTargetVersion = v}
|
||||
|
||||
describe "migrateCatalog" $ do
|
||||
@ -149,9 +153,9 @@ suite srcConfig pgExecCtx pgConnInfo = do
|
||||
secondDump `shouldBe` firstDump
|
||||
|
||||
it "supports upgrades after downgrade to version 12" \(NT transact) -> do
|
||||
let upgradeToLatest env time = lift $
|
||||
CacheRefT $ flip modifyMVar \_ ->
|
||||
migrateCatalogAndBuildCache env time
|
||||
let upgradeToLatest env time = lift do
|
||||
scVar <- asks snd
|
||||
modifyMVar scVar $ const $ migrateCatalogAndBuildCache env time
|
||||
env <- Env.getEnvironment
|
||||
time <- getCurrentTime
|
||||
transact (dropAndInit env time) `shouldReturn` MRInitialized
|
||||
|
Loading…
Reference in New Issue
Block a user