{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- | Defines the CE version of the engine.
--
-- This module contains everything that is required to run the community edition
-- of the engine: the base application monad and the implementation of all its
-- behaviour classes.
module Hasura.App
  ( -- * top-level error handling
    ExitCode (..),
    ExitException (..),
    throwErrExit,
    throwErrJExit,
    accessDeniedErrMsg,

    -- * printing helpers
    printJSON,

    -- * logging
    mkLoggers,
    mkPGLogger,

    -- * basic connection info
    BasicConnectionInfo (..),
    initMetadataConnectionInfo,
    initBasicConnectionInfo,
    resolvePostgresConnInfo,

    -- * app init
    initialiseAppEnv,
    initialiseAppContext,
    migrateCatalogAndFetchMetadata,
    buildFirstSchemaCache,
    initSubscriptionsState,
    initLockedEventsCtx,

    -- * app monad
    AppM,
    runAppM,

    -- * misc
    getCatalogStateTx,
    updateJwkCtxThread,
    notifySchemaCacheSyncTx,
    parseArgs,
    runHGEServer,
    setCatalogStateTx,
    mkHGEServer,
    mkPgSourceResolver,
    mkMSSQLSourceResolver,
  )
where

import Control.Concurrent.Async.Lifted.Safe qualified as LA
import Control.Concurrent.Extended (sleep)
import Control.Concurrent.Extended qualified as C
import Control.Concurrent.STM
import Control.Concurrent.STM qualified as STM
import Control.Exception (bracket_, throwIO)
import Control.Monad.Catch
  ( Exception,
    MonadCatch,
    MonadMask,
    MonadThrow,
  )
import Control.Monad.Morph (hoist)
import Control.Monad.Stateless
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Managed (ManagedT (..), allocate, allocate_)
import Control.Retry qualified as Retry
import Data.Aeson qualified as J
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Lazy.Char8 qualified as BLC
import Data.Environment qualified as Env
import Data.FileEmbed (makeRelativeToProject)
import Data.HashMap.Strict qualified as HashMap
import Data.Set.NonEmpty qualified as NE
import Data.Text qualified as T
import Data.Time.Clock (UTCTime)
import Data.Time.Clock qualified as Clock
import Database.MSSQL.Pool qualified as MSPool
import Database.PG.Query qualified as PG
import Database.PG.Query qualified as Q
import GHC.AssertNF.CPP
import Hasura.App.State
import Hasura.Backends.MSSQL.Connection
import Hasura.Backends.Postgres.Connection
import Hasura.Base.Error
import Hasura.ClientCredentials (getEEClientCredentialsTx, setEEClientCredentialsTx)
import Hasura.Eventing.Backend
import Hasura.Eventing.Common
import Hasura.Eventing.EventTrigger
import Hasura.Eventing.ScheduledTrigger
import Hasura.GraphQL.Execute
  ( ExecutionStep (..),
    MonadGQLExecutionCheck (..),
    checkQueryInAllowlist,
  )
import Hasura.GraphQL.Execute.Action
import Hasura.GraphQL.Execute.Action.Subscription
import Hasura.GraphQL.Execute.Subscription.Poll qualified as ES
import Hasura.GraphQL.Execute.Subscription.State qualified as ES
import Hasura.GraphQL.Logging (MonadExecutionLog (..), MonadQueryLog (..))
import Hasura.GraphQL.Transport.HTTP
  ( CacheResult (..),
    MonadExecuteQuery (..),
  )
import Hasura.GraphQL.Transport.HTTP.Protocol (toParsed)
import Hasura.GraphQL.Transport.WSServerApp qualified as WS
import Hasura.GraphQL.Transport.WebSocket.Server qualified as WS
import Hasura.GraphQL.Transport.WebSocket.Types (WSServerEnv (..))
import Hasura.Logging
import Hasura.Metadata.Class
import Hasura.PingSources
import Hasura.Prelude
import Hasura.QueryTags
import Hasura.RQL.DDL.EventTrigger (MonadEventLogCleanup (..))
import Hasura.RQL.DDL.Schema.Cache
import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.DDL.Schema.Cache.Config
import Hasura.RQL.DDL.Schema.Catalog
import Hasura.RQL.DDL.SchemaRegistry qualified as SchemaRegistry
import Hasura.RQL.Types.Allowlist
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.BackendType
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Metadata
import Hasura.RQL.Types.ResizePool
import Hasura.RQL.Types.Roles (adminRoleName)
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.SchemaCache.Build
import Hasura.RQL.Types.Source
import Hasura.SQL.AnyBackend qualified as AB
import Hasura.Server.API.Query (requiresAdmin)
import Hasura.Server.App
import Hasura.Server.AppStateRef
import Hasura.Server.Auth
import Hasura.Server.CheckUpdates (checkForUpdates)
import Hasura.Server.Init
import Hasura.Server.Limits
import Hasura.Server.Logging
import Hasura.Server.Metrics (ServerMetrics (..))
import Hasura.Server.Migrate (migrateCatalog)
import Hasura.Server.Prometheus
  ( PrometheusMetrics (..),
    decWarpThreads,
    incWarpThreads,
  )
import Hasura.Server.ResourceChecker (getServerResources)
import Hasura.Server.SchemaUpdate
import Hasura.Server.Telemetry
import Hasura.Server.Types
import Hasura.Server.Version
import Hasura.Services
import Hasura.Session
import Hasura.ShutdownLatch
import Hasura.Tracing
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Client.CreateManager (mkHttpManager)
import Network.Types.Extended
import Network.Wai (Application)
import Network.Wai.Handler.Warp qualified as Warp
import Options.Applicative
import Refined (unrefine)
import System.Metrics qualified as EKG
import System.Metrics.Gauge qualified as EKG.Gauge
import Text.Mustache.Compile qualified as M
import Web.Spock.Core qualified as Spock

--------------------------------------------------------------------------------
-- Error handling (move to another module!)

data ExitCode
  = -- these are used during server initialization:
    InvalidEnvironmentVariableOptionsError
  | InvalidDatabaseConnectionParamsError
  | AuthConfigurationError
  | DatabaseMigrationError
  | -- | used by MT because it initialises the schema cache only
    -- these are used in app/Main.hs:
    SchemaCacheInitError
  | MetadataExportError
  | MetadataCleanError
  | DowngradeProcessError
  deriving (Int -> ExitCode -> ShowS
[ExitCode] -> ShowS
ExitCode -> String
(Int -> ExitCode -> ShowS)
-> (ExitCode -> String) -> ([ExitCode] -> ShowS) -> Show ExitCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExitCode -> ShowS
showsPrec :: Int -> ExitCode -> ShowS
$cshow :: ExitCode -> String
show :: ExitCode -> String
$cshowList :: [ExitCode] -> ShowS
showList :: [ExitCode] -> ShowS
Show)

data ExitException = ExitException
  { ExitException -> ExitCode
eeCode :: !ExitCode,
    ExitException -> ByteString
eeMessage :: !BC.ByteString
  }
  deriving (Int -> ExitException -> ShowS
[ExitException] -> ShowS
ExitException -> String
(Int -> ExitException -> ShowS)
-> (ExitException -> String)
-> ([ExitException] -> ShowS)
-> Show ExitException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExitException -> ShowS
showsPrec :: Int -> ExitException -> ShowS
$cshow :: ExitException -> String
show :: ExitException -> String
$cshowList :: [ExitException] -> ShowS
showList :: [ExitException] -> ShowS
Show)

instance Exception ExitException

throwErrExit :: (MonadIO m) => forall a. ExitCode -> String -> m a
throwErrExit :: forall (m :: * -> *) a. MonadIO m => ExitCode -> String -> m a
throwErrExit ExitCode
reason = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (String -> IO a) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExitException -> IO a
forall e a. Exception e => e -> IO a
throwIO (ExitException -> IO a)
-> (String -> ExitException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExitCode -> ByteString -> ExitException
ExitException ExitCode
reason (ByteString -> ExitException)
-> (String -> ByteString) -> String -> ExitException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BC.pack

throwErrJExit :: (J.ToJSON a, MonadIO m) => forall b. ExitCode -> a -> m b
throwErrJExit :: forall a (m :: * -> *) b.
(ToJSON a, MonadIO m) =>
ExitCode -> a -> m b
throwErrJExit ExitCode
reason = IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> (a -> IO b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExitException -> IO b
forall e a. Exception e => e -> IO a
throwIO (ExitException -> IO b) -> (a -> ExitException) -> a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExitCode -> ByteString -> ExitException
ExitException ExitCode
reason (ByteString -> ExitException)
-> (a -> ByteString) -> a -> ExitException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BLC.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode

accessDeniedErrMsg :: Text
accessDeniedErrMsg :: Text
accessDeniedErrMsg = Text
"restricted access : admin only"

--------------------------------------------------------------------------------
-- Printing helpers (move to another module!)

printJSON :: (J.ToJSON a, MonadIO m) => a -> m ()
printJSON :: forall a (m :: * -> *). (ToJSON a, MonadIO m) => a -> m ()
printJSON = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
BLC.putStrLn (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode

--------------------------------------------------------------------------------
-- Logging

mkPGLogger :: Logger Hasura -> PG.PGLogger
mkPGLogger :: Logger Hasura -> PGLogger
mkPGLogger (Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) (PG.PLERetryMsg Value
msg) = PGLog -> IO ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger (PGLog -> IO ()) -> PGLog -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> Value -> PGLog
PGLog LogLevel
LevelWarn Value
msg

-- | Create all loggers based on the set of enabled logs and chosen log level.
mkLoggers ::
  (MonadIO m, MonadBaseControl IO m) =>
  HashSet (EngineLogType Hasura) ->
  LogLevel ->
  ManagedT m Loggers
mkLoggers :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
HashSet (EngineLogType Hasura) -> LogLevel -> ManagedT m Loggers
mkLoggers HashSet (EngineLogType Hasura)
enabledLogs LogLevel
logLevel = do
  LoggerCtx Hasura
loggerCtx <- LoggerSettings
-> HashSet (EngineLogType Hasura) -> ManagedT m (LoggerCtx Hasura)
forall (io :: * -> *) impl.
(MonadIO io, MonadBaseControl IO io) =>
LoggerSettings
-> HashSet (EngineLogType impl) -> ManagedT io (LoggerCtx impl)
mkLoggerCtx (Bool -> LogLevel -> LoggerSettings
defaultLoggerSettings Bool
True LogLevel
logLevel) HashSet (EngineLogType Hasura)
enabledLogs
  let logger :: Logger Hasura
logger = LoggerCtx Hasura -> Logger Hasura
forall impl.
ToJSON (EngineLogType impl) =>
LoggerCtx impl -> Logger impl
mkLogger LoggerCtx Hasura
loggerCtx
      pgLogger :: PGLogger
pgLogger = Logger Hasura -> PGLogger
mkPGLogger Logger Hasura
logger
  Loggers -> ManagedT m Loggers
forall a. a -> ManagedT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Loggers -> ManagedT m Loggers) -> Loggers -> ManagedT m Loggers
forall a b. (a -> b) -> a -> b
$ LoggerCtx Hasura -> Logger Hasura -> PGLogger -> Loggers
Loggers LoggerCtx Hasura
loggerCtx Logger Hasura
logger PGLogger
pgLogger

--------------------------------------------------------------------------------
-- Basic connection info

-- | Basic information required to connect to the metadata DB, and to the
-- default Postgres DB if any.
data BasicConnectionInfo = BasicConnectionInfo
  { -- | metadata db connection info
    BasicConnectionInfo -> ConnInfo
bciMetadataConnInfo :: PG.ConnInfo,
    -- | default postgres connection info, if any
    BasicConnectionInfo -> Maybe PostgresConnConfiguration
bciDefaultPostgres :: Maybe PostgresConnConfiguration
  }

-- | Only create the metadata connection info.
--
-- Like 'initBasicConnectionInfo', it prioritizes @--metadata-database-url@, and
-- falls back to @--database-url@ otherwise.
--
-- !!! This function throws a fatal error if the @--database-url@ cannot be
-- !!! resolved.
initMetadataConnectionInfo ::
  (MonadIO m) =>
  Env.Environment ->
  -- | metadata DB URL (--metadata-database-url)
  Maybe String ->
  -- | user's DB URL (--database-url)
  PostgresConnInfo (Maybe UrlConf) ->
  m PG.ConnInfo
initMetadataConnectionInfo :: forall (m :: * -> *).
MonadIO m =>
Environment
-> Maybe String -> PostgresConnInfo (Maybe UrlConf) -> m ConnInfo
initMetadataConnectionInfo Environment
env Maybe String
metadataDbURL PostgresConnInfo (Maybe UrlConf)
dbURL =
  (BasicConnectionInfo -> ConnInfo)
-> m BasicConnectionInfo -> m ConnInfo
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BasicConnectionInfo -> ConnInfo
bciMetadataConnInfo
    (m BasicConnectionInfo -> m ConnInfo)
-> m BasicConnectionInfo -> m ConnInfo
forall a b. (a -> b) -> a -> b
$ Environment
-> Maybe String
-> PostgresConnInfo (Maybe UrlConf)
-> Maybe PostgresPoolSettings
-> Bool
-> TxIsolation
-> m BasicConnectionInfo
forall (m :: * -> *).
MonadIO m =>
Environment
-> Maybe String
-> PostgresConnInfo (Maybe UrlConf)
-> Maybe PostgresPoolSettings
-> Bool
-> TxIsolation
-> m BasicConnectionInfo
initBasicConnectionInfo
      Environment
env
      Maybe String
metadataDbURL
      PostgresConnInfo (Maybe UrlConf)
dbURL
      Maybe PostgresPoolSettings
forall a. Maybe a
Nothing -- ignored
      Bool
False -- ignored
      TxIsolation
PG.ReadCommitted -- ignored

-- | Create a 'BasicConnectionInfo' based on the given options.
--
-- The default postgres connection is only created when the @--database-url@
-- option is given. If the @--metadata-database-url@ isn't given, the
-- @--database-url@ will be used for the metadata connection.
--
-- All arguments related to the default postgres connection are ignored if the
-- @--database-url@ is missing.
--
-- !!! This function throws a fatal error if the @--database-url@ cannot be
-- !!! resolved.
initBasicConnectionInfo ::
  (MonadIO m) =>
  Env.Environment ->
  -- | metadata DB URL (--metadata-database-url)
  Maybe String ->
  -- | user's DB URL (--database-url)
  PostgresConnInfo (Maybe UrlConf) ->
  -- | pool settings of the default PG connection
  Maybe PostgresPoolSettings ->
  -- | whether the default PG config should use prepared statements
  Bool ->
  -- | default transaction isolation level
  PG.TxIsolation ->
  m BasicConnectionInfo
initBasicConnectionInfo :: forall (m :: * -> *).
MonadIO m =>
Environment
-> Maybe String
-> PostgresConnInfo (Maybe UrlConf)
-> Maybe PostgresPoolSettings
-> Bool
-> TxIsolation
-> m BasicConnectionInfo
initBasicConnectionInfo
  Environment
env
  Maybe String
metadataDbUrl
  (PostgresConnInfo Maybe UrlConf
dbUrlConf Maybe Int
maybeRetries)
  Maybe PostgresPoolSettings
poolSettings
  Bool
usePreparedStatements
  TxIsolation
isolationLevel =
    case (Maybe String
metadataDbUrl, Maybe UrlConf
dbUrlConf) of
      (Maybe String
Nothing, Maybe UrlConf
Nothing) ->
        ExitCode -> String -> m BasicConnectionInfo
forall a. ExitCode -> String -> m a
forall (m :: * -> *) a. MonadIO m => ExitCode -> String -> m a
throwErrExit
          ExitCode
InvalidDatabaseConnectionParamsError
          String
"Fatal Error: Either of --metadata-database-url or --database-url option expected"
      -- If no metadata storage specified consider use default database as
      -- metadata storage
      (Maybe String
Nothing, Just UrlConf
srcURL) -> do
        ConnInfo
srcConnInfo <- Environment -> UrlConf -> Maybe Int -> m ConnInfo
forall (m :: * -> *).
MonadIO m =>
Environment -> UrlConf -> Maybe Int -> m ConnInfo
resolvePostgresConnInfo Environment
env UrlConf
srcURL Maybe Int
maybeRetries
        BasicConnectionInfo -> m BasicConnectionInfo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BasicConnectionInfo -> m BasicConnectionInfo)
-> BasicConnectionInfo -> m BasicConnectionInfo
forall a b. (a -> b) -> a -> b
$ ConnInfo -> Maybe PostgresConnConfiguration -> BasicConnectionInfo
BasicConnectionInfo ConnInfo
srcConnInfo (PostgresConnConfiguration -> Maybe PostgresConnConfiguration
forall a. a -> Maybe a
Just (PostgresConnConfiguration -> Maybe PostgresConnConfiguration)
-> PostgresConnConfiguration -> Maybe PostgresConnConfiguration
forall a b. (a -> b) -> a -> b
$ UrlConf -> PostgresConnConfiguration
mkSourceConfig UrlConf
srcURL)
      (Just String
mdURL, Maybe UrlConf
Nothing) ->
        BasicConnectionInfo -> m BasicConnectionInfo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BasicConnectionInfo -> m BasicConnectionInfo)
-> BasicConnectionInfo -> m BasicConnectionInfo
forall a b. (a -> b) -> a -> b
$ ConnInfo -> Maybe PostgresConnConfiguration -> BasicConnectionInfo
BasicConnectionInfo (String -> ConnInfo
mkConnInfoFromMDB String
mdURL) Maybe PostgresConnConfiguration
forall a. Maybe a
Nothing
      (Just String
mdURL, Just UrlConf
srcURL) -> do
        ConnInfo
_srcConnInfo <- Environment -> UrlConf -> Maybe Int -> m ConnInfo
forall (m :: * -> *).
MonadIO m =>
Environment -> UrlConf -> Maybe Int -> m ConnInfo
resolvePostgresConnInfo Environment
env UrlConf
srcURL Maybe Int
maybeRetries
        BasicConnectionInfo -> m BasicConnectionInfo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BasicConnectionInfo -> m BasicConnectionInfo)
-> BasicConnectionInfo -> m BasicConnectionInfo
forall a b. (a -> b) -> a -> b
$ ConnInfo -> Maybe PostgresConnConfiguration -> BasicConnectionInfo
BasicConnectionInfo (String -> ConnInfo
mkConnInfoFromMDB String
mdURL) (PostgresConnConfiguration -> Maybe PostgresConnConfiguration
forall a. a -> Maybe a
Just (PostgresConnConfiguration -> Maybe PostgresConnConfiguration)
-> PostgresConnConfiguration -> Maybe PostgresConnConfiguration
forall a b. (a -> b) -> a -> b
$ UrlConf -> PostgresConnConfiguration
mkSourceConfig UrlConf
srcURL)
    where
      mkConnInfoFromMDB :: String -> ConnInfo
mkConnInfoFromMDB String
mdbURL =
        PG.ConnInfo
          { ciRetries :: Int
PG.ciRetries = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
maybeRetries,
            ciDetails :: ConnDetails
PG.ciDetails = ByteString -> ConnDetails
PG.CDDatabaseURI (ByteString -> ConnDetails) -> ByteString -> ConnDetails
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
txtToBs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
mdbURL
          }
      mkSourceConfig :: UrlConf -> PostgresConnConfiguration
mkSourceConfig UrlConf
srcURL =
        PostgresConnConfiguration
          { _pccConnectionInfo :: PostgresSourceConnInfo
_pccConnectionInfo =
              PostgresSourceConnInfo
                { _psciDatabaseUrl :: UrlConf
_psciDatabaseUrl = UrlConf
srcURL,
                  _psciPoolSettings :: Maybe PostgresPoolSettings
_psciPoolSettings = Maybe PostgresPoolSettings
poolSettings,
                  _psciUsePreparedStatements :: Bool
_psciUsePreparedStatements = Bool
usePreparedStatements,
                  _psciIsolationLevel :: TxIsolation
_psciIsolationLevel = TxIsolation
isolationLevel,
                  _psciSslConfiguration :: Maybe (PGClientCerts CertVar CertVar)
_psciSslConfiguration = Maybe (PGClientCerts CertVar CertVar)
forall a. Maybe a
Nothing
                },
            _pccReadReplicas :: Maybe (NonEmpty PostgresSourceConnInfo)
_pccReadReplicas = Maybe (NonEmpty PostgresSourceConnInfo)
forall a. Maybe a
Nothing,
            _pccExtensionsSchema :: ExtensionsSchema
_pccExtensionsSchema = ExtensionsSchema
defaultPostgresExtensionsSchema,
            _pccConnectionTemplate :: Maybe ConnectionTemplate
_pccConnectionTemplate = Maybe ConnectionTemplate
forall a. Maybe a
Nothing,
            _pccConnectionSet :: Maybe PostgresConnectionSet
_pccConnectionSet = Maybe PostgresConnectionSet
forall a. Monoid a => a
mempty
          }

-- | Creates a 'PG.ConnInfo' from a 'UrlConf' parameter.
--
-- !!! throws a fatal error if the configuration is invalid
resolvePostgresConnInfo ::
  (MonadIO m) =>
  Env.Environment ->
  UrlConf ->
  Maybe Int ->
  m PG.ConnInfo
resolvePostgresConnInfo :: forall (m :: * -> *).
MonadIO m =>
Environment -> UrlConf -> Maybe Int -> m ConnInfo
resolvePostgresConnInfo Environment
env UrlConf
dbUrlConf (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 -> Int
retries) = do
  Text
dbUrlText <-
    Environment -> UrlConf -> Either QErr Text
forall (m :: * -> *).
MonadError QErr m =>
Environment -> UrlConf -> m Text
resolveUrlConf Environment
env UrlConf
dbUrlConf Either QErr Text -> (QErr -> m Text) -> m Text
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` \QErr
err ->
      IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExitCode -> QErr -> IO Text
forall b. ExitCode -> QErr -> IO b
forall a (m :: * -> *) b.
(ToJSON a, MonadIO m) =>
ExitCode -> a -> m b
throwErrJExit ExitCode
InvalidDatabaseConnectionParamsError QErr
err)
  ConnInfo -> m ConnInfo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnInfo -> m ConnInfo) -> ConnInfo -> m ConnInfo
forall a b. (a -> b) -> a -> b
$ Int -> ConnDetails -> ConnInfo
PG.ConnInfo Int
retries (ConnDetails -> ConnInfo) -> ConnDetails -> ConnInfo
forall a b. (a -> b) -> a -> b
$ ByteString -> ConnDetails
PG.CDDatabaseURI (ByteString -> ConnDetails) -> ByteString -> ConnDetails
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
txtToBs Text
dbUrlText

--------------------------------------------------------------------------------
-- App init

-- | The initialisation of the app is split into several functions, for clarity;
-- but there are several pieces of information that need to be threaded across
-- those initialisation functions. This small data structure groups together all
-- such pieces of information that are required throughout the initialisation,
-- but that aren't needed in the rest of the application.
data AppInit = AppInit
  { AppInit -> TLSAllowListRef
aiTLSAllowListRef :: TLSAllowListRef,
    AppInit -> MetadataWithResourceVersion
aiMetadataWithResourceVersion :: MetadataWithResourceVersion
  }

-- | Initializes or migrates the catalog and creates the 'AppEnv' required to
-- start the server, and also create the 'AppInit' that needs to be threaded
-- along the init code.
--
-- For historical reasons, this function performs a few additional startup tasks
-- that are not required to create the 'AppEnv', such as starting background
-- processes and logging startup information. All of those are flagged with a
-- comment marking them as a side-effect.
initialiseAppEnv ::
  (C.ForkableMonadIO m) =>
  Env.Environment ->
  BasicConnectionInfo ->
  ServeOptions Hasura ->
  Maybe ES.SubscriptionPostPollHook ->
  ServerMetrics ->
  PrometheusMetrics ->
  SamplingPolicy ->
  ManagedT m (AppInit, AppEnv)
initialiseAppEnv :: forall (m :: * -> *).
ForkableMonadIO m =>
Environment
-> BasicConnectionInfo
-> ServeOptions Hasura
-> Maybe SubscriptionPostPollHook
-> ServerMetrics
-> PrometheusMetrics
-> SamplingPolicy
-> ManagedT m (AppInit, AppEnv)
initialiseAppEnv Environment
env BasicConnectionInfo {Maybe PostgresConnConfiguration
ConnInfo
bciMetadataConnInfo :: BasicConnectionInfo -> ConnInfo
bciDefaultPostgres :: BasicConnectionInfo -> Maybe PostgresConnConfiguration
bciMetadataConnInfo :: ConnInfo
bciDefaultPostgres :: Maybe PostgresConnConfiguration
..} serveOptions :: ServeOptions Hasura
serveOptions@ServeOptions {Int
[JWTConfig]
Maybe Text
Maybe RoleName
Maybe AuthHook
HostPreference
HashSet (EngineLogType Hasura)
HashSet ExperimentalFeature
HashSet AdminSecretHash
HashSet API
TxIsolation
ConnParams
Refined NonNegative Int
Refined NonNegative Milliseconds
Refined NonNegative Seconds
Refined Positive Int
ConnectionOptions
StreamQueriesOptions
LogLevel
NamingCase
RemoteSchemaPermissions
InferFunctionPermissions
DangerouslyCollapseBooleans
StringifyNumbers
ExtensionsSchema
CloseWebsocketsOnMetadataChangeStatus
ApolloFederationStatus
EventingMode
ReadOnlyMode
MaintenanceMode ()
CorsConfig
MetadataQueryLoggingMode
MetadataDefaults
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
TelemetryStatus
DevModeStatus
AllowListStatus
AdminInternalErrorsStatus
ConsoleStatus
soPort :: Port
soHost :: HostPreference
soConnParams :: ConnParams
soTxIso :: TxIsolation
soAdminSecret :: HashSet AdminSecretHash
soAuthHook :: Maybe AuthHook
soJwtSecret :: [JWTConfig]
soUnAuthRole :: Maybe RoleName
soCorsConfig :: CorsConfig
soConsoleStatus :: ConsoleStatus
soConsoleAssetsDir :: Maybe Text
soConsoleSentryDsn :: Maybe Text
soEnableTelemetry :: TelemetryStatus
soStringifyNum :: StringifyNumbers
soDangerousBooleanCollapse :: DangerouslyCollapseBooleans
soEnabledAPIs :: HashSet API
soLiveQueryOpts :: StreamQueriesOptions
soStreamingQueryOpts :: StreamQueriesOptions
soEnableAllowList :: AllowListStatus
soEnabledLogTypes :: HashSet (EngineLogType Hasura)
soLogLevel :: LogLevel
soEventsHttpPoolSize :: Refined Positive Int
soEventsFetchInterval :: Refined NonNegative Milliseconds
soAsyncActionsFetchInterval :: OptionalInterval
soEnableRemoteSchemaPermissions :: RemoteSchemaPermissions
soConnectionOptions :: ConnectionOptions
soWebSocketKeepAlive :: KeepAliveDelay
soInferFunctionPermissions :: InferFunctionPermissions
soEnableMaintenanceMode :: MaintenanceMode ()
soSchemaPollInterval :: OptionalInterval
soExperimentalFeatures :: HashSet ExperimentalFeature
soEventsFetchBatchSize :: Refined NonNegative Int
soDevMode :: DevModeStatus
soAdminInternalErrors :: AdminInternalErrorsStatus
soGracefulShutdownTimeout :: Refined NonNegative Seconds
soWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
soEventingMode :: EventingMode
soReadOnlyMode :: ReadOnlyMode
soEnableMetadataQueryLogging :: MetadataQueryLoggingMode
soDefaultNamingConvention :: NamingCase
soExtensionsSchema :: ExtensionsSchema
soMetadataDefaults :: MetadataDefaults
soApolloFederationStatus :: ApolloFederationStatus
soCloseWebsocketsOnMetadataChangeStatus :: CloseWebsocketsOnMetadataChangeStatus
soMaxTotalHeaderLength :: Int
soPort :: forall impl. ServeOptions impl -> Port
soHost :: forall impl. ServeOptions impl -> HostPreference
soConnParams :: forall impl. ServeOptions impl -> ConnParams
soTxIso :: forall impl. ServeOptions impl -> TxIsolation
soAdminSecret :: forall impl. ServeOptions impl -> HashSet AdminSecretHash
soAuthHook :: forall impl. ServeOptions impl -> Maybe AuthHook
soJwtSecret :: forall impl. ServeOptions impl -> [JWTConfig]
soUnAuthRole :: forall impl. ServeOptions impl -> Maybe RoleName
soCorsConfig :: forall impl. ServeOptions impl -> CorsConfig
soConsoleStatus :: forall impl. ServeOptions impl -> ConsoleStatus
soConsoleAssetsDir :: forall impl. ServeOptions impl -> Maybe Text
soConsoleSentryDsn :: forall impl. ServeOptions impl -> Maybe Text
soEnableTelemetry :: forall impl. ServeOptions impl -> TelemetryStatus
soStringifyNum :: forall impl. ServeOptions impl -> StringifyNumbers
soDangerousBooleanCollapse :: forall impl. ServeOptions impl -> DangerouslyCollapseBooleans
soEnabledAPIs :: forall impl. ServeOptions impl -> HashSet API
soLiveQueryOpts :: forall impl. ServeOptions impl -> StreamQueriesOptions
soStreamingQueryOpts :: forall impl. ServeOptions impl -> StreamQueriesOptions
soEnableAllowList :: forall impl. ServeOptions impl -> AllowListStatus
soEnabledLogTypes :: forall impl. ServeOptions impl -> HashSet (EngineLogType impl)
soLogLevel :: forall impl. ServeOptions impl -> LogLevel
soEventsHttpPoolSize :: forall impl. ServeOptions impl -> Refined Positive Int
soEventsFetchInterval :: forall impl. ServeOptions impl -> Refined NonNegative Milliseconds
soAsyncActionsFetchInterval :: forall impl. ServeOptions impl -> OptionalInterval
soEnableRemoteSchemaPermissions :: forall impl. ServeOptions impl -> RemoteSchemaPermissions
soConnectionOptions :: forall impl. ServeOptions impl -> ConnectionOptions
soWebSocketKeepAlive :: forall impl. ServeOptions impl -> KeepAliveDelay
soInferFunctionPermissions :: forall impl. ServeOptions impl -> InferFunctionPermissions
soEnableMaintenanceMode :: forall impl. ServeOptions impl -> MaintenanceMode ()
soSchemaPollInterval :: forall impl. ServeOptions impl -> OptionalInterval
soExperimentalFeatures :: forall impl. ServeOptions impl -> HashSet ExperimentalFeature
soEventsFetchBatchSize :: forall impl. ServeOptions impl -> Refined NonNegative Int
soDevMode :: forall impl. ServeOptions impl -> DevModeStatus
soAdminInternalErrors :: forall impl. ServeOptions impl -> AdminInternalErrorsStatus
soGracefulShutdownTimeout :: forall impl. ServeOptions impl -> Refined NonNegative Seconds
soWebSocketConnectionInitTimeout :: forall impl. ServeOptions impl -> WSConnectionInitTimeout
soEventingMode :: forall impl. ServeOptions impl -> EventingMode
soReadOnlyMode :: forall impl. ServeOptions impl -> ReadOnlyMode
soEnableMetadataQueryLogging :: forall impl. ServeOptions impl -> MetadataQueryLoggingMode
soDefaultNamingConvention :: forall impl. ServeOptions impl -> NamingCase
soExtensionsSchema :: forall impl. ServeOptions impl -> ExtensionsSchema
soMetadataDefaults :: forall impl. ServeOptions impl -> MetadataDefaults
soApolloFederationStatus :: forall impl. ServeOptions impl -> ApolloFederationStatus
soCloseWebsocketsOnMetadataChangeStatus :: forall impl.
ServeOptions impl -> CloseWebsocketsOnMetadataChangeStatus
soMaxTotalHeaderLength :: forall impl. ServeOptions impl -> Int
..} Maybe SubscriptionPostPollHook
liveQueryHook ServerMetrics
serverMetrics PrometheusMetrics
prometheusMetrics SamplingPolicy
traceSamplingPolicy = do
  loggers :: Loggers
loggers@(Loggers LoggerCtx Hasura
_loggerCtx Logger Hasura
logger PGLogger
pgLogger) <- HashSet (EngineLogType Hasura) -> LogLevel -> ManagedT m Loggers
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
HashSet (EngineLogType Hasura) -> LogLevel -> ManagedT m Loggers
mkLoggers HashSet (EngineLogType Hasura)
soEnabledLogTypes LogLevel
soLogLevel

  -- SIDE EFFECT: print a warning if no admin secret is set.
  Bool -> ManagedT m () -> ManagedT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HashSet AdminSecretHash -> Bool
forall a. HashSet a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HashSet AdminSecretHash
soAdminSecret)
    (ManagedT m () -> ManagedT m ()) -> ManagedT m () -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger
      Logger Hasura
logger
      StartupLog
        { slLogLevel :: LogLevel
slLogLevel = LogLevel
LevelWarn,
          slKind :: Text
slKind = Text
"no_admin_secret",
          slInfo :: Value
slInfo = Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Text
"WARNING: No admin secret provided" :: Text)
        }

  -- SIDE EFFECT: log all server options.
  Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (StartupLog -> ManagedT m ()) -> StartupLog -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ ServeOptions Hasura -> StartupLog
forall impl.
ToJSON (EngineLogType impl) =>
ServeOptions impl -> StartupLog
serveOptsToLog ServeOptions Hasura
serveOptions

  -- SIDE EFFECT: log metadata postgres connection info.
  Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (StartupLog -> ManagedT m ()) -> StartupLog -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ ConnInfo -> StartupLog
connInfoToLog ConnInfo
bciMetadataConnInfo

  -- Generate the instance id.
  InstanceId
instanceId <- IO InstanceId -> ManagedT m InstanceId
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InstanceId
generateInstanceId

  -- Init metadata db pool.
  PGPool
metadataDbPool <-
    m PGPool -> (PGPool -> m ()) -> ManagedT m PGPool
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> (a -> m b) -> ManagedT m a
allocate
      (IO PGPool -> m PGPool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PGPool -> m PGPool) -> IO PGPool -> m PGPool
forall a b. (a -> b) -> a -> b
$ ConnInfo -> ConnParams -> PGLogger -> IO PGPool
PG.initPGPool ConnInfo
bciMetadataConnInfo ConnParams
soConnParams PGLogger
pgLogger)
      (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (PGPool -> IO ()) -> PGPool -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGPool -> IO ()
PG.destroyPGPool)

  -- Migrate the catalog and fetch the metdata.
  MetadataWithResourceVersion
metadataWithVersion <-
    m MetadataWithResourceVersion
-> ManagedT m MetadataWithResourceVersion
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
      (m MetadataWithResourceVersion
 -> ManagedT m MetadataWithResourceVersion)
-> m MetadataWithResourceVersion
-> ManagedT m MetadataWithResourceVersion
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> PGPool
-> Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> MaintenanceMode ()
-> ExtensionsSchema
-> m MetadataWithResourceVersion
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
Logger Hasura
-> PGPool
-> Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> MaintenanceMode ()
-> ExtensionsSchema
-> m MetadataWithResourceVersion
migrateCatalogAndFetchMetadata
        Logger Hasura
logger
        PGPool
metadataDbPool
        Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
Maybe PostgresConnConfiguration
bciDefaultPostgres
        MaintenanceMode ()
soEnableMaintenanceMode
        ExtensionsSchema
soExtensionsSchema

  -- Create the TLSAllowListRef and the HTTP Manager.
  let metadata :: Metadata
metadata = MetadataWithResourceVersion -> Metadata
_mwrvMetadata MetadataWithResourceVersion
metadataWithVersion
  TLSAllowListRef
tlsAllowListRef <- IO TLSAllowListRef -> ManagedT m TLSAllowListRef
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TLSAllowListRef -> ManagedT m TLSAllowListRef)
-> IO TLSAllowListRef -> ManagedT m TLSAllowListRef
forall a b. (a -> b) -> a -> b
$ [TlsAllow] -> IO TLSAllowListRef
createTLSAllowListRef ([TlsAllow] -> IO TLSAllowListRef)
-> [TlsAllow] -> IO TLSAllowListRef
forall a b. (a -> b) -> a -> b
$ Network -> [TlsAllow]
networkTlsAllowlist (Network -> [TlsAllow]) -> Network -> [TlsAllow]
forall a b. (a -> b) -> a -> b
$ Metadata -> Network
_metaNetwork Metadata
metadata
  Manager
httpManager <- IO Manager -> ManagedT m Manager
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> ManagedT m Manager)
-> IO Manager -> ManagedT m Manager
forall a b. (a -> b) -> a -> b
$ IO [TlsAllow] -> Blocklist -> IO Manager
mkHttpManager (TLSAllowListRef -> IO [TlsAllow]
readTLSAllowList TLSAllowListRef
tlsAllowListRef) Blocklist
forall a. Monoid a => a
mempty

  -- Start a background thread for listening schema sync events from other
  -- server instances (an interval of 0 indicates that no schema sync is
  -- required). Logs whether the thread is started or not, and with what
  -- interval.
  -- TODO: extract into a separate init function.
  TMVar MetadataResourceVersion
metaVersionRef <- IO (TMVar MetadataResourceVersion)
-> ManagedT m (TMVar MetadataResourceVersion)
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TMVar MetadataResourceVersion)
 -> ManagedT m (TMVar MetadataResourceVersion))
-> IO (TMVar MetadataResourceVersion)
-> ManagedT m (TMVar MetadataResourceVersion)
forall a b. (a -> b) -> a -> b
$ IO (TMVar MetadataResourceVersion)
forall a. IO (TMVar a)
STM.newEmptyTMVarIO
  case OptionalInterval
soSchemaPollInterval of
    OptionalInterval
Skip -> Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (StartupLog -> ManagedT m ()) -> StartupLog -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @Text LogLevel
LevelInfo Text
"schema-sync" Text
"Schema sync disabled"
    Interval Refined NonNegative Milliseconds
interval -> do
      Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (StartupLog -> ManagedT m ()) -> StartupLog -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @String LogLevel
LevelInfo Text
"schema-sync" (String
"Schema sync enabled. Polling at " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Refined NonNegative Milliseconds -> String
forall a. Show a => a -> String
show Refined NonNegative Milliseconds
interval)
      ManagedT m Thread -> ManagedT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ManagedT m Thread -> ManagedT m ())
-> ManagedT m Thread -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> PGPool
-> InstanceId
-> Refined NonNegative Milliseconds
-> TMVar MetadataResourceVersion
-> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
Logger Hasura
-> PGPool
-> InstanceId
-> Refined NonNegative Milliseconds
-> TMVar MetadataResourceVersion
-> ManagedT m Thread
startSchemaSyncListenerThread Logger Hasura
logger PGPool
metadataDbPool InstanceId
instanceId Refined NonNegative Milliseconds
interval TMVar MetadataResourceVersion
metaVersionRef

  -- Generate the shutdown latch.
  ShutdownLatch
latch <- IO ShutdownLatch -> ManagedT m ShutdownLatch
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ShutdownLatch
newShutdownLatch

  -- Generate subscription state.
  SubscriptionsState
subscriptionsState <- IO SubscriptionsState -> ManagedT m SubscriptionsState
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SubscriptionsState -> ManagedT m SubscriptionsState)
-> IO SubscriptionsState -> ManagedT m SubscriptionsState
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> Maybe SubscriptionPostPollHook -> IO SubscriptionsState
initSubscriptionsState Logger Hasura
logger Maybe SubscriptionPostPollHook
liveQueryHook

  -- Generate event's trigger shared state
  LockedEventsCtx
lockedEventsCtx <- IO LockedEventsCtx -> ManagedT m LockedEventsCtx
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LockedEventsCtx -> ManagedT m LockedEventsCtx)
-> IO LockedEventsCtx -> ManagedT m LockedEventsCtx
forall a b. (a -> b) -> a -> b
$ IO LockedEventsCtx
initLockedEventsCtx

  (AppInit, AppEnv) -> ManagedT m (AppInit, AppEnv)
forall a. a -> ManagedT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( AppInit
        { aiTLSAllowListRef :: TLSAllowListRef
aiTLSAllowListRef = TLSAllowListRef
tlsAllowListRef,
          aiMetadataWithResourceVersion :: MetadataWithResourceVersion
aiMetadataWithResourceVersion = MetadataWithResourceVersion
metadataWithVersion
        },
      AppEnv
        { appEnvPort :: Port
appEnvPort = Port
soPort,
          appEnvHost :: HostPreference
appEnvHost = HostPreference
soHost,
          appEnvMetadataDbPool :: PGPool
appEnvMetadataDbPool = PGPool
metadataDbPool,
          appEnvIntrospectionDbPool :: Maybe PGPool
appEnvIntrospectionDbPool = Maybe PGPool
forall a. Maybe a
Nothing, -- No introspection storage for self-hosted CE
          appEnvManager :: Manager
appEnvManager = Manager
httpManager,
          appEnvLoggers :: Loggers
appEnvLoggers = Loggers
loggers,
          appEnvMetadataVersionRef :: TMVar MetadataResourceVersion
appEnvMetadataVersionRef = TMVar MetadataResourceVersion
metaVersionRef,
          appEnvInstanceId :: InstanceId
appEnvInstanceId = InstanceId
instanceId,
          appEnvEnableMaintenanceMode :: MaintenanceMode ()
appEnvEnableMaintenanceMode = MaintenanceMode ()
soEnableMaintenanceMode,
          appEnvLoggingSettings :: LoggingSettings
appEnvLoggingSettings = HashSet (EngineLogType Hasura)
-> MetadataQueryLoggingMode -> LoggingSettings
LoggingSettings HashSet (EngineLogType Hasura)
soEnabledLogTypes MetadataQueryLoggingMode
soEnableMetadataQueryLogging,
          appEnvEventingMode :: EventingMode
appEnvEventingMode = EventingMode
soEventingMode,
          appEnvEnableReadOnlyMode :: ReadOnlyMode
appEnvEnableReadOnlyMode = ReadOnlyMode
soReadOnlyMode,
          appEnvServerMetrics :: ServerMetrics
appEnvServerMetrics = ServerMetrics
serverMetrics,
          appEnvShutdownLatch :: ShutdownLatch
appEnvShutdownLatch = ShutdownLatch
latch,
          appEnvMetaVersionRef :: TMVar MetadataResourceVersion
appEnvMetaVersionRef = TMVar MetadataResourceVersion
metaVersionRef,
          appEnvPrometheusMetrics :: PrometheusMetrics
appEnvPrometheusMetrics = PrometheusMetrics
prometheusMetrics,
          appEnvTraceSamplingPolicy :: SamplingPolicy
appEnvTraceSamplingPolicy = SamplingPolicy
traceSamplingPolicy,
          appEnvSubscriptionState :: SubscriptionsState
appEnvSubscriptionState = SubscriptionsState
subscriptionsState,
          appEnvLockedEventsCtx :: LockedEventsCtx
appEnvLockedEventsCtx = LockedEventsCtx
lockedEventsCtx,
          appEnvConnParams :: ConnParams
appEnvConnParams = ConnParams
soConnParams,
          appEnvTxIso :: TxIsolation
appEnvTxIso = TxIsolation
soTxIso,
          appEnvConsoleAssetsDir :: Maybe Text
appEnvConsoleAssetsDir = Maybe Text
soConsoleAssetsDir,
          appEnvConsoleSentryDsn :: Maybe Text
appEnvConsoleSentryDsn = Maybe Text
soConsoleSentryDsn,
          appEnvConnectionOptions :: ConnectionOptions
appEnvConnectionOptions = ConnectionOptions
soConnectionOptions,
          appEnvWebSocketKeepAlive :: KeepAliveDelay
appEnvWebSocketKeepAlive = KeepAliveDelay
soWebSocketKeepAlive,
          appEnvWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
appEnvWebSocketConnectionInitTimeout = WSConnectionInitTimeout
soWebSocketConnectionInitTimeout,
          appEnvGracefulShutdownTimeout :: Refined NonNegative Seconds
appEnvGracefulShutdownTimeout = Refined NonNegative Seconds
soGracefulShutdownTimeout,
          appEnvCheckFeatureFlag :: CheckFeatureFlag
appEnvCheckFeatureFlag = Environment -> CheckFeatureFlag
ceCheckFeatureFlag Environment
env,
          appEnvSchemaPollInterval :: OptionalInterval
appEnvSchemaPollInterval = OptionalInterval
soSchemaPollInterval,
          appEnvLicenseKeyCache :: Maybe (CredentialCache AgentLicenseKey)
appEnvLicenseKeyCache = Maybe (CredentialCache AgentLicenseKey)
forall a. Maybe a
Nothing,
          appEnvMaxTotalHeaderLength :: Int
appEnvMaxTotalHeaderLength = Int
soMaxTotalHeaderLength
        }
    )

-- | Initializes the 'AppContext' and returns a corresponding 'AppStateRef'.
--
-- This function is meant to be run in the app monad, which provides the
-- 'AppEnv'.
initialiseAppContext ::
  (C.ForkableMonadIO m, HasAppEnv m) =>
  Env.Environment ->
  ServeOptions Hasura ->
  AppInit ->
  m (AppStateRef Hasura)
initialiseAppContext :: forall (m :: * -> *).
(ForkableMonadIO m, HasAppEnv m) =>
Environment
-> ServeOptions Hasura -> AppInit -> m (AppStateRef Hasura)
initialiseAppContext Environment
env serveOptions :: ServeOptions Hasura
serveOptions@ServeOptions {Int
[JWTConfig]
Maybe Text
Maybe RoleName
Maybe AuthHook
HostPreference
HashSet (EngineLogType Hasura)
HashSet ExperimentalFeature
HashSet AdminSecretHash
HashSet API
TxIsolation
ConnParams
Refined NonNegative Int
Refined NonNegative Milliseconds
Refined NonNegative Seconds
Refined Positive Int
ConnectionOptions
StreamQueriesOptions
LogLevel
NamingCase
RemoteSchemaPermissions
InferFunctionPermissions
DangerouslyCollapseBooleans
StringifyNumbers
ExtensionsSchema
CloseWebsocketsOnMetadataChangeStatus
ApolloFederationStatus
EventingMode
ReadOnlyMode
MaintenanceMode ()
CorsConfig
MetadataQueryLoggingMode
MetadataDefaults
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
TelemetryStatus
DevModeStatus
AllowListStatus
AdminInternalErrorsStatus
ConsoleStatus
soPort :: forall impl. ServeOptions impl -> Port
soHost :: forall impl. ServeOptions impl -> HostPreference
soConnParams :: forall impl. ServeOptions impl -> ConnParams
soTxIso :: forall impl. ServeOptions impl -> TxIsolation
soAdminSecret :: forall impl. ServeOptions impl -> HashSet AdminSecretHash
soAuthHook :: forall impl. ServeOptions impl -> Maybe AuthHook
soJwtSecret :: forall impl. ServeOptions impl -> [JWTConfig]
soUnAuthRole :: forall impl. ServeOptions impl -> Maybe RoleName
soCorsConfig :: forall impl. ServeOptions impl -> CorsConfig
soConsoleStatus :: forall impl. ServeOptions impl -> ConsoleStatus
soConsoleAssetsDir :: forall impl. ServeOptions impl -> Maybe Text
soConsoleSentryDsn :: forall impl. ServeOptions impl -> Maybe Text
soEnableTelemetry :: forall impl. ServeOptions impl -> TelemetryStatus
soStringifyNum :: forall impl. ServeOptions impl -> StringifyNumbers
soDangerousBooleanCollapse :: forall impl. ServeOptions impl -> DangerouslyCollapseBooleans
soEnabledAPIs :: forall impl. ServeOptions impl -> HashSet API
soLiveQueryOpts :: forall impl. ServeOptions impl -> StreamQueriesOptions
soStreamingQueryOpts :: forall impl. ServeOptions impl -> StreamQueriesOptions
soEnableAllowList :: forall impl. ServeOptions impl -> AllowListStatus
soEnabledLogTypes :: forall impl. ServeOptions impl -> HashSet (EngineLogType impl)
soLogLevel :: forall impl. ServeOptions impl -> LogLevel
soEventsHttpPoolSize :: forall impl. ServeOptions impl -> Refined Positive Int
soEventsFetchInterval :: forall impl. ServeOptions impl -> Refined NonNegative Milliseconds
soAsyncActionsFetchInterval :: forall impl. ServeOptions impl -> OptionalInterval
soEnableRemoteSchemaPermissions :: forall impl. ServeOptions impl -> RemoteSchemaPermissions
soConnectionOptions :: forall impl. ServeOptions impl -> ConnectionOptions
soWebSocketKeepAlive :: forall impl. ServeOptions impl -> KeepAliveDelay
soInferFunctionPermissions :: forall impl. ServeOptions impl -> InferFunctionPermissions
soEnableMaintenanceMode :: forall impl. ServeOptions impl -> MaintenanceMode ()
soSchemaPollInterval :: forall impl. ServeOptions impl -> OptionalInterval
soExperimentalFeatures :: forall impl. ServeOptions impl -> HashSet ExperimentalFeature
soEventsFetchBatchSize :: forall impl. ServeOptions impl -> Refined NonNegative Int
soDevMode :: forall impl. ServeOptions impl -> DevModeStatus
soAdminInternalErrors :: forall impl. ServeOptions impl -> AdminInternalErrorsStatus
soGracefulShutdownTimeout :: forall impl. ServeOptions impl -> Refined NonNegative Seconds
soWebSocketConnectionInitTimeout :: forall impl. ServeOptions impl -> WSConnectionInitTimeout
soEventingMode :: forall impl. ServeOptions impl -> EventingMode
soReadOnlyMode :: forall impl. ServeOptions impl -> ReadOnlyMode
soEnableMetadataQueryLogging :: forall impl. ServeOptions impl -> MetadataQueryLoggingMode
soDefaultNamingConvention :: forall impl. ServeOptions impl -> NamingCase
soExtensionsSchema :: forall impl. ServeOptions impl -> ExtensionsSchema
soMetadataDefaults :: forall impl. ServeOptions impl -> MetadataDefaults
soApolloFederationStatus :: forall impl. ServeOptions impl -> ApolloFederationStatus
soCloseWebsocketsOnMetadataChangeStatus :: forall impl.
ServeOptions impl -> CloseWebsocketsOnMetadataChangeStatus
soMaxTotalHeaderLength :: forall impl. ServeOptions impl -> Int
soPort :: Port
soHost :: HostPreference
soConnParams :: ConnParams
soTxIso :: TxIsolation
soAdminSecret :: HashSet AdminSecretHash
soAuthHook :: Maybe AuthHook
soJwtSecret :: [JWTConfig]
soUnAuthRole :: Maybe RoleName
soCorsConfig :: CorsConfig
soConsoleStatus :: ConsoleStatus
soConsoleAssetsDir :: Maybe Text
soConsoleSentryDsn :: Maybe Text
soEnableTelemetry :: TelemetryStatus
soStringifyNum :: StringifyNumbers
soDangerousBooleanCollapse :: DangerouslyCollapseBooleans
soEnabledAPIs :: HashSet API
soLiveQueryOpts :: StreamQueriesOptions
soStreamingQueryOpts :: StreamQueriesOptions
soEnableAllowList :: AllowListStatus
soEnabledLogTypes :: HashSet (EngineLogType Hasura)
soLogLevel :: LogLevel
soEventsHttpPoolSize :: Refined Positive Int
soEventsFetchInterval :: Refined NonNegative Milliseconds
soAsyncActionsFetchInterval :: OptionalInterval
soEnableRemoteSchemaPermissions :: RemoteSchemaPermissions
soConnectionOptions :: ConnectionOptions
soWebSocketKeepAlive :: KeepAliveDelay
soInferFunctionPermissions :: InferFunctionPermissions
soEnableMaintenanceMode :: MaintenanceMode ()
soSchemaPollInterval :: OptionalInterval
soExperimentalFeatures :: HashSet ExperimentalFeature
soEventsFetchBatchSize :: Refined NonNegative Int
soDevMode :: DevModeStatus
soAdminInternalErrors :: AdminInternalErrorsStatus
soGracefulShutdownTimeout :: Refined NonNegative Seconds
soWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
soEventingMode :: EventingMode
soReadOnlyMode :: ReadOnlyMode
soEnableMetadataQueryLogging :: MetadataQueryLoggingMode
soDefaultNamingConvention :: NamingCase
soExtensionsSchema :: ExtensionsSchema
soMetadataDefaults :: MetadataDefaults
soApolloFederationStatus :: ApolloFederationStatus
soCloseWebsocketsOnMetadataChangeStatus :: CloseWebsocketsOnMetadataChangeStatus
soMaxTotalHeaderLength :: Int
..} AppInit {MetadataWithResourceVersion
TLSAllowListRef
aiTLSAllowListRef :: AppInit -> TLSAllowListRef
aiMetadataWithResourceVersion :: AppInit -> MetadataWithResourceVersion
aiTLSAllowListRef :: TLSAllowListRef
aiMetadataWithResourceVersion :: MetadataWithResourceVersion
..} = do
  appEnv :: AppEnv
appEnv@AppEnv {Int
Maybe Text
Maybe PGPool
Maybe (CredentialCache AgentLicenseKey)
SamplingPolicy
HostPreference
Manager
TxIsolation
ConnParams
PGPool
Refined NonNegative Seconds
TMVar MetadataResourceVersion
ConnectionOptions
CheckFeatureFlag
ServerMetrics
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
PrometheusMetrics
ShutdownLatch
LoggingSettings
LockedEventsCtx
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
SubscriptionsState
Loggers
appEnvPort :: AppEnv -> Port
appEnvHost :: AppEnv -> HostPreference
appEnvMetadataDbPool :: AppEnv -> PGPool
appEnvIntrospectionDbPool :: AppEnv -> Maybe PGPool
appEnvManager :: AppEnv -> Manager
appEnvLoggers :: AppEnv -> Loggers
appEnvMetadataVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvInstanceId :: AppEnv -> InstanceId
appEnvEnableMaintenanceMode :: AppEnv -> MaintenanceMode ()
appEnvLoggingSettings :: AppEnv -> LoggingSettings
appEnvEventingMode :: AppEnv -> EventingMode
appEnvEnableReadOnlyMode :: AppEnv -> ReadOnlyMode
appEnvServerMetrics :: AppEnv -> ServerMetrics
appEnvShutdownLatch :: AppEnv -> ShutdownLatch
appEnvMetaVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: AppEnv -> PrometheusMetrics
appEnvTraceSamplingPolicy :: AppEnv -> SamplingPolicy
appEnvSubscriptionState :: AppEnv -> SubscriptionsState
appEnvLockedEventsCtx :: AppEnv -> LockedEventsCtx
appEnvConnParams :: AppEnv -> ConnParams
appEnvTxIso :: AppEnv -> TxIsolation
appEnvConsoleAssetsDir :: AppEnv -> Maybe Text
appEnvConsoleSentryDsn :: AppEnv -> Maybe Text
appEnvConnectionOptions :: AppEnv -> ConnectionOptions
appEnvWebSocketKeepAlive :: AppEnv -> KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: AppEnv -> WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: AppEnv -> Refined NonNegative Seconds
appEnvCheckFeatureFlag :: AppEnv -> CheckFeatureFlag
appEnvSchemaPollInterval :: AppEnv -> OptionalInterval
appEnvLicenseKeyCache :: AppEnv -> Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: AppEnv -> Int
appEnvPort :: Port
appEnvHost :: HostPreference
appEnvMetadataDbPool :: PGPool
appEnvIntrospectionDbPool :: Maybe PGPool
appEnvManager :: Manager
appEnvLoggers :: Loggers
appEnvMetadataVersionRef :: TMVar MetadataResourceVersion
appEnvInstanceId :: InstanceId
appEnvEnableMaintenanceMode :: MaintenanceMode ()
appEnvLoggingSettings :: LoggingSettings
appEnvEventingMode :: EventingMode
appEnvEnableReadOnlyMode :: ReadOnlyMode
appEnvServerMetrics :: ServerMetrics
appEnvShutdownLatch :: ShutdownLatch
appEnvMetaVersionRef :: TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: PrometheusMetrics
appEnvTraceSamplingPolicy :: SamplingPolicy
appEnvSubscriptionState :: SubscriptionsState
appEnvLockedEventsCtx :: LockedEventsCtx
appEnvConnParams :: ConnParams
appEnvTxIso :: TxIsolation
appEnvConsoleAssetsDir :: Maybe Text
appEnvConsoleSentryDsn :: Maybe Text
appEnvConnectionOptions :: ConnectionOptions
appEnvWebSocketKeepAlive :: KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: Refined NonNegative Seconds
appEnvSchemaPollInterval :: OptionalInterval
appEnvCheckFeatureFlag :: CheckFeatureFlag
appEnvLicenseKeyCache :: Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: Int
..} <- m AppEnv
forall (m :: * -> *). HasAppEnv m => m AppEnv
askAppEnv
  let cacheStaticConfig :: CacheStaticConfig
cacheStaticConfig = AppEnv -> CacheStaticConfig
buildCacheStaticConfig AppEnv
appEnv
      Loggers LoggerCtx Hasura
_ Logger Hasura
logger PGLogger
pgLogger = Loggers
appEnvLoggers
      sqlGenCtx :: SQLGenCtx
sqlGenCtx = HashSet ExperimentalFeature
-> StringifyNumbers -> DangerouslyCollapseBooleans -> SQLGenCtx
initSQLGenCtx HashSet ExperimentalFeature
soExperimentalFeatures StringifyNumbers
soStringifyNum DangerouslyCollapseBooleans
soDangerousBooleanCollapse
      cacheDynamicConfig :: CacheDynamicConfig
cacheDynamicConfig =
        InferFunctionPermissions
-> RemoteSchemaPermissions
-> SQLGenCtx
-> HashSet ExperimentalFeature
-> NamingCase
-> MetadataDefaults
-> ApolloFederationStatus
-> CloseWebsocketsOnMetadataChangeStatus
-> CacheDynamicConfig
CacheDynamicConfig
          InferFunctionPermissions
soInferFunctionPermissions
          RemoteSchemaPermissions
soEnableRemoteSchemaPermissions
          SQLGenCtx
sqlGenCtx
          HashSet ExperimentalFeature
soExperimentalFeatures
          NamingCase
soDefaultNamingConvention
          MetadataDefaults
soMetadataDefaults
          ApolloFederationStatus
soApolloFederationStatus
          CloseWebsocketsOnMetadataChangeStatus
soCloseWebsocketsOnMetadataChangeStatus

  -- Create the schema cache
  RebuildableSchemaCache
rebuildableSchemaCache <-
    Environment
-> Logger Hasura
-> SourceResolver ('Postgres 'Vanilla)
-> SourceResolver 'MSSQL
-> MetadataWithResourceVersion
-> CacheStaticConfig
-> CacheDynamicConfig
-> Manager
-> Maybe SchemaRegistryContext
-> m RebuildableSchemaCache
forall (m :: * -> *).
MonadIO m =>
Environment
-> Logger Hasura
-> SourceResolver ('Postgres 'Vanilla)
-> SourceResolver 'MSSQL
-> MetadataWithResourceVersion
-> CacheStaticConfig
-> CacheDynamicConfig
-> Manager
-> Maybe SchemaRegistryContext
-> m RebuildableSchemaCache
buildFirstSchemaCache
      Environment
env
      Logger Hasura
logger
      (PGLogger -> SourceResolver ('Postgres 'Vanilla)
mkPgSourceResolver PGLogger
pgLogger)
      SourceResolver 'MSSQL
mkMSSQLSourceResolver
      MetadataWithResourceVersion
aiMetadataWithResourceVersion
      CacheStaticConfig
cacheStaticConfig
      CacheDynamicConfig
cacheDynamicConfig
      Manager
appEnvManager
      Maybe SchemaRegistryContext
forall a. Maybe a
Nothing

  -- Build the RebuildableAppContext.
  -- (See note [Hasura Application State].)
  Either QErr (RebuildableAppContext Hasura)
rebuildableAppCtxE <- IO (Either QErr (RebuildableAppContext Hasura))
-> m (Either QErr (RebuildableAppContext Hasura))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either QErr (RebuildableAppContext Hasura))
 -> m (Either QErr (RebuildableAppContext Hasura)))
-> IO (Either QErr (RebuildableAppContext Hasura))
-> m (Either QErr (RebuildableAppContext Hasura))
forall a b. (a -> b) -> a -> b
$ ExceptT QErr IO (RebuildableAppContext Hasura)
-> IO (Either QErr (RebuildableAppContext Hasura))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ((Logger Hasura, Manager)
-> ServeOptions Hasura
-> Environment
-> ExceptT QErr IO (RebuildableAppContext Hasura)
forall impl.
(Logger Hasura, Manager)
-> ServeOptions impl
-> Environment
-> ExceptT QErr IO (RebuildableAppContext impl)
buildRebuildableAppContext (Logger Hasura
logger, Manager
appEnvManager) ServeOptions Hasura
serveOptions Environment
env)
  !RebuildableAppContext Hasura
rebuildableAppCtx <- Either QErr (RebuildableAppContext Hasura)
-> (QErr -> m (RebuildableAppContext Hasura))
-> m (RebuildableAppContext Hasura)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr (RebuildableAppContext Hasura)
rebuildableAppCtxE ((QErr -> m (RebuildableAppContext Hasura))
 -> m (RebuildableAppContext Hasura))
-> (QErr -> m (RebuildableAppContext Hasura))
-> m (RebuildableAppContext Hasura)
forall a b. (a -> b) -> a -> b
$ \QErr
e -> ExitCode -> String -> m (RebuildableAppContext Hasura)
forall a. ExitCode -> String -> m a
forall (m :: * -> *) a. MonadIO m => ExitCode -> String -> m a
throwErrExit ExitCode
InvalidEnvironmentVariableOptionsError (String -> m (RebuildableAppContext Hasura))
-> String -> m (RebuildableAppContext Hasura)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ QErr -> Text
qeError QErr
e

  -- Initialise the 'AppStateRef' from 'RebuildableSchemaCacheRef' and 'RebuildableAppContext'.
  TLSAllowListRef
-> Maybe MetricsConfigRef
-> ServerMetrics
-> RebuildableSchemaCache
-> RebuildableAppContext Hasura
-> m (AppStateRef Hasura)
forall (m :: * -> *) impl.
MonadIO m =>
TLSAllowListRef
-> Maybe MetricsConfigRef
-> ServerMetrics
-> RebuildableSchemaCache
-> RebuildableAppContext impl
-> m (AppStateRef impl)
initialiseAppStateRef TLSAllowListRef
aiTLSAllowListRef Maybe MetricsConfigRef
forall a. Maybe a
Nothing ServerMetrics
appEnvServerMetrics RebuildableSchemaCache
rebuildableSchemaCache RebuildableAppContext Hasura
rebuildableAppCtx

-- | Runs catalogue migration, and returns the metadata that was fetched.
--
-- On success, this function logs the result of the migration, on failure it
-- logs a 'catalog_migrate' error and throws a fatal error.
migrateCatalogAndFetchMetadata ::
  (MonadIO m, MonadBaseControl IO m) =>
  Logger Hasura ->
  PG.PGPool ->
  Maybe (SourceConnConfiguration ('Postgres 'Vanilla)) ->
  MaintenanceMode () ->
  ExtensionsSchema ->
  m MetadataWithResourceVersion
migrateCatalogAndFetchMetadata :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
Logger Hasura
-> PGPool
-> Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> MaintenanceMode ()
-> ExtensionsSchema
-> m MetadataWithResourceVersion
migrateCatalogAndFetchMetadata
  Logger Hasura
logger
  PGPool
pool
  Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
defaultSourceConfig
  MaintenanceMode ()
maintenanceMode
  ExtensionsSchema
extensionsSchema = do
    -- TODO: should we allow the migration to happen during maintenance mode?
    -- Allowing this can be a sanity check, to see if the hdb_catalog in the
    -- DB has been set correctly
    UTCTime
currentTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Clock.getCurrentTime
    Either QErr (MigrationResult, MetadataWithResourceVersion)
result <-
      ExceptT QErr m (MigrationResult, MetadataWithResourceVersion)
-> m (Either QErr (MigrationResult, MetadataWithResourceVersion))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (ExceptT QErr m (MigrationResult, MetadataWithResourceVersion)
 -> m (Either QErr (MigrationResult, MetadataWithResourceVersion)))
-> ExceptT QErr m (MigrationResult, MetadataWithResourceVersion)
-> m (Either QErr (MigrationResult, MetadataWithResourceVersion))
forall a b. (a -> b) -> a -> b
$ PGPool
-> TxMode
-> TxET QErr m (MigrationResult, MetadataWithResourceVersion)
-> ExceptT QErr m (MigrationResult, MetadataWithResourceVersion)
forall (m :: * -> *) e a.
(MonadIO m, MonadBaseControl IO m, FromPGTxErr e,
 FromPGConnErr e) =>
PGPool -> TxMode -> TxET e m a -> ExceptT e m a
PG.runTx PGPool
pool (TxIsolation
PG.Serializable, TxAccess -> Maybe TxAccess
forall a. a -> Maybe a
Just TxAccess
PG.ReadWrite)
        (TxET QErr m (MigrationResult, MetadataWithResourceVersion)
 -> ExceptT QErr m (MigrationResult, MetadataWithResourceVersion))
-> TxET QErr m (MigrationResult, MetadataWithResourceVersion)
-> ExceptT QErr m (MigrationResult, MetadataWithResourceVersion)
forall a b. (a -> b) -> a -> b
$ Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> ExtensionsSchema
-> MaintenanceMode ()
-> UTCTime
-> TxET QErr m (MigrationResult, MetadataWithResourceVersion)
forall (m :: * -> *).
(MonadTx m, MonadIO m, MonadBaseControl IO m) =>
Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> ExtensionsSchema
-> MaintenanceMode ()
-> UTCTime
-> m (MigrationResult, MetadataWithResourceVersion)
migrateCatalog
          Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
defaultSourceConfig
          ExtensionsSchema
extensionsSchema
          MaintenanceMode ()
maintenanceMode
          UTCTime
currentTime
    case Either QErr (MigrationResult, MetadataWithResourceVersion)
result of
      Left QErr
err -> do
        Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger
          Logger Hasura
logger
          StartupLog
            { slLogLevel :: LogLevel
slLogLevel = LogLevel
LevelError,
              slKind :: Text
slKind = Text
"catalog_migrate",
              slInfo :: Value
slInfo = QErr -> Value
forall a. ToJSON a => a -> Value
J.toJSON QErr
err
            }
        IO MetadataWithResourceVersion -> m MetadataWithResourceVersion
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExitCode -> QErr -> IO MetadataWithResourceVersion
forall b. ExitCode -> QErr -> IO b
forall a (m :: * -> *) b.
(ToJSON a, MonadIO m) =>
ExitCode -> a -> m b
throwErrJExit ExitCode
DatabaseMigrationError QErr
err)
      Right (MigrationResult
migrationResult, MetadataWithResourceVersion
metadataWithVersion) -> do
        Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger MigrationResult
migrationResult
        MetadataWithResourceVersion -> m MetadataWithResourceVersion
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MetadataWithResourceVersion
metadataWithVersion

-- | Build the original 'RebuildableSchemaCache'.
--
-- On error, it logs a 'catalog_migrate' error and throws a fatal error. This
-- misnomer is intentional: it is to preserve a previous behaviour of the code
-- and avoid a breaking change.
buildFirstSchemaCache ::
  (MonadIO m) =>
  Env.Environment ->
  Logger Hasura ->
  SourceResolver ('Postgres 'Vanilla) ->
  SourceResolver ('MSSQL) ->
  MetadataWithResourceVersion ->
  CacheStaticConfig ->
  CacheDynamicConfig ->
  HTTP.Manager ->
  Maybe SchemaRegistry.SchemaRegistryContext ->
  m RebuildableSchemaCache
buildFirstSchemaCache :: forall (m :: * -> *).
MonadIO m =>
Environment
-> Logger Hasura
-> SourceResolver ('Postgres 'Vanilla)
-> SourceResolver 'MSSQL
-> MetadataWithResourceVersion
-> CacheStaticConfig
-> CacheDynamicConfig
-> Manager
-> Maybe SchemaRegistryContext
-> m RebuildableSchemaCache
buildFirstSchemaCache
  Environment
env
  Logger Hasura
logger
  SourceResolver ('Postgres 'Vanilla)
pgSourceResolver
  SourceResolver 'MSSQL
mssqlSourceResolver
  MetadataWithResourceVersion
metadataWithVersion
  CacheStaticConfig
cacheStaticConfig
  CacheDynamicConfig
cacheDynamicConfig
  Manager
httpManager
  Maybe SchemaRegistryContext
mSchemaRegistryContext = do
    let cacheBuildParams :: CacheBuildParams
cacheBuildParams = Manager
-> SourceResolver ('Postgres 'Vanilla)
-> SourceResolver 'MSSQL
-> CacheStaticConfig
-> CacheBuildParams
CacheBuildParams Manager
httpManager SourceResolver ('Postgres 'Vanilla)
pgSourceResolver SourceResolver 'MSSQL
mssqlSourceResolver CacheStaticConfig
cacheStaticConfig
    Either QErr RebuildableSchemaCache
result <-
      ExceptT QErr m RebuildableSchemaCache
-> m (Either QErr RebuildableSchemaCache)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (ExceptT QErr m RebuildableSchemaCache
 -> m (Either QErr RebuildableSchemaCache))
-> ExceptT QErr m RebuildableSchemaCache
-> m (Either QErr RebuildableSchemaCache)
forall a b. (a -> b) -> a -> b
$ CacheBuildParams
-> CacheBuild RebuildableSchemaCache
-> ExceptT QErr m RebuildableSchemaCache
forall (m :: * -> *) a.
(MonadIO m, MonadError QErr m) =>
CacheBuildParams -> CacheBuild a -> m a
runCacheBuild CacheBuildParams
cacheBuildParams
        (CacheBuild RebuildableSchemaCache
 -> ExceptT QErr m RebuildableSchemaCache)
-> CacheBuild RebuildableSchemaCache
-> ExceptT QErr m RebuildableSchemaCache
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> Environment
-> MetadataWithResourceVersion
-> CacheDynamicConfig
-> Maybe SchemaRegistryContext
-> CacheBuild RebuildableSchemaCache
buildRebuildableSchemaCache Logger Hasura
logger Environment
env MetadataWithResourceVersion
metadataWithVersion CacheDynamicConfig
cacheDynamicConfig Maybe SchemaRegistryContext
mSchemaRegistryContext
    Either QErr RebuildableSchemaCache
result Either QErr RebuildableSchemaCache
-> (QErr -> m RebuildableSchemaCache) -> m RebuildableSchemaCache
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` \QErr
err -> do
      -- TODO: we used to bundle the first schema cache build with the catalog
      -- migration, using the same error handler for both, meaning that an
      -- error in the first schema cache build would be reported as
      -- follows. Changing this will be a breaking change.
      Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger
        Logger Hasura
logger
        StartupLog
          { slLogLevel :: LogLevel
slLogLevel = LogLevel
LevelError,
            slKind :: Text
slKind = Text
"catalog_migrate",
            slInfo :: Value
slInfo = QErr -> Value
forall a. ToJSON a => a -> Value
J.toJSON QErr
err
          }
      IO RebuildableSchemaCache -> m RebuildableSchemaCache
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExitCode -> QErr -> IO RebuildableSchemaCache
forall b. ExitCode -> QErr -> IO b
forall a (m :: * -> *) b.
(ToJSON a, MonadIO m) =>
ExitCode -> a -> m b
throwErrJExit ExitCode
DatabaseMigrationError QErr
err)

initSubscriptionsState ::
  Logger Hasura ->
  Maybe ES.SubscriptionPostPollHook ->
  IO ES.SubscriptionsState
initSubscriptionsState :: Logger Hasura
-> Maybe SubscriptionPostPollHook -> IO SubscriptionsState
initSubscriptionsState Logger Hasura
logger Maybe SubscriptionPostPollHook
liveQueryHook = SubscriptionPostPollHook -> IO SubscriptionsState
ES.initSubscriptionsState SubscriptionPostPollHook
postPollHook
  where
    postPollHook :: SubscriptionPostPollHook
postPollHook = SubscriptionPostPollHook
-> Maybe SubscriptionPostPollHook -> SubscriptionPostPollHook
forall a. a -> Maybe a -> a
fromMaybe (Logger Hasura -> SubscriptionPostPollHook
ES.defaultSubscriptionPostPollHook Logger Hasura
logger) Maybe SubscriptionPostPollHook
liveQueryHook

initLockedEventsCtx :: IO LockedEventsCtx
initLockedEventsCtx :: IO LockedEventsCtx
initLockedEventsCtx =
  (TVar (Set CronEventId)
 -> TVar (Set CronEventId)
 -> TVar (HashMap SourceName (Set CronEventId))
 -> TVar (Set CronEventId)
 -> LockedEventsCtx)
-> IO (TVar (Set CronEventId))
-> IO (TVar (Set CronEventId))
-> IO (TVar (HashMap SourceName (Set CronEventId)))
-> IO (TVar (Set CronEventId))
-> IO LockedEventsCtx
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4
    TVar (Set CronEventId)
-> TVar (Set CronEventId)
-> TVar (HashMap SourceName (Set CronEventId))
-> TVar (Set CronEventId)
-> LockedEventsCtx
LockedEventsCtx
    (Set CronEventId -> IO (TVar (Set CronEventId))
forall a. a -> IO (TVar a)
STM.newTVarIO Set CronEventId
forall a. Monoid a => a
mempty)
    (Set CronEventId -> IO (TVar (Set CronEventId))
forall a. a -> IO (TVar a)
STM.newTVarIO Set CronEventId
forall a. Monoid a => a
mempty)
    (HashMap SourceName (Set CronEventId)
-> IO (TVar (HashMap SourceName (Set CronEventId)))
forall a. a -> IO (TVar a)
STM.newTVarIO HashMap SourceName (Set CronEventId)
forall a. Monoid a => a
mempty)
    (Set CronEventId -> IO (TVar (Set CronEventId))
forall a. a -> IO (TVar a)
STM.newTVarIO Set CronEventId
forall a. Monoid a => a
mempty)

--------------------------------------------------------------------------------
-- App monad

-- | The base app monad of the CE engine.
newtype AppM a = AppM (ReaderT AppEnv (TraceT IO) a)
  deriving newtype
    ( (forall a b. (a -> b) -> AppM a -> AppM b)
-> (forall a b. a -> AppM b -> AppM a) -> Functor AppM
forall a b. a -> AppM b -> AppM a
forall a b. (a -> b) -> AppM a -> AppM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> AppM a -> AppM b
fmap :: forall a b. (a -> b) -> AppM a -> AppM b
$c<$ :: forall a b. a -> AppM b -> AppM a
<$ :: forall a b. a -> AppM b -> AppM a
Functor,
      Functor AppM
Functor AppM
-> (forall a. a -> AppM a)
-> (forall a b. AppM (a -> b) -> AppM a -> AppM b)
-> (forall a b c. (a -> b -> c) -> AppM a -> AppM b -> AppM c)
-> (forall a b. AppM a -> AppM b -> AppM b)
-> (forall a b. AppM a -> AppM b -> AppM a)
-> Applicative AppM
forall a. a -> AppM a
forall a b. AppM a -> AppM b -> AppM a
forall a b. AppM a -> AppM b -> AppM b
forall a b. AppM (a -> b) -> AppM a -> AppM b
forall a b c. (a -> b -> c) -> AppM a -> AppM b -> AppM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> AppM a
pure :: forall a. a -> AppM a
$c<*> :: forall a b. AppM (a -> b) -> AppM a -> AppM b
<*> :: forall a b. AppM (a -> b) -> AppM a -> AppM b
$cliftA2 :: forall a b c. (a -> b -> c) -> AppM a -> AppM b -> AppM c
liftA2 :: forall a b c. (a -> b -> c) -> AppM a -> AppM b -> AppM c
$c*> :: forall a b. AppM a -> AppM b -> AppM b
*> :: forall a b. AppM a -> AppM b -> AppM b
$c<* :: forall a b. AppM a -> AppM b -> AppM a
<* :: forall a b. AppM a -> AppM b -> AppM a
Applicative,
      Applicative AppM
Applicative AppM
-> (forall a b. AppM a -> (a -> AppM b) -> AppM b)
-> (forall a b. AppM a -> AppM b -> AppM b)
-> (forall a. a -> AppM a)
-> Monad AppM
forall a. a -> AppM a
forall a b. AppM a -> AppM b -> AppM b
forall a b. AppM a -> (a -> AppM b) -> AppM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. AppM a -> (a -> AppM b) -> AppM b
>>= :: forall a b. AppM a -> (a -> AppM b) -> AppM b
$c>> :: forall a b. AppM a -> AppM b -> AppM b
>> :: forall a b. AppM a -> AppM b -> AppM b
$creturn :: forall a. a -> AppM a
return :: forall a. a -> AppM a
Monad,
      Monad AppM
Monad AppM -> (forall a. IO a -> AppM a) -> MonadIO AppM
forall a. IO a -> AppM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> AppM a
liftIO :: forall a. IO a -> AppM a
MonadIO,
      Monad AppM
Monad AppM -> (forall a. (a -> AppM a) -> AppM a) -> MonadFix AppM
forall a. (a -> AppM a) -> AppM a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall a. (a -> AppM a) -> AppM a
mfix :: forall a. (a -> AppM a) -> AppM a
MonadFix,
      MonadThrow AppM
MonadThrow AppM
-> (forall e a. Exception e => AppM a -> (e -> AppM a) -> AppM a)
-> MonadCatch AppM
forall e a. Exception e => AppM a -> (e -> AppM a) -> AppM a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a. Exception e => AppM a -> (e -> AppM a) -> AppM a
catch :: forall e a. Exception e => AppM a -> (e -> AppM a) -> AppM a
MonadCatch,
      Monad AppM
Monad AppM
-> (forall e a. Exception e => e -> AppM a) -> MonadThrow AppM
forall e a. Exception e => e -> AppM a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
$cthrowM :: forall e a. Exception e => e -> AppM a
throwM :: forall e a. Exception e => e -> AppM a
MonadThrow,
      MonadCatch AppM
MonadCatch AppM
-> (forall b. ((forall a. AppM a -> AppM a) -> AppM b) -> AppM b)
-> (forall b. ((forall a. AppM a -> AppM a) -> AppM b) -> AppM b)
-> (forall a b c.
    AppM a
    -> (a -> ExitCase b -> AppM c) -> (a -> AppM b) -> AppM (b, c))
-> MonadMask AppM
forall b. ((forall a. AppM a -> AppM a) -> AppM b) -> AppM b
forall a b c.
AppM a
-> (a -> ExitCase b -> AppM c) -> (a -> AppM b) -> AppM (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b. ((forall a. AppM a -> AppM a) -> AppM b) -> AppM b
mask :: forall b. ((forall a. AppM a -> AppM a) -> AppM b) -> AppM b
$cuninterruptibleMask :: forall b. ((forall a. AppM a -> AppM a) -> AppM b) -> AppM b
uninterruptibleMask :: forall b. ((forall a. AppM a -> AppM a) -> AppM b) -> AppM b
$cgeneralBracket :: forall a b c.
AppM a
-> (a -> ExitCase b -> AppM c) -> (a -> AppM b) -> AppM (b, c)
generalBracket :: forall a b c.
AppM a
-> (a -> ExitCase b -> AppM c) -> (a -> AppM b) -> AppM (b, c)
MonadMask,
      MonadReader AppEnv,
      MonadBase IO,
      MonadBaseControl IO
    )

runAppM :: AppEnv -> AppM a -> IO a
runAppM :: forall a. AppEnv -> AppM a -> IO a
runAppM AppEnv
c (AppM ReaderT AppEnv (TraceT IO) a
a) = TraceT IO a -> IO a
forall (m :: * -> *) a. TraceT m a -> m a
ignoreTraceT (TraceT IO a -> IO a) -> TraceT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ ReaderT AppEnv (TraceT IO) a -> AppEnv -> TraceT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT AppEnv (TraceT IO) a
a AppEnv
c

instance HasAppEnv AppM where
  askAppEnv :: AppM AppEnv
askAppEnv = AppM AppEnv
forall r (m :: * -> *). MonadReader r m => m r
ask

instance HasFeatureFlagChecker AppM where
  checkFlag :: FeatureFlag -> AppM Bool
checkFlag FeatureFlag
f = ReaderT AppEnv (TraceT IO) Bool -> AppM Bool
forall a. ReaderT AppEnv (TraceT IO) a -> AppM a
AppM do
    CheckFeatureFlag {FeatureFlag -> IO Bool
runCheckFeatureFlag :: FeatureFlag -> IO Bool
runCheckFeatureFlag :: CheckFeatureFlag -> FeatureFlag -> IO Bool
runCheckFeatureFlag} <- (AppEnv -> CheckFeatureFlag)
-> ReaderT AppEnv (TraceT IO) CheckFeatureFlag
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> CheckFeatureFlag
appEnvCheckFeatureFlag
    IO Bool -> ReaderT AppEnv (TraceT IO) Bool
forall a. IO a -> ReaderT AppEnv (TraceT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT AppEnv (TraceT IO) Bool)
-> IO Bool -> ReaderT AppEnv (TraceT IO) Bool
forall a b. (a -> b) -> a -> b
$ FeatureFlag -> IO Bool
runCheckFeatureFlag FeatureFlag
f

instance HasCacheStaticConfig AppM where
  askCacheStaticConfig :: AppM CacheStaticConfig
askCacheStaticConfig = AppEnv -> CacheStaticConfig
buildCacheStaticConfig (AppEnv -> CacheStaticConfig)
-> AppM AppEnv -> AppM CacheStaticConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppM AppEnv
forall (m :: * -> *). HasAppEnv m => m AppEnv
askAppEnv

instance MonadTrace AppM where
  newTraceWith :: forall a.
TraceContext -> SamplingPolicy -> Text -> AppM a -> AppM a
newTraceWith TraceContext
c SamplingPolicy
p Text
n (AppM ReaderT AppEnv (TraceT IO) a
a) = ReaderT AppEnv (TraceT IO) a -> AppM a
forall a. ReaderT AppEnv (TraceT IO) a -> AppM a
AppM (ReaderT AppEnv (TraceT IO) a -> AppM a)
-> ReaderT AppEnv (TraceT IO) a -> AppM a
forall a b. (a -> b) -> a -> b
$ TraceContext
-> SamplingPolicy
-> Text
-> ReaderT AppEnv (TraceT IO) a
-> ReaderT AppEnv (TraceT IO) a
forall a.
TraceContext
-> SamplingPolicy
-> Text
-> ReaderT AppEnv (TraceT IO) a
-> ReaderT AppEnv (TraceT IO) a
forall (m :: * -> *) a.
MonadTrace m =>
TraceContext -> SamplingPolicy -> Text -> m a -> m a
newTraceWith TraceContext
c SamplingPolicy
p Text
n ReaderT AppEnv (TraceT IO) a
a
  newSpanWith :: forall a. SpanId -> Text -> AppM a -> AppM a
newSpanWith SpanId
i Text
n (AppM ReaderT AppEnv (TraceT IO) a
a) = ReaderT AppEnv (TraceT IO) a -> AppM a
forall a. ReaderT AppEnv (TraceT IO) a -> AppM a
AppM (ReaderT AppEnv (TraceT IO) a -> AppM a)
-> ReaderT AppEnv (TraceT IO) a -> AppM a
forall a b. (a -> b) -> a -> b
$ SpanId
-> Text
-> ReaderT AppEnv (TraceT IO) a
-> ReaderT AppEnv (TraceT IO) a
forall a.
SpanId
-> Text
-> ReaderT AppEnv (TraceT IO) a
-> ReaderT AppEnv (TraceT IO) a
forall (m :: * -> *) a.
MonadTrace m =>
SpanId -> Text -> m a -> m a
newSpanWith SpanId
i Text
n ReaderT AppEnv (TraceT IO) a
a
  currentContext :: AppM (Maybe TraceContext)
currentContext = ReaderT AppEnv (TraceT IO) (Maybe TraceContext)
-> AppM (Maybe TraceContext)
forall a. ReaderT AppEnv (TraceT IO) a -> AppM a
AppM ReaderT AppEnv (TraceT IO) (Maybe TraceContext)
forall (m :: * -> *). MonadTrace m => m (Maybe TraceContext)
currentContext
  attachMetadata :: TraceMetadata -> AppM ()
attachMetadata = ReaderT AppEnv (TraceT IO) () -> AppM ()
forall a. ReaderT AppEnv (TraceT IO) a -> AppM a
AppM (ReaderT AppEnv (TraceT IO) () -> AppM ())
-> (TraceMetadata -> ReaderT AppEnv (TraceT IO) ())
-> TraceMetadata
-> AppM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceMetadata -> ReaderT AppEnv (TraceT IO) ()
forall (m :: * -> *). MonadTrace m => TraceMetadata -> m ()
attachMetadata

instance ProvidesNetwork AppM where
  askHTTPManager :: AppM Manager
askHTTPManager = (AppEnv -> Manager) -> AppM Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> Manager
appEnvManager

instance HasResourceLimits AppM where
  askHTTPHandlerLimit :: AppM ResourceLimits
askHTTPHandlerLimit = ResourceLimits -> AppM ResourceLimits
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResourceLimits -> AppM ResourceLimits)
-> ResourceLimits -> AppM ResourceLimits
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) a.
 (MonadBaseControl IO m, MonadError QErr m) =>
 m a -> m a)
-> ResourceLimits
ResourceLimits m a -> m a
forall a. a -> a
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadError QErr m) =>
m a -> m a
id
  askGraphqlOperationLimit :: RequestId -> UserInfo -> ApiLimit -> AppM ResourceLimits
askGraphqlOperationLimit RequestId
_ UserInfo
_ ApiLimit
_ = ResourceLimits -> AppM ResourceLimits
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResourceLimits -> AppM ResourceLimits)
-> ResourceLimits -> AppM ResourceLimits
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) a.
 (MonadBaseControl IO m, MonadError QErr m) =>
 m a -> m a)
-> ResourceLimits
ResourceLimits m a -> m a
forall a. a -> a
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadError QErr m) =>
m a -> m a
id

instance HttpLog AppM where
  type ExtraHttpLogMetadata AppM = ()

  emptyExtraHttpLogMetadata :: ExtraHttpLogMetadata AppM
emptyExtraHttpLogMetadata = ()

  buildExtraHttpLogMetadata :: ParameterizedQueryHashList
-> ExtraUserInfo -> ExtraHttpLogMetadata AppM
buildExtraHttpLogMetadata ParameterizedQueryHashList
_ ExtraUserInfo
_ = ()

  logHttpError :: Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> QErr
-> [Header]
-> HttpLogMetadata AppM
-> AppM ()
logHttpError Logger Hasura
logger LoggingSettings
loggingSettings Maybe UserInfo
userInfoM RequestId
reqId Request
waiReq (ByteString, Maybe Value)
req QErr
qErr [Header]
headers HttpLogMetadata AppM
_ =
    Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger
      (HttpLogLine -> AppM ()) -> HttpLogLine -> AppM ()
forall a b. (a -> b) -> a -> b
$ HttpLogContext -> HttpLogLine
mkHttpLog
      (HttpLogContext -> HttpLogLine) -> HttpLogContext -> HttpLogLine
forall a b. (a -> b) -> a -> b
$ Maybe UserInfo
-> LoggingSettings
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> QErr
-> Maybe (DiffTime, DiffTime)
-> Maybe CompressionType
-> [Header]
-> HttpLogContext
mkHttpErrorLogContext Maybe UserInfo
userInfoM LoggingSettings
loggingSettings RequestId
reqId Request
waiReq (ByteString, Maybe Value)
req QErr
qErr Maybe (DiffTime, DiffTime)
forall a. Maybe a
Nothing Maybe CompressionType
forall a. Maybe a
Nothing [Header]
headers

  logHttpSuccess :: Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> ByteString
-> ByteString
-> Maybe (DiffTime, DiffTime)
-> Maybe CompressionType
-> [Header]
-> HttpLogMetadata AppM
-> AppM ()
logHttpSuccess Logger Hasura
logger LoggingSettings
loggingSettings Maybe UserInfo
userInfoM RequestId
reqId Request
waiReq (ByteString, Maybe Value)
reqBody ByteString
response ByteString
compressedResponse Maybe (DiffTime, DiffTime)
qTime Maybe CompressionType
cType [Header]
headers (CommonHttpLogMetadata RequestMode
rb Maybe (GQLBatchedReqs GQLBatchQueryOperationLog)
batchQueryOpLogs, ()) =
    Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger
      (HttpLogLine -> AppM ()) -> HttpLogLine -> AppM ()
forall a b. (a -> b) -> a -> b
$ HttpLogContext -> HttpLogLine
mkHttpLog
      (HttpLogContext -> HttpLogLine) -> HttpLogContext -> HttpLogLine
forall a b. (a -> b) -> a -> b
$ Maybe UserInfo
-> LoggingSettings
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Int64
-> ByteString
-> Maybe (DiffTime, DiffTime)
-> Maybe CompressionType
-> [Header]
-> RequestMode
-> Maybe (GQLBatchedReqs GQLBatchQueryOperationLog)
-> HttpLogContext
mkHttpAccessLogContext Maybe UserInfo
userInfoM LoggingSettings
loggingSettings RequestId
reqId Request
waiReq (ByteString, Maybe Value)
reqBody (ByteString -> Int64
BL.length ByteString
response) ByteString
compressedResponse Maybe (DiffTime, DiffTime)
qTime Maybe CompressionType
cType [Header]
headers RequestMode
rb Maybe (GQLBatchedReqs GQLBatchQueryOperationLog)
batchQueryOpLogs

instance MonadExecuteQuery AppM where
  cacheLookup :: ExecutionPlan
-> [QueryRootField UnpreparedValue]
-> Maybe CachedDirective
-> GQLReqParsed
-> UserInfo
-> [Header]
-> AppM (Either QErr ([Header], CacheResult))
cacheLookup ExecutionPlan
_ [QueryRootField UnpreparedValue]
_ Maybe CachedDirective
_ GQLReqParsed
_ UserInfo
_ [Header]
_ = Either QErr ([Header], CacheResult)
-> AppM (Either QErr ([Header], CacheResult))
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either QErr ([Header], CacheResult)
 -> AppM (Either QErr ([Header], CacheResult)))
-> Either QErr ([Header], CacheResult)
-> AppM (Either QErr ([Header], CacheResult))
forall a b. (a -> b) -> a -> b
$ ([Header], CacheResult) -> Either QErr ([Header], CacheResult)
forall a b. b -> Either a b
Right ([], Maybe ResponseCacher -> CacheResult
ResponseUncached Maybe ResponseCacher
forall a. Maybe a
Nothing)

instance UserAuthentication AppM where
  resolveUserInfo :: Logger Hasura
-> Manager
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> AppM
     (Either QErr (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo))
resolveUserInfo Logger Hasura
logger Manager
manager [Header]
headers AuthMode
authMode Maybe ReqsText
reqs =
    ExceptT
  QErr AppM (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo)
-> AppM
     (Either QErr (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   QErr AppM (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo)
 -> AppM
      (Either QErr (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo)))
-> ExceptT
     QErr AppM (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo)
-> AppM
     (Either QErr (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo))
forall a b. (a -> b) -> a -> b
$ do
      (UserInfo
a, Maybe UTCTime
b, [Header]
c) <- Logger Hasura
-> Manager
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> ExceptT QErr AppM (UserInfo, Maybe UTCTime, [Header])
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m) =>
Logger Hasura
-> Manager
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
getUserInfoWithExpTime Logger Hasura
logger Manager
manager [Header]
headers AuthMode
authMode Maybe ReqsText
reqs
      (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo)
-> ExceptT
     QErr AppM (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo)
forall a. a -> ExceptT QErr AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UserInfo, Maybe UTCTime, [Header], ExtraUserInfo)
 -> ExceptT
      QErr AppM (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo))
-> (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo)
-> ExceptT
     QErr AppM (UserInfo, Maybe UTCTime, [Header], ExtraUserInfo)
forall a b. (a -> b) -> a -> b
$ (UserInfo
a, Maybe UTCTime
b, [Header]
c, Maybe Text -> ExtraUserInfo
ExtraUserInfo Maybe Text
forall a. Maybe a
Nothing)

instance MonadMetadataApiAuthorization AppM where
  authorizeV1QueryApi :: RQLQuery -> HandlerCtx -> AppM (Either QErr ())
authorizeV1QueryApi RQLQuery
query HandlerCtx
handlerCtx = ExceptT QErr AppM () -> AppM (Either QErr ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
    let currRole :: RoleName
currRole = UserInfo -> RoleName
_uiRole (UserInfo -> RoleName) -> UserInfo -> RoleName
forall a b. (a -> b) -> a -> b
$ HandlerCtx -> UserInfo
hcUser HandlerCtx
handlerCtx
    Bool -> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RQLQuery -> Bool
requiresAdmin RQLQuery
query Bool -> Bool -> Bool
&& RoleName
currRole RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
/= RoleName
adminRoleName)
      (ExceptT QErr AppM () -> ExceptT QErr AppM ())
-> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK Text
"args"
      (ExceptT QErr AppM () -> ExceptT QErr AppM ())
-> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> ExceptT QErr AppM ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
AccessDenied Text
accessDeniedErrMsg

  authorizeV1MetadataApi :: RQLMetadata -> HandlerCtx -> AppM (Either QErr ())
authorizeV1MetadataApi RQLMetadata
_ HandlerCtx
handlerCtx = ExceptT QErr AppM () -> AppM (Either QErr ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
    let currRole :: RoleName
currRole = UserInfo -> RoleName
_uiRole (UserInfo -> RoleName) -> UserInfo -> RoleName
forall a b. (a -> b) -> a -> b
$ HandlerCtx -> UserInfo
hcUser HandlerCtx
handlerCtx
    Bool -> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RoleName
currRole RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
/= RoleName
adminRoleName)
      (ExceptT QErr AppM () -> ExceptT QErr AppM ())
-> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK Text
"args"
      (ExceptT QErr AppM () -> ExceptT QErr AppM ())
-> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> ExceptT QErr AppM ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
AccessDenied Text
accessDeniedErrMsg

  authorizeV2QueryApi :: RQLQuery -> HandlerCtx -> AppM (Either QErr ())
authorizeV2QueryApi RQLQuery
_ HandlerCtx
handlerCtx = ExceptT QErr AppM () -> AppM (Either QErr ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
    let currRole :: RoleName
currRole = UserInfo -> RoleName
_uiRole (UserInfo -> RoleName) -> UserInfo -> RoleName
forall a b. (a -> b) -> a -> b
$ HandlerCtx -> UserInfo
hcUser HandlerCtx
handlerCtx
    Bool -> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RoleName
currRole RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
/= RoleName
adminRoleName)
      (ExceptT QErr AppM () -> ExceptT QErr AppM ())
-> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK Text
"args"
      (ExceptT QErr AppM () -> ExceptT QErr AppM ())
-> ExceptT QErr AppM () -> ExceptT QErr AppM ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> ExceptT QErr AppM ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
AccessDenied Text
accessDeniedErrMsg

instance ConsoleRenderer AppM where
  type ConsoleType AppM = CEConsoleType
  renderConsole :: Text
-> AuthMode
-> TelemetryStatus
-> Maybe Text
-> Maybe Text
-> ConsoleType AppM
-> AppM (Either String Text)
renderConsole Text
path AuthMode
authMode TelemetryStatus
enableTelemetry Maybe Text
consoleAssetsDir Maybe Text
consoleSentryDsn ConsoleType AppM
consoleType =
    Either String Text -> AppM (Either String Text)
forall a. a -> AppM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Text -> AppM (Either String Text))
-> Either String Text -> AppM (Either String Text)
forall a b. (a -> b) -> a -> b
$ Text
-> AuthMode
-> TelemetryStatus
-> Maybe Text
-> Maybe Text
-> CEConsoleType
-> Either String Text
mkConsoleHTML Text
path AuthMode
authMode TelemetryStatus
enableTelemetry Maybe Text
consoleAssetsDir Maybe Text
consoleSentryDsn CEConsoleType
ConsoleType AppM
consoleType

instance MonadVersionAPIWithExtraData AppM where
  -- we always default to CE as the `server_type` in this codebase
  getExtraDataForVersionAPI :: AppM [Pair]
getExtraDataForVersionAPI = [Pair] -> AppM [Pair]
forall a. a -> AppM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Key
"server_type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= (Text
"ce" :: Text)]

instance MonadGQLExecutionCheck AppM where
  checkGQLExecution :: UserInfo
-> ([Header], IpAddress)
-> AllowListStatus
-> SchemaCache
-> GQLReqUnparsed
-> RequestId
-> AppM (Either QErr GQLReqParsed)
checkGQLExecution UserInfo
userInfo ([Header], IpAddress)
_ AllowListStatus
enableAL SchemaCache
sc GQLReqUnparsed
query RequestId
_ = ExceptT QErr AppM GQLReqParsed -> AppM (Either QErr GQLReqParsed)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr AppM GQLReqParsed -> AppM (Either QErr GQLReqParsed))
-> ExceptT QErr AppM GQLReqParsed
-> AppM (Either QErr GQLReqParsed)
forall a b. (a -> b) -> a -> b
$ do
    GQLReqParsed
req <- GQLReqUnparsed -> ExceptT QErr AppM GQLReqParsed
forall (m :: * -> *).
MonadError QErr m =>
GQLReqUnparsed -> m GQLReqParsed
toParsed GQLReqUnparsed
query
    AllowListStatus
-> AllowlistMode
-> UserInfo
-> GQLReqParsed
-> SchemaCache
-> ExceptT QErr AppM ()
forall (m :: * -> *).
MonadError QErr m =>
AllowListStatus
-> AllowlistMode -> UserInfo -> GQLReqParsed -> SchemaCache -> m ()
checkQueryInAllowlist AllowListStatus
enableAL AllowlistMode
AllowlistModeGlobalOnly UserInfo
userInfo GQLReqParsed
req SchemaCache
sc
    GQLReqParsed -> ExceptT QErr AppM GQLReqParsed
forall a. a -> ExceptT QErr AppM a
forall (m :: * -> *) a. Monad m => a -> m a
return GQLReqParsed
req

  executeIntrospection :: UserInfo
-> Value
-> SetGraphqlIntrospectionOptions
-> AppM (Either QErr ExecutionStep)
executeIntrospection UserInfo
_ Value
introspectionQuery SetGraphqlIntrospectionOptions
_ =
    Either QErr ExecutionStep -> AppM (Either QErr ExecutionStep)
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either QErr ExecutionStep -> AppM (Either QErr ExecutionStep))
-> Either QErr ExecutionStep -> AppM (Either QErr ExecutionStep)
forall a b. (a -> b) -> a -> b
$ ExecutionStep -> Either QErr ExecutionStep
forall a b. b -> Either a b
Right (ExecutionStep -> Either QErr ExecutionStep)
-> ExecutionStep -> Either QErr ExecutionStep
forall a b. (a -> b) -> a -> b
$ Value -> ExecutionStep
ExecStepRaw Value
introspectionQuery

  checkGQLBatchedReqs :: UserInfo
-> RequestId
-> [GQLReqUnparsed]
-> SchemaCache
-> AppM (Either QErr ())
checkGQLBatchedReqs UserInfo
_ RequestId
_ [GQLReqUnparsed]
_ SchemaCache
_ = ExceptT QErr AppM () -> AppM (Either QErr ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr AppM () -> AppM (Either QErr ()))
-> ExceptT QErr AppM () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ () -> ExceptT QErr AppM ()
forall a. a -> ExceptT QErr AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance MonadConfigApiHandler AppM where
  runConfigApiHandler :: forall impl. AppStateRef impl -> SpockCtxT () AppM ()
runConfigApiHandler = AppStateRef impl -> SpockCtxT () AppM ()
forall (m :: * -> *) impl.
(MonadIO m, MonadBaseControl IO m, HasAppEnv m,
 UserAuthentication m, HttpLog m, HasResourceLimits m,
 MonadTrace m) =>
AppStateRef impl -> SpockCtxT () m ()
configApiGetHandler

instance MonadQueryLog AppM where
  logQueryLog :: Logger Hasura -> QueryLog -> AppM ()
logQueryLog Logger Hasura
logger = Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger

instance MonadExecutionLog AppM where
  logExecutionLog :: Logger Hasura -> ExecutionLog -> AppM ()
logExecutionLog Logger Hasura
logger = Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger

instance WS.MonadWSLog AppM where
  logWSLog :: Logger Hasura -> WSLog -> AppM ()
logWSLog Logger Hasura
logger = Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger

instance MonadResolveSource AppM where
  getPGSourceResolver :: AppM (SourceResolver ('Postgres 'Vanilla))
getPGSourceResolver = (AppEnv
 -> Environment
 -> SourceName
 -> PostgresConnConfiguration
 -> IO (Either QErr PGSourceConfig))
-> AppM
     (Environment
      -> SourceName
      -> PostgresConnConfiguration
      -> IO (Either QErr PGSourceConfig))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PGLogger -> SourceResolver ('Postgres 'Vanilla)
PGLogger
-> Environment
-> SourceName
-> PostgresConnConfiguration
-> IO (Either QErr PGSourceConfig)
mkPgSourceResolver (PGLogger
 -> Environment
 -> SourceName
 -> PostgresConnConfiguration
 -> IO (Either QErr PGSourceConfig))
-> (AppEnv -> PGLogger)
-> AppEnv
-> Environment
-> SourceName
-> PostgresConnConfiguration
-> IO (Either QErr PGSourceConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loggers -> PGLogger
_lsPgLogger (Loggers -> PGLogger) -> (AppEnv -> Loggers) -> AppEnv -> PGLogger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppEnv -> Loggers
appEnvLoggers)
  getMSSQLSourceResolver :: AppM (SourceResolver 'MSSQL)
getMSSQLSourceResolver = (Environment
 -> SourceName
 -> MSSQLConnConfiguration
 -> IO (Either QErr MSSQLSourceConfig))
-> AppM
     (Environment
      -> SourceName
      -> MSSQLConnConfiguration
      -> IO (Either QErr MSSQLSourceConfig))
forall a. a -> AppM a
forall (m :: * -> *) a. Monad m => a -> m a
return Environment
-> SourceName
-> MSSQLConnConfiguration
-> IO (Either QErr MSSQLSourceConfig)
SourceResolver 'MSSQL
mkMSSQLSourceResolver

instance MonadQueryTags AppM where
  createQueryTags :: QueryTagsAttributes
-> Maybe QueryTagsConfig -> Tagged AppM QueryTagsComment
createQueryTags QueryTagsAttributes
_attributes Maybe QueryTagsConfig
_qtSourceConfig = QueryTagsComment -> Tagged AppM QueryTagsComment
forall a. a -> Tagged AppM a
forall (m :: * -> *) a. Monad m => a -> m a
return (QueryTagsComment -> Tagged AppM QueryTagsComment)
-> QueryTagsComment -> Tagged AppM QueryTagsComment
forall a b. (a -> b) -> a -> b
$ QueryTagsComment
emptyQueryTagsComment

instance MonadEventLogCleanup AppM where
  runLogCleaner :: SourceCache
-> TriggerLogCleanupConfig -> AppM (Either QErr EncJSON)
runLogCleaner SourceCache
_ TriggerLogCleanupConfig
_ = Either QErr EncJSON -> AppM (Either QErr EncJSON)
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either QErr EncJSON -> AppM (Either QErr EncJSON))
-> Either QErr EncJSON -> AppM (Either QErr EncJSON)
forall a b. (a -> b) -> a -> b
$ Code -> Text -> Either QErr EncJSON
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
NotSupported Text
"Event log cleanup feature is enterprise edition only"
  generateCleanupSchedules :: AnyBackend SourceInfo
-> TriggerName
-> AutoTriggerLogCleanupConfig
-> AppM (Either QErr ())
generateCleanupSchedules AnyBackend SourceInfo
_ TriggerName
_ AutoTriggerLogCleanupConfig
_ = Either QErr () -> AppM (Either QErr ())
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either QErr () -> AppM (Either QErr ()))
-> Either QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ () -> Either QErr ()
forall a b. b -> Either a b
Right ()
  updateTriggerCleanupSchedules :: Logger Hasura
-> InsOrdHashMap SourceName BackendSourceMetadata
-> InsOrdHashMap SourceName BackendSourceMetadata
-> SchemaCache
-> AppM (Either QErr ())
updateTriggerCleanupSchedules Logger Hasura
_ InsOrdHashMap SourceName BackendSourceMetadata
_ InsOrdHashMap SourceName BackendSourceMetadata
_ SchemaCache
_ = Either QErr () -> AppM (Either QErr ())
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either QErr () -> AppM (Either QErr ()))
-> Either QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ () -> Either QErr ()
forall a b. b -> Either a b
Right ()

instance MonadGetPolicies AppM where
  runGetApiTimeLimit :: AppM (Maybe MaxTime)
runGetApiTimeLimit = Maybe MaxTime -> AppM (Maybe MaxTime)
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe MaxTime -> AppM (Maybe MaxTime))
-> Maybe MaxTime -> AppM (Maybe MaxTime)
forall a b. (a -> b) -> a -> b
$ Maybe MaxTime
forall a. Maybe a
Nothing
  runGetPrometheusMetricsGranularity :: AppM (IO GranularPrometheusMetricsState)
runGetPrometheusMetricsGranularity = IO GranularPrometheusMetricsState
-> AppM (IO GranularPrometheusMetricsState)
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GranularPrometheusMetricsState -> IO GranularPrometheusMetricsState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GranularPrometheusMetricsState
GranularMetricsOff)

-- | Each of the function in the type class is executed in a totally separate transaction.
instance MonadMetadataStorage AppM where
  fetchMetadataResourceVersion :: AppM (Either QErr MetadataResourceVersion)
fetchMetadataResourceVersion = TxE QErr MetadataResourceVersion
-> AppM (Either QErr MetadataResourceVersion)
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx TxE QErr MetadataResourceVersion
fetchMetadataResourceVersionFromCatalog
  fetchMetadata :: AppM (Either QErr MetadataWithResourceVersion)
fetchMetadata = TxE QErr MetadataWithResourceVersion
-> AppM (Either QErr MetadataWithResourceVersion)
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx TxE QErr MetadataWithResourceVersion
fetchMetadataAndResourceVersionFromCatalog
  fetchMetadataNotifications :: MetadataResourceVersion
-> InstanceId
-> AppM
     (Either QErr [(MetadataResourceVersion, CacheInvalidations)])
fetchMetadataNotifications MetadataResourceVersion
a InstanceId
b = TxE QErr [(MetadataResourceVersion, CacheInvalidations)]
-> AppM
     (Either QErr [(MetadataResourceVersion, CacheInvalidations)])
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr [(MetadataResourceVersion, CacheInvalidations)]
 -> AppM
      (Either QErr [(MetadataResourceVersion, CacheInvalidations)]))
-> TxE QErr [(MetadataResourceVersion, CacheInvalidations)]
-> AppM
     (Either QErr [(MetadataResourceVersion, CacheInvalidations)])
forall a b. (a -> b) -> a -> b
$ MetadataResourceVersion
-> InstanceId
-> TxE QErr [(MetadataResourceVersion, CacheInvalidations)]
fetchMetadataNotificationsFromCatalog MetadataResourceVersion
a InstanceId
b
  setMetadata :: MetadataResourceVersion
-> Metadata -> AppM (Either QErr MetadataResourceVersion)
setMetadata MetadataResourceVersion
r = TxE QErr MetadataResourceVersion
-> AppM (Either QErr MetadataResourceVersion)
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr MetadataResourceVersion
 -> AppM (Either QErr MetadataResourceVersion))
-> (Metadata -> TxE QErr MetadataResourceVersion)
-> Metadata
-> AppM (Either QErr MetadataResourceVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetadataResourceVersion
-> Metadata -> TxE QErr MetadataResourceVersion
setMetadataInCatalog MetadataResourceVersion
r
  notifySchemaCacheSync :: MetadataResourceVersion
-> InstanceId -> CacheInvalidations -> AppM (Either QErr ())
notifySchemaCacheSync MetadataResourceVersion
a InstanceId
b CacheInvalidations
c = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> TxE QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ MetadataResourceVersion
-> InstanceId -> CacheInvalidations -> TxE QErr ()
notifySchemaCacheSyncTx MetadataResourceVersion
a InstanceId
b CacheInvalidations
c
  getCatalogState :: AppM (Either QErr CatalogState)
getCatalogState = TxE QErr CatalogState -> AppM (Either QErr CatalogState)
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx TxE QErr CatalogState
getCatalogStateTx
  setCatalogState :: CatalogStateType -> Value -> AppM (Either QErr ())
setCatalogState CatalogStateType
a Value
b = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> TxE QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ CatalogStateType -> Value -> TxE QErr ()
setCatalogStateTx CatalogStateType
a Value
b

  -- stored source introspection is not available in this distribution
  fetchSourceIntrospection :: MetadataResourceVersion
-> AppM (Either QErr (Maybe StoredIntrospection))
fetchSourceIntrospection MetadataResourceVersion
_ = Either QErr (Maybe StoredIntrospection)
-> AppM (Either QErr (Maybe StoredIntrospection))
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either QErr (Maybe StoredIntrospection)
 -> AppM (Either QErr (Maybe StoredIntrospection)))
-> Either QErr (Maybe StoredIntrospection)
-> AppM (Either QErr (Maybe StoredIntrospection))
forall a b. (a -> b) -> a -> b
$ Maybe StoredIntrospection
-> Either QErr (Maybe StoredIntrospection)
forall a b. b -> Either a b
Right Maybe StoredIntrospection
forall a. Maybe a
Nothing
  storeSourceIntrospection :: StoredIntrospection
-> MetadataResourceVersion -> AppM (Either QErr ())
storeSourceIntrospection StoredIntrospection
_ MetadataResourceVersion
_ = Either QErr () -> AppM (Either QErr ())
forall a. a -> AppM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either QErr () -> AppM (Either QErr ()))
-> Either QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ () -> Either QErr ()
forall a b. b -> Either a b
Right ()

  getMetadataDbUid :: AppM (Either QErr MetadataDbId)
getMetadataDbUid = TxE QErr MetadataDbId -> AppM (Either QErr MetadataDbId)
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx TxE QErr MetadataDbId
getDbId
  checkMetadataStorageHealth :: AppM (Either QErr ())
checkMetadataStorageHealth = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> TxE QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ TxE QErr ()
forall (m :: * -> *). MonadTx m => m ()
checkDbConnection

  getDeprivedCronTriggerStats :: [TriggerName] -> AppM (Either QErr [CronTriggerStats])
getDeprivedCronTriggerStats = TxE QErr [CronTriggerStats]
-> AppM (Either QErr [CronTriggerStats])
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr [CronTriggerStats]
 -> AppM (Either QErr [CronTriggerStats]))
-> ([TriggerName] -> TxE QErr [CronTriggerStats])
-> [TriggerName]
-> AppM (Either QErr [CronTriggerStats])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TriggerName] -> TxE QErr [CronTriggerStats]
getDeprivedCronTriggerStatsTx
  getScheduledEventsForDelivery :: [TriggerName]
-> AppM (Either QErr ([CronEvent], [OneOffScheduledEvent]))
getScheduledEventsForDelivery = TxE QErr ([CronEvent], [OneOffScheduledEvent])
-> AppM (Either QErr ([CronEvent], [OneOffScheduledEvent]))
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr ([CronEvent], [OneOffScheduledEvent])
 -> AppM (Either QErr ([CronEvent], [OneOffScheduledEvent])))
-> ([TriggerName]
    -> TxE QErr ([CronEvent], [OneOffScheduledEvent]))
-> [TriggerName]
-> AppM (Either QErr ([CronEvent], [OneOffScheduledEvent]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TriggerName] -> TxE QErr ([CronEvent], [OneOffScheduledEvent])
getScheduledEventsForDeliveryTx
  insertCronEvents :: [CronEventSeed] -> AppM (Either QErr ())
insertCronEvents = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> ([CronEventSeed] -> TxE QErr ())
-> [CronEventSeed]
-> AppM (Either QErr ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CronEventSeed] -> TxE QErr ()
insertCronEventsTx
  insertOneOffScheduledEvent :: OneOffEvent -> AppM (Either QErr CronEventId)
insertOneOffScheduledEvent = TxE QErr CronEventId -> AppM (Either QErr CronEventId)
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr CronEventId -> AppM (Either QErr CronEventId))
-> (OneOffEvent -> TxE QErr CronEventId)
-> OneOffEvent
-> AppM (Either QErr CronEventId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneOffEvent -> TxE QErr CronEventId
insertOneOffScheduledEventTx
  insertScheduledEventInvocation :: Invocation 'ScheduledType
-> ScheduledEventType -> AppM (Either QErr ())
insertScheduledEventInvocation Invocation 'ScheduledType
a ScheduledEventType
b = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> TxE QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ Invocation 'ScheduledType -> ScheduledEventType -> TxE QErr ()
insertInvocationTx Invocation 'ScheduledType
a ScheduledEventType
b
  setScheduledEventOp :: CronEventId
-> ScheduledEventOp -> ScheduledEventType -> AppM (Either QErr ())
setScheduledEventOp CronEventId
a ScheduledEventOp
b ScheduledEventType
c = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> TxE QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ CronEventId
-> ScheduledEventOp -> ScheduledEventType -> TxE QErr ()
setScheduledEventOpTx CronEventId
a ScheduledEventOp
b ScheduledEventType
c
  unlockScheduledEvents :: ScheduledEventType -> [CronEventId] -> AppM (Either QErr Int)
unlockScheduledEvents ScheduledEventType
a [CronEventId]
b = TxE QErr Int -> AppM (Either QErr Int)
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr Int -> AppM (Either QErr Int))
-> TxE QErr Int -> AppM (Either QErr Int)
forall a b. (a -> b) -> a -> b
$ ScheduledEventType -> [CronEventId] -> TxE QErr Int
unlockScheduledEventsTx ScheduledEventType
a [CronEventId]
b
  unlockAllLockedScheduledEvents :: AppM (Either QErr ())
unlockAllLockedScheduledEvents = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx TxE QErr ()
unlockAllLockedScheduledEventsTx
  clearFutureCronEvents :: ClearCronEvents -> AppM (Either QErr ())
clearFutureCronEvents = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> (ClearCronEvents -> TxE QErr ())
-> ClearCronEvents
-> AppM (Either QErr ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClearCronEvents -> TxE QErr ()
dropFutureCronEventsTx
  getOneOffScheduledEvents :: ScheduledEventPagination
-> [ScheduledEventStatus]
-> RowsCountOption
-> AppM
     (Either QErr (WithOptionalTotalCount [OneOffScheduledEvent]))
getOneOffScheduledEvents ScheduledEventPagination
a [ScheduledEventStatus]
b RowsCountOption
c = TxE QErr (WithOptionalTotalCount [OneOffScheduledEvent])
-> AppM
     (Either QErr (WithOptionalTotalCount [OneOffScheduledEvent]))
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr (WithOptionalTotalCount [OneOffScheduledEvent])
 -> AppM
      (Either QErr (WithOptionalTotalCount [OneOffScheduledEvent])))
-> TxE QErr (WithOptionalTotalCount [OneOffScheduledEvent])
-> AppM
     (Either QErr (WithOptionalTotalCount [OneOffScheduledEvent]))
forall a b. (a -> b) -> a -> b
$ ScheduledEventPagination
-> [ScheduledEventStatus]
-> RowsCountOption
-> TxE QErr (WithOptionalTotalCount [OneOffScheduledEvent])
getOneOffScheduledEventsTx ScheduledEventPagination
a [ScheduledEventStatus]
b RowsCountOption
c
  getCronEvents :: TriggerName
-> ScheduledEventPagination
-> [ScheduledEventStatus]
-> RowsCountOption
-> AppM (Either QErr (WithOptionalTotalCount [CronEvent]))
getCronEvents TriggerName
a ScheduledEventPagination
b [ScheduledEventStatus]
c RowsCountOption
d = TxE QErr (WithOptionalTotalCount [CronEvent])
-> AppM (Either QErr (WithOptionalTotalCount [CronEvent]))
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr (WithOptionalTotalCount [CronEvent])
 -> AppM (Either QErr (WithOptionalTotalCount [CronEvent])))
-> TxE QErr (WithOptionalTotalCount [CronEvent])
-> AppM (Either QErr (WithOptionalTotalCount [CronEvent]))
forall a b. (a -> b) -> a -> b
$ TriggerName
-> ScheduledEventPagination
-> [ScheduledEventStatus]
-> RowsCountOption
-> TxE QErr (WithOptionalTotalCount [CronEvent])
getCronEventsTx TriggerName
a ScheduledEventPagination
b [ScheduledEventStatus]
c RowsCountOption
d
  getScheduledEventInvocations :: GetScheduledEventInvocations
-> AppM
     (Either QErr (WithOptionalTotalCount [ScheduledEventInvocation]))
getScheduledEventInvocations GetScheduledEventInvocations
a = TxE QErr (WithOptionalTotalCount [ScheduledEventInvocation])
-> AppM
     (Either QErr (WithOptionalTotalCount [ScheduledEventInvocation]))
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr (WithOptionalTotalCount [ScheduledEventInvocation])
 -> AppM
      (Either QErr (WithOptionalTotalCount [ScheduledEventInvocation])))
-> TxE QErr (WithOptionalTotalCount [ScheduledEventInvocation])
-> AppM
     (Either QErr (WithOptionalTotalCount [ScheduledEventInvocation]))
forall a b. (a -> b) -> a -> b
$ GetScheduledEventInvocations
-> TxE QErr (WithOptionalTotalCount [ScheduledEventInvocation])
getScheduledEventInvocationsTx GetScheduledEventInvocations
a
  deleteScheduledEvent :: CronEventId -> ScheduledEventType -> AppM (Either QErr ())
deleteScheduledEvent CronEventId
a ScheduledEventType
b = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> TxE QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ CronEventId -> ScheduledEventType -> TxE QErr ()
deleteScheduledEventTx CronEventId
a ScheduledEventType
b

  insertAction :: ActionName
-> SessionVariables
-> [Header]
-> Value
-> AppM (Either QErr ActionId)
insertAction ActionName
a SessionVariables
b [Header]
c Value
d = TxE QErr ActionId -> AppM (Either QErr ActionId)
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr ActionId -> AppM (Either QErr ActionId))
-> TxE QErr ActionId -> AppM (Either QErr ActionId)
forall a b. (a -> b) -> a -> b
$ ActionName
-> SessionVariables -> [Header] -> Value -> TxE QErr ActionId
insertActionTx ActionName
a SessionVariables
b [Header]
c Value
d
  fetchUndeliveredActionEvents :: AppM (Either QErr [ActionLogItem])
fetchUndeliveredActionEvents = TxE QErr [ActionLogItem] -> AppM (Either QErr [ActionLogItem])
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx TxE QErr [ActionLogItem]
fetchUndeliveredActionEventsTx
  setActionStatus :: ActionId -> AsyncActionStatus -> AppM (Either QErr ())
setActionStatus ActionId
a AsyncActionStatus
b = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> TxE QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ ActionId -> AsyncActionStatus -> TxE QErr ()
setActionStatusTx ActionId
a AsyncActionStatus
b
  fetchActionResponse :: ActionId -> AppM (Either QErr ActionLogResponse)
fetchActionResponse = TxE QErr ActionLogResponse -> AppM (Either QErr ActionLogResponse)
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr ActionLogResponse
 -> AppM (Either QErr ActionLogResponse))
-> (ActionId -> TxE QErr ActionLogResponse)
-> ActionId
-> AppM (Either QErr ActionLogResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionId -> TxE QErr ActionLogResponse
fetchActionResponseTx
  clearActionData :: ActionName -> AppM (Either QErr ())
clearActionData = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> (ActionName -> TxE QErr ())
-> ActionName
-> AppM (Either QErr ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionName -> TxE QErr ()
clearActionDataTx
  setProcessingActionLogsToPending :: LockedActionIdArray -> AppM (Either QErr ())
setProcessingActionLogsToPending = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> (LockedActionIdArray -> TxE QErr ())
-> LockedActionIdArray
-> AppM (Either QErr ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LockedActionIdArray -> TxE QErr ()
setProcessingActionLogsToPendingTx

instance MonadEECredentialsStorage AppM where
  getEEClientCredentials :: AppM (Either QErr (Maybe EEClientCredentials))
getEEClientCredentials = TxE QErr (Maybe EEClientCredentials)
-> AppM (Either QErr (Maybe EEClientCredentials))
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx TxE QErr (Maybe EEClientCredentials)
getEEClientCredentialsTx
  setEEClientCredentials :: EEClientCredentials -> AppM (Either QErr ())
setEEClientCredentials EEClientCredentials
a = TxE QErr () -> AppM (Either QErr ())
forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx (TxE QErr () -> AppM (Either QErr ()))
-> TxE QErr () -> AppM (Either QErr ())
forall a b. (a -> b) -> a -> b
$ EEClientCredentials -> TxE QErr ()
setEEClientCredentialsTx EEClientCredentials
a

--------------------------------------------------------------------------------
-- misc

-- TODO(SOLOMON): Move Into `Hasura.Server.Init`. Unable to do so
-- currently due `throwErrExit`.

-- | Parse cli arguments to graphql-engine executable.
parseArgs :: (EnabledLogTypes impl) => Env.Environment -> IO (HGEOptions (ServeOptions impl))
parseArgs :: forall impl.
EnabledLogTypes impl =>
Environment -> IO (HGEOptions (ServeOptions impl))
parseArgs Environment
env = do
  HGEOptionsRaw (ServeOptionsRaw impl)
rawHGEOpts <- ParserInfo (HGEOptionsRaw (ServeOptionsRaw impl))
-> IO (HGEOptionsRaw (ServeOptionsRaw impl))
forall a. ParserInfo a -> IO a
execParser ParserInfo (HGEOptionsRaw (ServeOptionsRaw impl))
opts
  let eitherOpts :: Either String (HGEOptions (ServeOptions impl))
eitherOpts = [(String, String)]
-> WithEnv (HGEOptions (ServeOptions impl))
-> Either String (HGEOptions (ServeOptions impl))
forall a. [(String, String)] -> WithEnv a -> Either String a
runWithEnv (Environment -> [(String, String)]
Env.toList Environment
env) (WithEnv (HGEOptions (ServeOptions impl))
 -> Either String (HGEOptions (ServeOptions impl)))
-> WithEnv (HGEOptions (ServeOptions impl))
-> Either String (HGEOptions (ServeOptions impl))
forall a b. (a -> b) -> a -> b
$ HGEOptionsRaw (ServeOptionsRaw impl)
-> WithEnv (HGEOptions (ServeOptions impl))
forall impl.
EnabledLogTypes impl =>
HGEOptionsRaw (ServeOptionsRaw impl)
-> WithEnv (HGEOptions (ServeOptions impl))
mkHGEOptions HGEOptionsRaw (ServeOptionsRaw impl)
rawHGEOpts
  Either String (HGEOptions (ServeOptions impl))
-> (String -> IO (HGEOptions (ServeOptions impl)))
-> IO (HGEOptions (ServeOptions impl))
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either String (HGEOptions (ServeOptions impl))
eitherOpts ((String -> IO (HGEOptions (ServeOptions impl)))
 -> IO (HGEOptions (ServeOptions impl)))
-> (String -> IO (HGEOptions (ServeOptions impl)))
-> IO (HGEOptions (ServeOptions impl))
forall a b. (a -> b) -> a -> b
$ ExitCode -> String -> IO (HGEOptions (ServeOptions impl))
forall a. ExitCode -> String -> IO a
forall (m :: * -> *) a. MonadIO m => ExitCode -> String -> m a
throwErrExit ExitCode
InvalidEnvironmentVariableOptionsError
  where
    opts :: ParserInfo (HGEOptionsRaw (ServeOptionsRaw impl))
opts =
      Parser (HGEOptionsRaw (ServeOptionsRaw impl))
-> InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
-> ParserInfo (HGEOptionsRaw (ServeOptionsRaw impl))
forall a. Parser a -> InfoMod a -> ParserInfo a
info
        (Parser
  (HGEOptionsRaw (ServeOptionsRaw impl)
   -> HGEOptionsRaw (ServeOptionsRaw impl))
forall a. Parser (a -> a)
helper Parser
  (HGEOptionsRaw (ServeOptionsRaw impl)
   -> HGEOptionsRaw (ServeOptionsRaw impl))
-> Parser (HGEOptionsRaw (ServeOptionsRaw impl))
-> Parser (HGEOptionsRaw (ServeOptionsRaw impl))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (HGEOptionsRaw (ServeOptionsRaw impl))
forall impl.
EnabledLogTypes impl =>
Parser (HGEOptionsRaw (ServeOptionsRaw impl))
parseHgeOpts)
        ( InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
forall a. InfoMod a
fullDesc
            InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
-> InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
-> InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
forall a. String -> InfoMod a
header String
"Hasura GraphQL Engine: Blazing fast, instant realtime GraphQL APIs on your DB with fine grained access control, also trigger webhooks on database events."
            InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
-> InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
-> InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
forall a. Semigroup a => a -> a -> a
<> Maybe Doc -> InfoMod (HGEOptionsRaw (ServeOptionsRaw impl))
forall a. Maybe Doc -> InfoMod a
footerDoc (Doc -> Maybe Doc
forall a. a -> Maybe a
Just Doc
mainCmdFooter)
        )

-- | Core logic to fork a poller thread to update the JWK based on the
-- expiry time specified in @Expires@ header or @Cache-Control@ header
updateJwkCtxThread ::
  (C.ForkableMonadIO m) =>
  IO AppContext ->
  HTTP.Manager ->
  Logger Hasura ->
  m Void
updateJwkCtxThread :: forall (m :: * -> *).
ForkableMonadIO m =>
IO AppContext -> Manager -> Logger Hasura -> m Void
updateJwkCtxThread IO AppContext
getAppCtx Manager
httpManager Logger Hasura
logger = m () -> m Void
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$ do
  AuthMode
authMode <- IO AuthMode -> m AuthMode
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AuthMode -> m AuthMode) -> IO AuthMode -> m AuthMode
forall a b. (a -> b) -> a -> b
$ AppContext -> AuthMode
acAuthMode (AppContext -> AuthMode) -> IO AppContext -> IO AuthMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO AppContext
getAppCtx
  AuthMode -> Manager -> Logger Hasura -> m ()
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
AuthMode -> Manager -> Logger Hasura -> m ()
updateJwkCtx AuthMode
authMode Manager
httpManager Logger Hasura
logger
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
sleep (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ Seconds -> DiffTime
seconds Seconds
1

-- | Event triggers live in the user's DB and other events
--  (cron, one-off and async actions)
--   live in the metadata DB, so we need a way to differentiate the
--   type of shutdown action
data ShutdownAction
  = EventTriggerShutdownAction (IO ())
  | MetadataDBShutdownAction (ExceptT QErr IO ())

-- | This function acts as the entrypoint for the graphql-engine webserver.
--
-- Note: at the exit of this function, or in case of a graceful server shutdown
-- (SIGTERM, or more generally, whenever the shutdown latch is set),  we need to
-- make absolutely sure that we clean up any resources which were allocated during
-- server setup. In the case of a multitenant process, failure to do so can lead to
-- resource leaks.
--
-- To track these resources, we use the ManagedT monad, and attach finalizers at
-- the same point in the code where we allocate resources. If you fork a new
-- long-lived thread, or create a connection pool, or allocate any other
-- long-lived resource, make sure to pair the allocator  with its finalizer.
-- There are plenty of examples throughout the code. For example, see
-- 'C.forkManagedT'.
--
-- Note also: the order in which the finalizers run can be important. Specifically,
-- we want the finalizers for the logger threads to run last, so that we retain as
-- many "thread stopping" log messages as possible. The order in which the
-- finalizers is run is determined by the order in which they are introduced in the
-- code.

{- HLINT ignore runHGEServer "Avoid lambda" -}
{- HLINT ignore runHGEServer "Use withAsync" -}
runHGEServer ::
  forall m impl.
  ( MonadIO m,
    MonadFix m,
    MonadMask m,
    MonadStateless IO m,
    LA.Forall (LA.Pure m),
    UserAuthentication m,
    HttpLog m,
    HasAppEnv m,
    HasCacheStaticConfig m,
    HasFeatureFlagChecker m,
    ConsoleRenderer m,
    MonadVersionAPIWithExtraData m,
    MonadMetadataApiAuthorization m,
    MonadGQLExecutionCheck m,
    MonadConfigApiHandler m,
    MonadQueryLog m,
    MonadExecutionLog m,
    WS.MonadWSLog m,
    MonadExecuteQuery m,
    HasResourceLimits m,
    MonadMetadataStorage m,
    MonadResolveSource m,
    MonadQueryTags m,
    MonadEventLogCleanup m,
    ProvidesHasuraServices m,
    MonadTrace m,
    MonadGetPolicies m
  ) =>
  (AppStateRef impl -> Spock.SpockT m ()) ->
  AppStateRef impl ->
  -- | start time
  UTCTime ->
  -- | A hook which can be called to indicate when the server is started succesfully
  Maybe (IO ()) ->
  ConsoleType m ->
  EKG.Store EKG.EmptyMetrics ->
  ManagedT m ()
runHGEServer :: forall (m :: * -> *) impl.
(MonadIO m, MonadFix m, MonadMask m, MonadStateless IO m,
 Forall (Pure m), UserAuthentication m, HttpLog m, HasAppEnv m,
 HasCacheStaticConfig m, HasFeatureFlagChecker m, ConsoleRenderer m,
 MonadVersionAPIWithExtraData m, MonadMetadataApiAuthorization m,
 MonadGQLExecutionCheck m, MonadConfigApiHandler m, MonadQueryLog m,
 MonadExecutionLog m, MonadWSLog m, MonadExecuteQuery m,
 HasResourceLimits m, MonadMetadataStorage m, MonadResolveSource m,
 MonadQueryTags m, MonadEventLogCleanup m, ProvidesHasuraServices m,
 MonadTrace m, MonadGetPolicies m) =>
(AppStateRef impl -> SpockT m ())
-> AppStateRef impl
-> UTCTime
-> Maybe (IO ())
-> ConsoleType m
-> Store EmptyMetrics
-> ManagedT m ()
runHGEServer AppStateRef impl -> SpockT m ()
setupHook AppStateRef impl
appStateRef UTCTime
initTime Maybe (IO ())
startupStatusHook ConsoleType m
consoleType Store EmptyMetrics
ekgStore = do
  AppEnv {Int
Maybe Text
Maybe PGPool
Maybe (CredentialCache AgentLicenseKey)
SamplingPolicy
HostPreference
Manager
TxIsolation
ConnParams
PGPool
Refined NonNegative Seconds
TMVar MetadataResourceVersion
ConnectionOptions
CheckFeatureFlag
ServerMetrics
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
PrometheusMetrics
ShutdownLatch
LoggingSettings
LockedEventsCtx
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
SubscriptionsState
Loggers
appEnvPort :: AppEnv -> Port
appEnvHost :: AppEnv -> HostPreference
appEnvMetadataDbPool :: AppEnv -> PGPool
appEnvIntrospectionDbPool :: AppEnv -> Maybe PGPool
appEnvManager :: AppEnv -> Manager
appEnvLoggers :: AppEnv -> Loggers
appEnvMetadataVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvInstanceId :: AppEnv -> InstanceId
appEnvEnableMaintenanceMode :: AppEnv -> MaintenanceMode ()
appEnvLoggingSettings :: AppEnv -> LoggingSettings
appEnvEventingMode :: AppEnv -> EventingMode
appEnvEnableReadOnlyMode :: AppEnv -> ReadOnlyMode
appEnvServerMetrics :: AppEnv -> ServerMetrics
appEnvShutdownLatch :: AppEnv -> ShutdownLatch
appEnvMetaVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: AppEnv -> PrometheusMetrics
appEnvTraceSamplingPolicy :: AppEnv -> SamplingPolicy
appEnvSubscriptionState :: AppEnv -> SubscriptionsState
appEnvLockedEventsCtx :: AppEnv -> LockedEventsCtx
appEnvConnParams :: AppEnv -> ConnParams
appEnvTxIso :: AppEnv -> TxIsolation
appEnvConsoleAssetsDir :: AppEnv -> Maybe Text
appEnvConsoleSentryDsn :: AppEnv -> Maybe Text
appEnvConnectionOptions :: AppEnv -> ConnectionOptions
appEnvWebSocketKeepAlive :: AppEnv -> KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: AppEnv -> WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: AppEnv -> Refined NonNegative Seconds
appEnvCheckFeatureFlag :: AppEnv -> CheckFeatureFlag
appEnvSchemaPollInterval :: AppEnv -> OptionalInterval
appEnvLicenseKeyCache :: AppEnv -> Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: AppEnv -> Int
appEnvPort :: Port
appEnvHost :: HostPreference
appEnvMetadataDbPool :: PGPool
appEnvIntrospectionDbPool :: Maybe PGPool
appEnvManager :: Manager
appEnvLoggers :: Loggers
appEnvMetadataVersionRef :: TMVar MetadataResourceVersion
appEnvInstanceId :: InstanceId
appEnvEnableMaintenanceMode :: MaintenanceMode ()
appEnvLoggingSettings :: LoggingSettings
appEnvEventingMode :: EventingMode
appEnvEnableReadOnlyMode :: ReadOnlyMode
appEnvServerMetrics :: ServerMetrics
appEnvShutdownLatch :: ShutdownLatch
appEnvMetaVersionRef :: TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: PrometheusMetrics
appEnvTraceSamplingPolicy :: SamplingPolicy
appEnvSubscriptionState :: SubscriptionsState
appEnvLockedEventsCtx :: LockedEventsCtx
appEnvConnParams :: ConnParams
appEnvTxIso :: TxIsolation
appEnvConsoleAssetsDir :: Maybe Text
appEnvConsoleSentryDsn :: Maybe Text
appEnvConnectionOptions :: ConnectionOptions
appEnvWebSocketKeepAlive :: KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: Refined NonNegative Seconds
appEnvSchemaPollInterval :: OptionalInterval
appEnvCheckFeatureFlag :: CheckFeatureFlag
appEnvLicenseKeyCache :: Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: Int
..} <- m AppEnv -> ManagedT m AppEnv
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppEnv
forall (m :: * -> *). HasAppEnv m => m AppEnv
askAppEnv
  Application
waiApplication <- (AppStateRef impl -> SpockT m ())
-> AppStateRef impl
-> ConsoleType m
-> Store EmptyMetrics
-> ManagedT m Application
forall (m :: * -> *) impl.
(MonadIO m, MonadFix m, MonadMask m, MonadStateless IO m,
 Forall (Pure m), UserAuthentication m, HttpLog m, HasAppEnv m,
 HasCacheStaticConfig m, HasFeatureFlagChecker m, ConsoleRenderer m,
 MonadVersionAPIWithExtraData m, MonadMetadataApiAuthorization m,
 MonadGQLExecutionCheck m, MonadConfigApiHandler m, MonadQueryLog m,
 MonadExecutionLog m, MonadWSLog m, MonadExecuteQuery m,
 HasResourceLimits m, MonadMetadataStorage m, MonadResolveSource m,
 MonadQueryTags m, MonadEventLogCleanup m, ProvidesHasuraServices m,
 MonadTrace m, MonadGetPolicies m) =>
(AppStateRef impl -> SpockT m ())
-> AppStateRef impl
-> ConsoleType m
-> Store EmptyMetrics
-> ManagedT m Application
mkHGEServer AppStateRef impl -> SpockT m ()
setupHook AppStateRef impl
appStateRef ConsoleType m
consoleType Store EmptyMetrics
ekgStore

  let logger :: Logger Hasura
logger = Loggers -> Logger Hasura
_lsLogger Loggers
appEnvLoggers
  -- `startupStatusHook`: add `Service started successfully` message to config_status
  -- table when a tenant starts up in multitenant
  let warpSettings :: Warp.Settings
      warpSettings :: Settings
warpSettings =
        Int -> Settings -> Settings
Warp.setPort (Port -> Int
_getPort Port
appEnvPort)
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostPreference -> Settings -> Settings
Warp.setHost HostPreference
appEnvHost
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Settings -> Settings
Warp.setGracefulShutdownTimeout (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
30) -- 30s graceful shutdown
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO () -> IO ()) -> Settings -> Settings
Warp.setInstallShutdownHandler IO () -> IO ()
shutdownHandler
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Settings -> Settings
Warp.setBeforeMainLoop (Maybe (IO ()) -> (IO () -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (IO ())
startupStatusHook IO () -> IO ()
forall a. a -> a
id)
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Settings
setForkIOWithMetrics
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Settings -> Settings
Warp.setMaxTotalHeaderLength Int
appEnvMaxTotalHeaderLength
          (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
Warp.defaultSettings

      setForkIOWithMetrics :: Warp.Settings -> Warp.Settings
      setForkIOWithMetrics :: Settings -> Settings
setForkIOWithMetrics = (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> Settings -> Settings
Warp.setFork \(forall a. IO a -> IO a) -> IO ()
f -> do
        IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
          (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
C.forkIOWithUnmask
            ( \forall a. IO a -> IO a
unmask ->
                IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
                  ( do
                      Gauge -> IO ()
EKG.Gauge.inc (ServerMetrics -> Gauge
smWarpThreads ServerMetrics
appEnvServerMetrics)
                      ConnectionsGauge -> IO ()
incWarpThreads (PrometheusMetrics -> ConnectionsGauge
pmConnections PrometheusMetrics
appEnvPrometheusMetrics)
                  )
                  ( do
                      Gauge -> IO ()
EKG.Gauge.dec (ServerMetrics -> Gauge
smWarpThreads ServerMetrics
appEnvServerMetrics)
                      ConnectionsGauge -> IO ()
decWarpThreads (PrometheusMetrics -> ConnectionsGauge
pmConnections PrometheusMetrics
appEnvPrometheusMetrics)
                  )
                  ((forall a. IO a -> IO a) -> IO ()
f IO a -> IO a
forall a. IO a -> IO a
unmask)
            )

      shutdownHandler :: IO () -> IO ()
      shutdownHandler :: IO () -> IO ()
shutdownHandler IO ()
closeSocket =
        Async () -> IO ()
forall (m :: * -> *) a. MonadBase IO m => Async a -> m ()
LA.link (Async () -> IO ()) -> IO (Async ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO () -> IO (Async ())
forall (m :: * -> *) a.
(MonadBaseControl IO m, Forall (Pure m)) =>
m a -> m (Async a)
LA.async do
          ShutdownLatch -> IO ()
waitForShutdown ShutdownLatch
appEnvShutdownLatch
          Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (StartupLog -> IO ()) -> StartupLog -> IO ()
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @Text LogLevel
LevelInfo Text
"server" Text
"gracefully shutting down server"
          IO ()
closeSocket

  UTCTime
finishTime <- IO UTCTime -> ManagedT m UTCTime
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Clock.getCurrentTime
  let apiInitTime :: Double
apiInitTime = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
Clock.diffUTCTime UTCTime
finishTime UTCTime
initTime
  Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger
    (StartupLog -> ManagedT m ()) -> StartupLog -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> Text -> StartupTimeInfo -> StartupLog
forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog LogLevel
LevelInfo Text
"server"
    (StartupTimeInfo -> StartupLog) -> StartupTimeInfo -> StartupLog
forall a b. (a -> b) -> a -> b
$ Text -> Double -> StartupTimeInfo
StartupTimeInfo Text
"starting API server" Double
apiInitTime

  -- Here we block until the shutdown latch 'MVar' is filled, and then
  -- shut down the server. Once this blocking call returns, we'll tidy up
  -- any resources using the finalizers attached using 'ManagedT' above.
  -- Structuring things using the shutdown latch in this way lets us decide
  -- elsewhere exactly how we want to control shutdown.
  IO () -> ManagedT m ()
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ManagedT m ()) -> IO () -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ Settings -> Application -> IO ()
Warp.runSettings Settings
warpSettings Application
waiApplication

-- | Part of a factorization of 'runHGEServer' to expose the constructed WAI
-- application for testing purposes. See 'runHGEServer' for documentation.
mkHGEServer ::
  forall m impl.
  ( MonadIO m,
    MonadFix m,
    MonadMask m,
    MonadStateless IO m,
    LA.Forall (LA.Pure m),
    UserAuthentication m,
    HttpLog m,
    HasAppEnv m,
    HasCacheStaticConfig m,
    HasFeatureFlagChecker m,
    ConsoleRenderer m,
    MonadVersionAPIWithExtraData m,
    MonadMetadataApiAuthorization m,
    MonadGQLExecutionCheck m,
    MonadConfigApiHandler m,
    MonadQueryLog m,
    MonadExecutionLog m,
    WS.MonadWSLog m,
    MonadExecuteQuery m,
    HasResourceLimits m,
    MonadMetadataStorage m,
    MonadResolveSource m,
    MonadQueryTags m,
    MonadEventLogCleanup m,
    ProvidesHasuraServices m,
    MonadTrace m,
    MonadGetPolicies m
  ) =>
  (AppStateRef impl -> Spock.SpockT m ()) ->
  AppStateRef impl ->
  ConsoleType m ->
  EKG.Store EKG.EmptyMetrics ->
  ManagedT m Application
mkHGEServer :: forall (m :: * -> *) impl.
(MonadIO m, MonadFix m, MonadMask m, MonadStateless IO m,
 Forall (Pure m), UserAuthentication m, HttpLog m, HasAppEnv m,
 HasCacheStaticConfig m, HasFeatureFlagChecker m, ConsoleRenderer m,
 MonadVersionAPIWithExtraData m, MonadMetadataApiAuthorization m,
 MonadGQLExecutionCheck m, MonadConfigApiHandler m, MonadQueryLog m,
 MonadExecutionLog m, MonadWSLog m, MonadExecuteQuery m,
 HasResourceLimits m, MonadMetadataStorage m, MonadResolveSource m,
 MonadQueryTags m, MonadEventLogCleanup m, ProvidesHasuraServices m,
 MonadTrace m, MonadGetPolicies m) =>
(AppStateRef impl -> SpockT m ())
-> AppStateRef impl
-> ConsoleType m
-> Store EmptyMetrics
-> ManagedT m Application
mkHGEServer AppStateRef impl -> SpockT m ()
setupHook AppStateRef impl
appStateRef ConsoleType m
consoleType Store EmptyMetrics
ekgStore = do
  -- Comment this to enable expensive assertions from "GHC.AssertNF". These
  -- will log lines to STDOUT containing "not in normal form". In the future we
  -- could try to integrate this into our tests. For now this is a development
  -- tool.
  --
  -- NOTE: be sure to compile WITHOUT code coverage, for this to work properly.
  IO () -> ManagedT m ()
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
disableAssertNF
  AppEnv {Int
Maybe Text
Maybe PGPool
Maybe (CredentialCache AgentLicenseKey)
SamplingPolicy
HostPreference
Manager
TxIsolation
ConnParams
PGPool
Refined NonNegative Seconds
TMVar MetadataResourceVersion
ConnectionOptions
CheckFeatureFlag
ServerMetrics
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
PrometheusMetrics
ShutdownLatch
LoggingSettings
LockedEventsCtx
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
SubscriptionsState
Loggers
appEnvPort :: AppEnv -> Port
appEnvHost :: AppEnv -> HostPreference
appEnvMetadataDbPool :: AppEnv -> PGPool
appEnvIntrospectionDbPool :: AppEnv -> Maybe PGPool
appEnvManager :: AppEnv -> Manager
appEnvLoggers :: AppEnv -> Loggers
appEnvMetadataVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvInstanceId :: AppEnv -> InstanceId
appEnvEnableMaintenanceMode :: AppEnv -> MaintenanceMode ()
appEnvLoggingSettings :: AppEnv -> LoggingSettings
appEnvEventingMode :: AppEnv -> EventingMode
appEnvEnableReadOnlyMode :: AppEnv -> ReadOnlyMode
appEnvServerMetrics :: AppEnv -> ServerMetrics
appEnvShutdownLatch :: AppEnv -> ShutdownLatch
appEnvMetaVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: AppEnv -> PrometheusMetrics
appEnvTraceSamplingPolicy :: AppEnv -> SamplingPolicy
appEnvSubscriptionState :: AppEnv -> SubscriptionsState
appEnvLockedEventsCtx :: AppEnv -> LockedEventsCtx
appEnvConnParams :: AppEnv -> ConnParams
appEnvTxIso :: AppEnv -> TxIsolation
appEnvConsoleAssetsDir :: AppEnv -> Maybe Text
appEnvConsoleSentryDsn :: AppEnv -> Maybe Text
appEnvConnectionOptions :: AppEnv -> ConnectionOptions
appEnvWebSocketKeepAlive :: AppEnv -> KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: AppEnv -> WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: AppEnv -> Refined NonNegative Seconds
appEnvCheckFeatureFlag :: AppEnv -> CheckFeatureFlag
appEnvSchemaPollInterval :: AppEnv -> OptionalInterval
appEnvLicenseKeyCache :: AppEnv -> Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: AppEnv -> Int
appEnvPort :: Port
appEnvHost :: HostPreference
appEnvMetadataDbPool :: PGPool
appEnvIntrospectionDbPool :: Maybe PGPool
appEnvManager :: Manager
appEnvLoggers :: Loggers
appEnvMetadataVersionRef :: TMVar MetadataResourceVersion
appEnvInstanceId :: InstanceId
appEnvEnableMaintenanceMode :: MaintenanceMode ()
appEnvLoggingSettings :: LoggingSettings
appEnvEventingMode :: EventingMode
appEnvEnableReadOnlyMode :: ReadOnlyMode
appEnvServerMetrics :: ServerMetrics
appEnvShutdownLatch :: ShutdownLatch
appEnvMetaVersionRef :: TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: PrometheusMetrics
appEnvTraceSamplingPolicy :: SamplingPolicy
appEnvSubscriptionState :: SubscriptionsState
appEnvLockedEventsCtx :: LockedEventsCtx
appEnvConnParams :: ConnParams
appEnvTxIso :: TxIsolation
appEnvConsoleAssetsDir :: Maybe Text
appEnvConsoleSentryDsn :: Maybe Text
appEnvConnectionOptions :: ConnectionOptions
appEnvWebSocketKeepAlive :: KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: Refined NonNegative Seconds
appEnvSchemaPollInterval :: OptionalInterval
appEnvCheckFeatureFlag :: CheckFeatureFlag
appEnvLicenseKeyCache :: Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: Int
..} <- m AppEnv -> ManagedT m AppEnv
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppEnv
forall (m :: * -> *). HasAppEnv m => m AppEnv
askAppEnv
  let Loggers LoggerCtx Hasura
loggerCtx Logger Hasura
logger PGLogger
_ = Loggers
appEnvLoggers

  WSServerEnv impl
wsServerEnv <- m (WSServerEnv impl) -> ManagedT m (WSServerEnv impl)
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (WSServerEnv impl) -> ManagedT m (WSServerEnv impl))
-> m (WSServerEnv impl) -> ManagedT m (WSServerEnv impl)
forall a b. (a -> b) -> a -> b
$ AppStateRef impl -> m (WSServerEnv impl)
forall (m :: * -> *) impl.
(HasAppEnv m, MonadIO m) =>
AppStateRef impl -> m (WSServerEnv impl)
WS.createWSServerEnv AppStateRef impl
appStateRef

  HasuraApp Application
app AsyncActionSubscriptionState
actionSubState IO ()
stopWsServer <-
    m HasuraApp -> ManagedT m HasuraApp
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
      (m HasuraApp -> ManagedT m HasuraApp)
-> m HasuraApp -> ManagedT m HasuraApp
forall a b. (a -> b) -> a -> b
$ (AppStateRef impl -> SpockT m ())
-> AppStateRef impl
-> ConsoleType m
-> Store EmptyMetrics
-> WSServerEnv impl
-> m HasuraApp
forall (m :: * -> *) impl.
(MonadIO m, MonadFix m, MonadStateless IO m, Forall (Pure m),
 ConsoleRenderer m, MonadVersionAPIWithExtraData m, HttpLog m,
 HasAppEnv m, HasCacheStaticConfig m, HasFeatureFlagChecker m,
 UserAuthentication m, MonadMetadataApiAuthorization m,
 MonadGQLExecutionCheck m, MonadConfigApiHandler m, MonadQueryLog m,
 MonadExecutionLog m, MonadWSLog m, MonadTrace m,
 MonadExecuteQuery m, HasResourceLimits m, MonadMetadataStorage m,
 MonadResolveSource m, MonadQueryTags m, MonadEventLogCleanup m,
 ProvidesNetwork m, MonadGetPolicies m) =>
(AppStateRef impl -> SpockT m ())
-> AppStateRef impl
-> ConsoleType m
-> Store EmptyMetrics
-> WSServerEnv impl
-> m HasuraApp
mkWaiApp
        AppStateRef impl -> SpockT m ()
setupHook
        AppStateRef impl
appStateRef
        ConsoleType m
consoleType
        Store EmptyMetrics
ekgStore
        WSServerEnv impl
wsServerEnv

  -- Log Warning if deprecated environment variables are used
  SourceCache
sources <- SchemaCache -> SourceCache
scSources (SchemaCache -> SourceCache)
-> ManagedT m SchemaCache -> ManagedT m SourceCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SchemaCache -> ManagedT m SchemaCache
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef)
  -- TODO: naveen: send IO to logDeprecatedEnvVars
  AppContext {Environment
HashSet ExperimentalFeature
HashSet API
StreamQueriesOptions
NamingCase
RemoteSchemaPermissions
InferFunctionPermissions
SQLGenCtx
CloseWebsocketsOnMetadataChangeStatus
ApolloFederationStatus
CorsPolicy
AuthMode
MetadataDefaults
ResponseInternalErrorsConfig
OptionalInterval
TelemetryStatus
AllowListStatus
ConsoleStatus
EventEngineCtx
acAuthMode :: AppContext -> AuthMode
acAuthMode :: AuthMode
acSQLGenCtx :: SQLGenCtx
acEnabledAPIs :: HashSet API
acEnableAllowlist :: AllowListStatus
acResponseInternalErrorsConfig :: ResponseInternalErrorsConfig
acEnvironment :: Environment
acRemoteSchemaPermsCtx :: RemoteSchemaPermissions
acFunctionPermsCtx :: InferFunctionPermissions
acExperimentalFeatures :: HashSet ExperimentalFeature
acDefaultNamingConvention :: NamingCase
acMetadataDefaults :: MetadataDefaults
acLiveQueryOptions :: StreamQueriesOptions
acStreamQueryOptions :: StreamQueriesOptions
acCorsPolicy :: CorsPolicy
acConsoleStatus :: ConsoleStatus
acEnableTelemetry :: TelemetryStatus
acEventEngineCtx :: EventEngineCtx
acAsyncActionsFetchInterval :: OptionalInterval
acApolloFederationStatus :: ApolloFederationStatus
acCloseWebsocketsOnMetadataChangeStatus :: CloseWebsocketsOnMetadataChangeStatus
acSQLGenCtx :: AppContext -> SQLGenCtx
acEnabledAPIs :: AppContext -> HashSet API
acEnableAllowlist :: AppContext -> AllowListStatus
acResponseInternalErrorsConfig :: AppContext -> ResponseInternalErrorsConfig
acEnvironment :: AppContext -> Environment
acRemoteSchemaPermsCtx :: AppContext -> RemoteSchemaPermissions
acFunctionPermsCtx :: AppContext -> InferFunctionPermissions
acExperimentalFeatures :: AppContext -> HashSet ExperimentalFeature
acDefaultNamingConvention :: AppContext -> NamingCase
acMetadataDefaults :: AppContext -> MetadataDefaults
acLiveQueryOptions :: AppContext -> StreamQueriesOptions
acStreamQueryOptions :: AppContext -> StreamQueriesOptions
acCorsPolicy :: AppContext -> CorsPolicy
acConsoleStatus :: AppContext -> ConsoleStatus
acEnableTelemetry :: AppContext -> TelemetryStatus
acEventEngineCtx :: AppContext -> EventEngineCtx
acAsyncActionsFetchInterval :: AppContext -> OptionalInterval
acApolloFederationStatus :: AppContext -> ApolloFederationStatus
acCloseWebsocketsOnMetadataChangeStatus :: AppContext -> CloseWebsocketsOnMetadataChangeStatus
..} <- IO AppContext -> ManagedT m AppContext
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AppContext -> ManagedT m AppContext)
-> IO AppContext -> ManagedT m AppContext
forall a b. (a -> b) -> a -> b
$ AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
appStateRef
  IO () -> ManagedT m ()
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ManagedT m ()) -> IO () -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura -> Environment -> SourceCache -> IO ()
logDeprecatedEnvVars Logger Hasura
logger Environment
acEnvironment SourceCache
sources

  -- log inconsistent schema objects
  [InconsistentMetadata]
inconsObjs <- SchemaCache -> [InconsistentMetadata]
scInconsistentObjs (SchemaCache -> [InconsistentMetadata])
-> ManagedT m SchemaCache -> ManagedT m [InconsistentMetadata]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SchemaCache -> ManagedT m SchemaCache
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef)
  IO () -> ManagedT m ()
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ManagedT m ()) -> IO () -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura -> [InconsistentMetadata] -> IO ()
logInconsistentMetadata Logger Hasura
logger [InconsistentMetadata]
inconsObjs

  -- NOTE: `newLogTVar` is being used to make sure that the metadata logger runs only once
  --       while logging errors or any `inconsistent_metadata` logs.
  TVar Bool
newLogTVar <- IO (TVar Bool) -> ManagedT m (TVar Bool)
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Bool) -> ManagedT m (TVar Bool))
-> IO (TVar Bool) -> ManagedT m (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
STM.newTVarIO Bool
False

  -- Start a background thread for processing schema sync event present in the '_sscSyncEventRef'
  Thread
_ <- AppStateRef impl -> TVar Bool -> ManagedT m Thread
forall (m :: * -> *) impl.
(ForkableMonadIO m, HasAppEnv m, HasCacheStaticConfig m,
 MonadMetadataStorage m, MonadResolveSource m, ProvidesNetwork m) =>
AppStateRef impl -> TVar Bool -> ManagedT m Thread
startSchemaSyncProcessorThread AppStateRef impl
appStateRef TVar Bool
newLogTVar

  case EventingMode
appEnvEventingMode of
    EventingMode
EventingEnabled -> do
      Logger Hasura -> LockedEventsCtx -> ManagedT m ()
startEventTriggerPollerThread Logger Hasura
logger LockedEventsCtx
appEnvLockedEventsCtx
      Logger Hasura
-> LockedEventsCtx -> AsyncActionSubscriptionState -> ManagedT m ()
startAsyncActionsPollerThread Logger Hasura
logger LockedEventsCtx
appEnvLockedEventsCtx AsyncActionSubscriptionState
actionSubState

      -- Create logger for logging the statistics of fetched cron triggers
      FetchedCronTriggerStatsLogger
fetchedCronTriggerStatsLogger <-
        m FetchedCronTriggerStatsLogger
-> (FetchedCronTriggerStatsLogger -> m ())
-> ManagedT m FetchedCronTriggerStatsLogger
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> (a -> m b) -> ManagedT m a
allocate
          (Logger Hasura -> m FetchedCronTriggerStatsLogger
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> m FetchedCronTriggerStatsLogger
createFetchedCronTriggerStatsLogger Logger Hasura
logger)
          (Logger Hasura -> FetchedCronTriggerStatsLogger -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> FetchedCronTriggerStatsLogger -> m ()
closeFetchedCronTriggersStatsLogger Logger Hasura
logger)

      -- start a background thread to create new cron events
      Thread
_cronEventsThread <-
        String -> Logger Hasura -> m Void -> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String -> Logger Hasura -> m Void -> ManagedT m Thread
C.forkManagedT String
"runCronEventsGenerator" Logger Hasura
logger
          (m Void -> ManagedT m Thread) -> m Void -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> FetchedCronTriggerStatsLogger -> IO SchemaCache -> m Void
forall (m :: * -> *) void.
(MonadIO m, MonadMetadataStorage m) =>
Logger Hasura
-> FetchedCronTriggerStatsLogger -> IO SchemaCache -> m void
runCronEventsGenerator Logger Hasura
logger FetchedCronTriggerStatsLogger
fetchedCronTriggerStatsLogger (AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef)

      Logger Hasura -> LockedEventsCtx -> ManagedT m ()
startScheduledEventsPollerThread Logger Hasura
logger LockedEventsCtx
appEnvLockedEventsCtx
    EventingMode
EventingDisabled ->
      Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (StartupLog -> ManagedT m ()) -> StartupLog -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @Text LogLevel
LevelInfo Text
"server" Text
"starting in eventing disabled mode"

  -- start a background thread to check for updates
  Thread
_updateThread <-
    String -> Logger Hasura -> m Void -> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String -> Logger Hasura -> m Void -> ManagedT m Thread
C.forkManagedT String
"checkForUpdates" Logger Hasura
logger
      (m Void -> ManagedT m Thread) -> m Void -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ IO Void -> m Void
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO Void -> m Void) -> IO Void -> m Void
forall a b. (a -> b) -> a -> b
$ LoggerCtx Hasura -> Manager -> IO Void
forall a void. LoggerCtx a -> Manager -> IO void
checkForUpdates LoggerCtx Hasura
loggerCtx Manager
appEnvManager

  -- Start a background thread for source pings
  Thread
_sourcePingPoller <-
    String -> Logger Hasura -> m Void -> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String -> Logger Hasura -> m Void -> ManagedT m Thread
C.forkManagedT String
"sourcePingPoller" Logger Hasura
logger (m Void -> ManagedT m Thread) -> m Void -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ do
      let pingLog :: String -> IO ()
pingLog =
            Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (StartupLog -> IO ()) -> (String -> StartupLog) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @String LogLevel
LevelInfo Text
"sources-ping"
      IO Void -> m Void
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        ( Environment -> (String -> IO ()) -> IO SourcePingCache -> IO Void
forall a.
Environment -> (String -> IO ()) -> IO SourcePingCache -> IO a
runPingSources
            Environment
acEnvironment
            String -> IO ()
pingLog
            (SchemaCache -> SourcePingCache
scSourcePingConfig (SchemaCache -> SourcePingCache)
-> IO SchemaCache -> IO SourcePingCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef)
        )

  -- initialise the websocket connection reaper thread
  Thread
_websocketConnectionReaperThread <-
    String -> Logger Hasura -> m Void -> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String -> Logger Hasura -> m Void -> ManagedT m Thread
C.forkManagedT String
"websocket connection reaper thread" Logger Hasura
logger
      (m Void -> ManagedT m Thread) -> m Void -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ IO Void -> m Void
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO Void -> m Void) -> IO Void -> m Void
forall a b. (a -> b) -> a -> b
$ IO
  (AuthMode, AllowListStatus, CorsPolicy, SQLGenCtx,
   HashSet ExperimentalFeature, NamingCase)
-> IO SchemaCache -> WSServer WSConnData -> IO Void
forall a.
IO
  (AuthMode, AllowListStatus, CorsPolicy, SQLGenCtx,
   HashSet ExperimentalFeature, NamingCase)
-> IO SchemaCache -> WSServer a -> IO Void
WS.websocketConnectionReaper IO
  (AuthMode, AllowListStatus, CorsPolicy, SQLGenCtx,
   HashSet ExperimentalFeature, NamingCase)
getLatestConfigForWSServer IO SchemaCache
getSchemaCache' (WSServerEnv impl -> WSServer WSConnData
forall impl. WSServerEnv impl -> WSServer WSConnData
_wseServer WSServerEnv impl
wsServerEnv)

  MetadataDbId
dbUid <-
    ManagedT m (Either QErr MetadataDbId)
forall (m :: * -> *).
MonadMetadataStorage m =>
m (Either QErr MetadataDbId)
getMetadataDbUid ManagedT m (Either QErr MetadataDbId)
-> (QErr -> ManagedT m MetadataDbId) -> ManagedT m MetadataDbId
forall (m :: * -> *) e a.
Monad m =>
m (Either e a) -> (e -> m a) -> m a
`onLeftM` ExitCode -> QErr -> ManagedT m MetadataDbId
forall b. ExitCode -> QErr -> ManagedT m b
forall a (m :: * -> *) b.
(ToJSON a, MonadIO m) =>
ExitCode -> a -> m b
throwErrJExit ExitCode
DatabaseMigrationError
  PGVersion
pgVersion <-
    IO (Either QErr PGVersion) -> ManagedT m (Either QErr PGVersion)
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT QErr IO PGVersion -> IO (Either QErr PGVersion)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr IO PGVersion -> IO (Either QErr PGVersion))
-> ExceptT QErr IO PGVersion -> IO (Either QErr PGVersion)
forall a b. (a -> b) -> a -> b
$ PGPool
-> TxMode -> TxET QErr IO PGVersion -> ExceptT QErr IO PGVersion
forall (m :: * -> *) e a.
(MonadIO m, MonadBaseControl IO m, FromPGTxErr e,
 FromPGConnErr e) =>
PGPool -> TxMode -> TxET e m a -> ExceptT e m a
PG.runTx PGPool
appEnvMetadataDbPool (TxIsolation
PG.ReadCommitted, Maybe TxAccess
forall a. Maybe a
Nothing) (TxET QErr IO PGVersion -> ExceptT QErr IO PGVersion)
-> TxET QErr IO PGVersion -> ExceptT QErr IO PGVersion
forall a b. (a -> b) -> a -> b
$ TxET QErr IO PGVersion
getPgVersion)
      ManagedT m (Either QErr PGVersion)
-> (QErr -> ManagedT m PGVersion) -> ManagedT m PGVersion
forall (m :: * -> *) e a.
Monad m =>
m (Either e a) -> (e -> m a) -> m a
`onLeftM` ExitCode -> QErr -> ManagedT m PGVersion
forall b. ExitCode -> QErr -> ManagedT m b
forall a (m :: * -> *) b.
(ToJSON a, MonadIO m) =>
ExitCode -> a -> m b
throwErrJExit ExitCode
DatabaseMigrationError

  m () -> ManagedT m ()
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ManagedT m ())
-> (StartupLog -> m ()) -> StartupLog -> ManagedT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (StartupLog -> ManagedT m ()) -> StartupLog -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @Text LogLevel
LevelInfo Text
"telemetry" Text
telemetryNotice

  ComputeResourcesResponse
computeResources <- ManagedT m ComputeResourcesResponse
forall (m :: * -> *). MonadIO m => m ComputeResourcesResponse
getServerResources

  -- start a background thread for telemetry
  Thread
_telemetryThread <-
    String -> Logger Hasura -> m Void -> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String -> Logger Hasura -> m Void -> ManagedT m Thread
C.forkManagedT String
"runTelemetry" Logger Hasura
logger
      (m Void -> ManagedT m Thread) -> m Void -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> AppStateRef impl
-> MetadataDbId
-> PGVersion
-> ComputeResourcesResponse
-> m Void
forall (m :: * -> *) impl.
(MonadIO m, HasAppEnv m) =>
Logger Hasura
-> AppStateRef impl
-> MetadataDbId
-> PGVersion
-> ComputeResourcesResponse
-> m Void
runTelemetry Logger Hasura
logger AppStateRef impl
appStateRef MetadataDbId
dbUid PGVersion
pgVersion ComputeResourcesResponse
computeResources

  -- forking a dedicated polling thread to dynamically get the latest JWK settings
  -- set by the user and update the JWK accordingly. This will help in applying the
  -- updates without restarting HGE.
  Thread
_ <-
    String -> Logger Hasura -> m Void -> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String -> Logger Hasura -> m Void -> ManagedT m Thread
C.forkManagedT String
"update JWK" Logger Hasura
logger
      (m Void -> ManagedT m Thread) -> m Void -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ IO AppContext -> Manager -> Logger Hasura -> m Void
forall (m :: * -> *).
ForkableMonadIO m =>
IO AppContext -> Manager -> Logger Hasura -> m Void
updateJwkCtxThread (AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
appStateRef) Manager
appEnvManager Logger Hasura
logger

  -- These cleanup actions are not directly associated with any
  -- resource, but we still need to make sure we clean them up here.
  m () -> m () -> ManagedT m ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> ManagedT m ()
allocate_ (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
stopWsServer)

  Application -> ManagedT m Application
forall a. a -> ManagedT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Application
app
  where
    isRetryRequired :: p -> Either QErr b -> m Bool
isRetryRequired p
_ Either QErr b
resp = do
      Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case Either QErr b
resp of
        Right b
_ -> Bool
False
        Left QErr
err -> QErr -> Code
qeCode QErr
err Code -> Code -> Bool
forall a. Eq a => a -> a -> Bool
== Code
ConcurrentUpdate

    getLatestConfigForWSServer :: IO
  (AuthMode, AllowListStatus, CorsPolicy, SQLGenCtx,
   HashSet ExperimentalFeature, NamingCase)
getLatestConfigForWSServer =
      (AppContext
 -> (AuthMode, AllowListStatus, CorsPolicy, SQLGenCtx,
     HashSet ExperimentalFeature, NamingCase))
-> IO AppContext
-> IO
     (AuthMode, AllowListStatus, CorsPolicy, SQLGenCtx,
      HashSet ExperimentalFeature, NamingCase)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (\AppContext
appCtx -> (AppContext -> AuthMode
acAuthMode AppContext
appCtx, AppContext -> AllowListStatus
acEnableAllowlist AppContext
appCtx, AppContext -> CorsPolicy
acCorsPolicy AppContext
appCtx, AppContext -> SQLGenCtx
acSQLGenCtx AppContext
appCtx, AppContext -> HashSet ExperimentalFeature
acExperimentalFeatures AppContext
appCtx, AppContext -> NamingCase
acDefaultNamingConvention AppContext
appCtx))
        (AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
appStateRef)
    getSchemaCache' :: IO SchemaCache
getSchemaCache' = AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef

    prepareScheduledEvents :: Logger impl -> m ()
prepareScheduledEvents (Logger forall a (m :: * -> *).
(ToEngineLog a impl, MonadIO m) =>
a -> m ()
logger) = do
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ StartupLog -> IO ()
forall a (m :: * -> *).
(ToEngineLog a impl, MonadIO m) =>
a -> m ()
logger (StartupLog -> IO ()) -> StartupLog -> IO ()
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @Text LogLevel
LevelInfo Text
"scheduled_triggers" Text
"preparing data"
      Either QErr ()
res <- RetryPolicyM m
-> (RetryStatus -> Either QErr () -> m Bool)
-> (RetryStatus -> m (Either QErr ()))
-> m (Either QErr ())
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
Retry.retrying RetryPolicyM m
forall (m :: * -> *). Monad m => RetryPolicyM m
Retry.retryPolicyDefault RetryStatus -> Either QErr () -> m Bool
forall {m :: * -> *} {p} {b}.
Monad m =>
p -> Either QErr b -> m Bool
isRetryRequired (m (Either QErr ()) -> RetryStatus -> m (Either QErr ())
forall a. a -> RetryStatus -> a
forall (m :: * -> *) a. Monad m => a -> m a
return m (Either QErr ())
forall (m :: * -> *). MonadMetadataStorage m => m (Either QErr ())
unlockAllLockedScheduledEvents)
      Either QErr () -> (QErr -> m ()) -> m ()
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr ()
res (\QErr
err -> StartupLog -> m ()
forall a (m :: * -> *).
(ToEngineLog a impl, MonadIO m) =>
a -> m ()
logger (StartupLog -> m ()) -> StartupLog -> m ()
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @String LogLevel
LevelError Text
"scheduled_triggers" (Text -> String
forall a. Show a => a -> String
show (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ QErr -> Text
qeError QErr
err))

    getProcessingScheduledEventsCount :: LockedEventsCtx -> IO Int
    getProcessingScheduledEventsCount :: LockedEventsCtx -> IO Int
getProcessingScheduledEventsCount LockedEventsCtx {TVar (HashMap SourceName (Set CronEventId))
TVar (Set CronEventId)
leCronEvents :: TVar (Set CronEventId)
leOneOffEvents :: TVar (Set CronEventId)
leEvents :: TVar (HashMap SourceName (Set CronEventId))
leActionEvents :: TVar (Set CronEventId)
leCronEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leOneOffEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leEvents :: LockedEventsCtx -> TVar (HashMap SourceName (Set CronEventId))
leActionEvents :: LockedEventsCtx -> TVar (Set CronEventId)
..} = do
      Set CronEventId
processingCronEvents <- TVar (Set CronEventId) -> IO (Set CronEventId)
forall a. TVar a -> IO a
readTVarIO TVar (Set CronEventId)
leCronEvents
      Set CronEventId
processingOneOffEvents <- TVar (Set CronEventId) -> IO (Set CronEventId)
forall a. TVar a -> IO a
readTVarIO TVar (Set CronEventId)
leOneOffEvents
      Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Set CronEventId -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set CronEventId
processingOneOffEvents Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set CronEventId -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set CronEventId
processingCronEvents

    shutdownEventTriggerEvents ::
      [BackendSourceInfo] ->
      Logger Hasura ->
      LockedEventsCtx ->
      IO ()
    shutdownEventTriggerEvents :: [AnyBackend SourceInfo]
-> Logger Hasura -> LockedEventsCtx -> IO ()
shutdownEventTriggerEvents [AnyBackend SourceInfo]
sources (Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) LockedEventsCtx {TVar (HashMap SourceName (Set CronEventId))
TVar (Set CronEventId)
leCronEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leOneOffEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leEvents :: LockedEventsCtx -> TVar (HashMap SourceName (Set CronEventId))
leActionEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leCronEvents :: TVar (Set CronEventId)
leOneOffEvents :: TVar (Set CronEventId)
leEvents :: TVar (HashMap SourceName (Set CronEventId))
leActionEvents :: TVar (Set CronEventId)
..} = do
      -- TODO: is this correct?
      -- event triggers should be tied to the life cycle of a source
      HashMap SourceName (Set CronEventId)
lockedEvents <- TVar (HashMap SourceName (Set CronEventId))
-> IO (HashMap SourceName (Set CronEventId))
forall a. TVar a -> IO a
readTVarIO TVar (HashMap SourceName (Set CronEventId))
leEvents
      [AnyBackend SourceInfo]
-> (AnyBackend SourceInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AnyBackend SourceInfo]
sources ((AnyBackend SourceInfo -> IO ()) -> IO ())
-> (AnyBackend SourceInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AnyBackend SourceInfo
backendSourceInfo -> do
        forall (c :: BackendType -> Constraint) (i :: BackendType -> *) r.
AllBackendsSatisfy c =>
AnyBackend i -> (forall (b :: BackendType). c b => i b -> r) -> r
AB.dispatchAnyBackend @BackendEventTrigger AnyBackend SourceInfo
backendSourceInfo \(SourceInfo {Maybe QueryTagsConfig
TableCache b
FunctionCache b
StoredProcedureCache b
LogicalModelCache b
NativeQueryCache b
BackendSourceKind b
SourceName
SourceConfig b
ResolvedSourceCustomization
DBObjectsIntrospection b
_siName :: SourceName
_siSourceKind :: BackendSourceKind b
_siTables :: TableCache b
_siFunctions :: FunctionCache b
_siNativeQueries :: NativeQueryCache b
_siStoredProcedures :: StoredProcedureCache b
_siLogicalModels :: LogicalModelCache b
_siConfiguration :: SourceConfig b
_siQueryTagsConfig :: Maybe QueryTagsConfig
_siCustomization :: ResolvedSourceCustomization
_siDbObjectsIntrospection :: DBObjectsIntrospection b
_siName :: forall (b :: BackendType). SourceInfo b -> SourceName
_siSourceKind :: forall (b :: BackendType). SourceInfo b -> BackendSourceKind b
_siTables :: forall (b :: BackendType). SourceInfo b -> TableCache b
_siFunctions :: forall (b :: BackendType). SourceInfo b -> FunctionCache b
_siNativeQueries :: forall (b :: BackendType). SourceInfo b -> NativeQueryCache b
_siStoredProcedures :: forall (b :: BackendType). SourceInfo b -> StoredProcedureCache b
_siLogicalModels :: forall (b :: BackendType). SourceInfo b -> LogicalModelCache b
_siConfiguration :: forall (b :: BackendType). SourceInfo b -> SourceConfig b
_siQueryTagsConfig :: forall (b :: BackendType). SourceInfo b -> Maybe QueryTagsConfig
_siCustomization :: forall (b :: BackendType).
SourceInfo b -> ResolvedSourceCustomization
_siDbObjectsIntrospection :: forall (b :: BackendType). SourceInfo b -> DBObjectsIntrospection b
..} :: SourceInfo b) -> do
          let sourceNameText :: Text
sourceNameText = SourceName -> Text
sourceNameToText SourceName
_siName
          StartupLog -> IO ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger (StartupLog -> IO ()) -> StartupLog -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> Text -> Text -> StartupLog
forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog LogLevel
LevelInfo Text
"event_triggers" (Text -> StartupLog) -> Text -> StartupLog
forall a b. (a -> b) -> a -> b
$ Text
"unlocking events of source: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sourceNameText
          Maybe (Set CronEventId) -> (Set CronEventId -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (SourceName
-> HashMap SourceName (Set CronEventId) -> Maybe (Set CronEventId)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup SourceName
_siName HashMap SourceName (Set CronEventId)
lockedEvents) ((Set CronEventId -> IO ()) -> IO ())
-> (Set CronEventId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Set CronEventId
sourceLockedEvents -> do
            -- No need to execute unlockEventsTx when events are not present
            Maybe (NESet CronEventId) -> (NESet CronEventId -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Set CronEventId -> Maybe (NESet CronEventId)
forall a. Set a -> Maybe (NESet a)
NE.nonEmptySet Set CronEventId
sourceLockedEvents) ((NESet CronEventId -> IO ()) -> IO ())
-> (NESet CronEventId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NESet CronEventId
nonEmptyLockedEvents -> do
              Either QErr Int
res <- RetryPolicyM IO
-> (RetryStatus -> Either QErr Int -> IO Bool)
-> (RetryStatus -> IO (Either QErr Int))
-> IO (Either QErr Int)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
Retry.retrying RetryPolicyM IO
forall (m :: * -> *). Monad m => RetryPolicyM m
Retry.retryPolicyDefault RetryStatus -> Either QErr Int -> IO Bool
forall {m :: * -> *} {p} {b}.
Monad m =>
p -> Either QErr b -> m Bool
isRetryRequired (IO (Either QErr Int) -> RetryStatus -> IO (Either QErr Int)
forall a. a -> RetryStatus -> a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Either QErr Int) -> RetryStatus -> IO (Either QErr Int))
-> IO (Either QErr Int) -> RetryStatus -> IO (Either QErr Int)
forall a b. (a -> b) -> a -> b
$ forall (b :: BackendType) (m :: * -> *).
(BackendEventTrigger b, MonadIO m) =>
SourceConfig b -> NESet CronEventId -> m (Either QErr Int)
unlockEventsInSource @b SourceConfig b
_siConfiguration NESet CronEventId
nonEmptyLockedEvents)
              case Either QErr Int
res of
                Left QErr
err ->
                  StartupLog -> IO ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger
                    (StartupLog -> IO ()) -> StartupLog -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> Text -> Text -> StartupLog
forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog LogLevel
LevelWarn Text
"event_trigger"
                    (Text -> StartupLog) -> Text -> StartupLog
forall a b. (a -> b) -> a -> b
$ Text
"Error while unlocking event trigger events of source: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sourceNameText
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" error:"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QErr -> Text
showQErr QErr
err
                Right Int
count ->
                  StartupLog -> IO ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger
                    (StartupLog -> IO ()) -> StartupLog -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> Text -> Text -> StartupLog
forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog LogLevel
LevelInfo Text
"event_trigger"
                    (Text -> StartupLog) -> Text -> StartupLog
forall a b. (a -> b) -> a -> b
$ Int -> Text
forall a. Show a => a -> Text
tshow Int
count
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" events of source "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sourceNameText
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" were successfully unlocked"

    shutdownAsyncActions ::
      LockedEventsCtx ->
      ExceptT QErr m ()
    shutdownAsyncActions :: LockedEventsCtx -> ExceptT QErr m ()
shutdownAsyncActions LockedEventsCtx
lockedEventsCtx = do
      Set CronEventId
lockedActionEvents <- IO (Set CronEventId) -> ExceptT QErr m (Set CronEventId)
forall a. IO a -> ExceptT QErr m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set CronEventId) -> ExceptT QErr m (Set CronEventId))
-> IO (Set CronEventId) -> ExceptT QErr m (Set CronEventId)
forall a b. (a -> b) -> a -> b
$ TVar (Set CronEventId) -> IO (Set CronEventId)
forall a. TVar a -> IO a
readTVarIO (TVar (Set CronEventId) -> IO (Set CronEventId))
-> TVar (Set CronEventId) -> IO (Set CronEventId)
forall a b. (a -> b) -> a -> b
$ LockedEventsCtx -> TVar (Set CronEventId)
leActionEvents LockedEventsCtx
lockedEventsCtx
      ExceptT QErr m (Either QErr ()) -> ExceptT QErr m ()
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (ExceptT QErr m (Either QErr ()) -> ExceptT QErr m ())
-> ExceptT QErr m (Either QErr ()) -> ExceptT QErr m ()
forall a b. (a -> b) -> a -> b
$ LockedActionIdArray -> ExceptT QErr m (Either QErr ())
forall (m :: * -> *).
MonadMetadataStorage m =>
LockedActionIdArray -> m (Either QErr ())
setProcessingActionLogsToPending ([CronEventId] -> LockedActionIdArray
LockedActionIdArray ([CronEventId] -> LockedActionIdArray)
-> [CronEventId] -> LockedActionIdArray
forall a b. (a -> b) -> a -> b
$ Set CronEventId -> [CronEventId]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set CronEventId
lockedActionEvents)

    -- This function is a helper function to do couple of things:
    --
    -- 1. When the value of the `graceful-shutdown-timeout` > 0, we poll
    --    the in-flight events queue we maintain using the `processingEventsCountAction`
    --    number of in-flight processing events, in case of actions it is the
    --    actions which are in 'processing' state and in scheduled events
    --    it is the events which are in 'locked' state. The in-flight events queue is polled
    --    every 5 seconds until either the graceful shutdown time is exhausted
    --    or the number of in-flight processing events is 0.
    -- 2. After step 1, we unlock all the events which were attempted to process by the current
    --    graphql-engine instance that are still in the processing
    --    state. In actions, it means to set the status of such actions to 'pending'
    --    and in scheduled events, the status will be set to 'unlocked'.
    waitForProcessingAction ::
      Logger Hasura ->
      String ->
      IO Int ->
      ShutdownAction ->
      Seconds ->
      IO ()
    waitForProcessingAction :: Logger Hasura
-> String -> IO Int -> ShutdownAction -> Seconds -> IO ()
waitForProcessingAction l :: Logger Hasura
l@(Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) String
actionType IO Int
processingEventsCountAction' ShutdownAction
shutdownAction Seconds
maxTimeout
      | Seconds
maxTimeout Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
<= Seconds
0 = do
          case ShutdownAction
shutdownAction of
            EventTriggerShutdownAction IO ()
userDBShutdownAction -> IO ()
userDBShutdownAction
            MetadataDBShutdownAction ExceptT QErr IO ()
metadataDBShutdownAction ->
              ExceptT QErr IO () -> IO (Either QErr ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT QErr IO ()
metadataDBShutdownAction IO (Either QErr ()) -> (Either QErr () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left QErr
err ->
                  StartupLog -> IO ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger
                    (StartupLog -> IO ()) -> StartupLog -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> Text -> Text -> StartupLog
forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog LogLevel
LevelWarn (String -> Text
T.pack String
actionType)
                    (Text -> StartupLog) -> Text -> StartupLog
forall a b. (a -> b) -> a -> b
$ Text
"Error while unlocking the processing  "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
tshow String
actionType
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" err - "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QErr -> Text
showQErr QErr
err
                Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          Int
processingEventsCount <- IO Int
processingEventsCountAction'
          if (Int
processingEventsCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
            then
              StartupLog -> IO ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger
                (StartupLog -> IO ()) -> StartupLog -> IO ()
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @Text LogLevel
LevelInfo (String -> Text
T.pack String
actionType)
                (Text -> StartupLog) -> Text -> StartupLog
forall a b. (a -> b) -> a -> b
$ Text
"All in-flight events have finished processing"
            else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
processingEventsCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              DiffTime -> IO ()
C.sleep (DiffTime
5) -- sleep for 5 seconds and then repeat
              Logger Hasura
-> String -> IO Int -> ShutdownAction -> Seconds -> IO ()
waitForProcessingAction Logger Hasura
l String
actionType IO Int
processingEventsCountAction' ShutdownAction
shutdownAction (Seconds
maxTimeout Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
- (DiffTime -> Seconds
Seconds DiffTime
5))

    startEventTriggerPollerThread :: Logger Hasura -> LockedEventsCtx -> ManagedT m ()
startEventTriggerPollerThread Logger Hasura
logger LockedEventsCtx
lockedEventsCtx = do
      AppEnv {Int
Maybe Text
Maybe PGPool
Maybe (CredentialCache AgentLicenseKey)
SamplingPolicy
HostPreference
Manager
TxIsolation
ConnParams
PGPool
Refined NonNegative Seconds
TMVar MetadataResourceVersion
ConnectionOptions
CheckFeatureFlag
ServerMetrics
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
PrometheusMetrics
ShutdownLatch
LoggingSettings
LockedEventsCtx
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
SubscriptionsState
Loggers
appEnvPort :: AppEnv -> Port
appEnvHost :: AppEnv -> HostPreference
appEnvMetadataDbPool :: AppEnv -> PGPool
appEnvIntrospectionDbPool :: AppEnv -> Maybe PGPool
appEnvManager :: AppEnv -> Manager
appEnvLoggers :: AppEnv -> Loggers
appEnvMetadataVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvInstanceId :: AppEnv -> InstanceId
appEnvEnableMaintenanceMode :: AppEnv -> MaintenanceMode ()
appEnvLoggingSettings :: AppEnv -> LoggingSettings
appEnvEventingMode :: AppEnv -> EventingMode
appEnvEnableReadOnlyMode :: AppEnv -> ReadOnlyMode
appEnvServerMetrics :: AppEnv -> ServerMetrics
appEnvShutdownLatch :: AppEnv -> ShutdownLatch
appEnvMetaVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: AppEnv -> PrometheusMetrics
appEnvTraceSamplingPolicy :: AppEnv -> SamplingPolicy
appEnvSubscriptionState :: AppEnv -> SubscriptionsState
appEnvLockedEventsCtx :: AppEnv -> LockedEventsCtx
appEnvConnParams :: AppEnv -> ConnParams
appEnvTxIso :: AppEnv -> TxIsolation
appEnvConsoleAssetsDir :: AppEnv -> Maybe Text
appEnvConsoleSentryDsn :: AppEnv -> Maybe Text
appEnvConnectionOptions :: AppEnv -> ConnectionOptions
appEnvWebSocketKeepAlive :: AppEnv -> KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: AppEnv -> WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: AppEnv -> Refined NonNegative Seconds
appEnvCheckFeatureFlag :: AppEnv -> CheckFeatureFlag
appEnvSchemaPollInterval :: AppEnv -> OptionalInterval
appEnvLicenseKeyCache :: AppEnv -> Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: AppEnv -> Int
appEnvPort :: Port
appEnvHost :: HostPreference
appEnvMetadataDbPool :: PGPool
appEnvIntrospectionDbPool :: Maybe PGPool
appEnvManager :: Manager
appEnvLoggers :: Loggers
appEnvMetadataVersionRef :: TMVar MetadataResourceVersion
appEnvInstanceId :: InstanceId
appEnvEnableMaintenanceMode :: MaintenanceMode ()
appEnvLoggingSettings :: LoggingSettings
appEnvEventingMode :: EventingMode
appEnvEnableReadOnlyMode :: ReadOnlyMode
appEnvServerMetrics :: ServerMetrics
appEnvShutdownLatch :: ShutdownLatch
appEnvMetaVersionRef :: TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: PrometheusMetrics
appEnvTraceSamplingPolicy :: SamplingPolicy
appEnvSubscriptionState :: SubscriptionsState
appEnvLockedEventsCtx :: LockedEventsCtx
appEnvConnParams :: ConnParams
appEnvTxIso :: TxIsolation
appEnvConsoleAssetsDir :: Maybe Text
appEnvConsoleSentryDsn :: Maybe Text
appEnvConnectionOptions :: ConnectionOptions
appEnvWebSocketKeepAlive :: KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: Refined NonNegative Seconds
appEnvSchemaPollInterval :: OptionalInterval
appEnvCheckFeatureFlag :: CheckFeatureFlag
appEnvLicenseKeyCache :: Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: Int
..} <- m AppEnv -> ManagedT m AppEnv
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppEnv
forall (m :: * -> *). HasAppEnv m => m AppEnv
askAppEnv
      SchemaCache
schemaCache <- IO SchemaCache -> ManagedT m SchemaCache
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SchemaCache -> ManagedT m SchemaCache)
-> IO SchemaCache -> ManagedT m SchemaCache
forall a b. (a -> b) -> a -> b
$ AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef
      let allSources :: [AnyBackend SourceInfo]
allSources = SourceCache -> [AnyBackend SourceInfo]
forall k v. HashMap k v -> [v]
HashMap.elems (SourceCache -> [AnyBackend SourceInfo])
-> SourceCache -> [AnyBackend SourceInfo]
forall a b. (a -> b) -> a -> b
$ SchemaCache -> SourceCache
scSources SchemaCache
schemaCache
      TVar Int
activeEventProcessingThreads <- IO (TVar Int) -> ManagedT m (TVar Int)
forall a. IO a -> ManagedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Int) -> ManagedT m (TVar Int))
-> IO (TVar Int) -> ManagedT m (TVar Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0

      -- Initialise the event processing thread
      let eventsGracefulShutdownAction :: IO ()
eventsGracefulShutdownAction =
            Logger Hasura
-> String -> IO Int -> ShutdownAction -> Seconds -> IO ()
waitForProcessingAction
              Logger Hasura
logger
              String
"event_triggers"
              (HashMap SourceName (Set CronEventId) -> Int
forall a. HashMap SourceName a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HashMap SourceName (Set CronEventId) -> Int)
-> IO (HashMap SourceName (Set CronEventId)) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashMap SourceName (Set CronEventId))
-> IO (HashMap SourceName (Set CronEventId))
forall a. TVar a -> IO a
readTVarIO (LockedEventsCtx -> TVar (HashMap SourceName (Set CronEventId))
leEvents LockedEventsCtx
lockedEventsCtx))
              (IO () -> ShutdownAction
EventTriggerShutdownAction ([AnyBackend SourceInfo]
-> Logger Hasura -> LockedEventsCtx -> IO ()
shutdownEventTriggerEvents [AnyBackend SourceInfo]
allSources Logger Hasura
logger LockedEventsCtx
lockedEventsCtx))
              (Refined NonNegative Seconds -> Seconds
forall {k} (p :: k) x. Refined p x -> x
unrefine Refined NonNegative Seconds
appEnvGracefulShutdownTimeout)

      -- Create logger for logging the statistics of events fetched
      FetchedEventsStatsLogger
fetchedEventsStatsLogger <-
        m FetchedEventsStatsLogger
-> (FetchedEventsStatsLogger -> m ())
-> ManagedT m FetchedEventsStatsLogger
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> (a -> m b) -> ManagedT m a
allocate
          (Logger Hasura -> m FetchedEventsStatsLogger
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> m FetchedEventsStatsLogger
createFetchedEventsStatsLogger Logger Hasura
logger)
          (Logger Hasura -> FetchedEventsStatsLogger -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> FetchedEventsStatsLogger -> m ()
closeFetchedEventsStatsLogger Logger Hasura
logger)

      Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (StartupLog -> ManagedT m ()) -> StartupLog -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => LogLevel -> Text -> a -> StartupLog
mkGenericLog @Text LogLevel
LevelInfo Text
"event_triggers" Text
"starting workers"
      ManagedT m Thread -> ManagedT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
        (ManagedT m Thread -> ManagedT m ())
-> ManagedT m Thread -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ String
-> Logger Hasura
-> ThreadShutdown m
-> m (Forever m)
-> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String
-> Logger Hasura
-> ThreadShutdown m
-> m (Forever m)
-> ManagedT m Thread
C.forkManagedTWithGracefulShutdown
          String
"processEventQueue"
          Logger Hasura
logger
          (m () -> ThreadShutdown m
forall (m :: * -> *). m () -> ThreadShutdown m
C.ThreadShutdown (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
eventsGracefulShutdownAction))
        (m (Forever m) -> ManagedT m Thread)
-> m (Forever m) -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> FetchedEventsStatsLogger
-> Manager
-> IO SchemaCache
-> IO EventEngineCtx
-> TVar Int
-> LockedEventsCtx
-> ServerMetrics
-> EventTriggerMetrics
-> MaintenanceMode ()
-> m (Forever m)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, Forall (Pure m), MonadMask m,
 MonadTrace m, MonadGetPolicies m) =>
Logger Hasura
-> FetchedEventsStatsLogger
-> Manager
-> IO SchemaCache
-> IO EventEngineCtx
-> TVar Int
-> LockedEventsCtx
-> ServerMetrics
-> EventTriggerMetrics
-> MaintenanceMode ()
-> m (Forever m)
processEventQueue
          Logger Hasura
logger
          FetchedEventsStatsLogger
fetchedEventsStatsLogger
          Manager
appEnvManager
          (AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef)
          (AppContext -> EventEngineCtx
acEventEngineCtx (AppContext -> EventEngineCtx)
-> IO AppContext -> IO EventEngineCtx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
appStateRef)
          TVar Int
activeEventProcessingThreads
          LockedEventsCtx
lockedEventsCtx
          ServerMetrics
appEnvServerMetrics
          (PrometheusMetrics -> EventTriggerMetrics
pmEventTriggerMetrics PrometheusMetrics
appEnvPrometheusMetrics)
          MaintenanceMode ()
appEnvEnableMaintenanceMode

    startAsyncActionsPollerThread :: Logger Hasura
-> LockedEventsCtx -> AsyncActionSubscriptionState -> ManagedT m ()
startAsyncActionsPollerThread Logger Hasura
logger LockedEventsCtx
lockedEventsCtx AsyncActionSubscriptionState
actionSubState = do
      AppEnv {Int
Maybe Text
Maybe PGPool
Maybe (CredentialCache AgentLicenseKey)
SamplingPolicy
HostPreference
Manager
TxIsolation
ConnParams
PGPool
Refined NonNegative Seconds
TMVar MetadataResourceVersion
ConnectionOptions
CheckFeatureFlag
ServerMetrics
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
PrometheusMetrics
ShutdownLatch
LoggingSettings
LockedEventsCtx
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
SubscriptionsState
Loggers
appEnvPort :: AppEnv -> Port
appEnvHost :: AppEnv -> HostPreference
appEnvMetadataDbPool :: AppEnv -> PGPool
appEnvIntrospectionDbPool :: AppEnv -> Maybe PGPool
appEnvManager :: AppEnv -> Manager
appEnvLoggers :: AppEnv -> Loggers
appEnvMetadataVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvInstanceId :: AppEnv -> InstanceId
appEnvEnableMaintenanceMode :: AppEnv -> MaintenanceMode ()
appEnvLoggingSettings :: AppEnv -> LoggingSettings
appEnvEventingMode :: AppEnv -> EventingMode
appEnvEnableReadOnlyMode :: AppEnv -> ReadOnlyMode
appEnvServerMetrics :: AppEnv -> ServerMetrics
appEnvShutdownLatch :: AppEnv -> ShutdownLatch
appEnvMetaVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: AppEnv -> PrometheusMetrics
appEnvTraceSamplingPolicy :: AppEnv -> SamplingPolicy
appEnvSubscriptionState :: AppEnv -> SubscriptionsState
appEnvLockedEventsCtx :: AppEnv -> LockedEventsCtx
appEnvConnParams :: AppEnv -> ConnParams
appEnvTxIso :: AppEnv -> TxIsolation
appEnvConsoleAssetsDir :: AppEnv -> Maybe Text
appEnvConsoleSentryDsn :: AppEnv -> Maybe Text
appEnvConnectionOptions :: AppEnv -> ConnectionOptions
appEnvWebSocketKeepAlive :: AppEnv -> KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: AppEnv -> WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: AppEnv -> Refined NonNegative Seconds
appEnvCheckFeatureFlag :: AppEnv -> CheckFeatureFlag
appEnvSchemaPollInterval :: AppEnv -> OptionalInterval
appEnvLicenseKeyCache :: AppEnv -> Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: AppEnv -> Int
appEnvPort :: Port
appEnvHost :: HostPreference
appEnvMetadataDbPool :: PGPool
appEnvIntrospectionDbPool :: Maybe PGPool
appEnvManager :: Manager
appEnvLoggers :: Loggers
appEnvMetadataVersionRef :: TMVar MetadataResourceVersion
appEnvInstanceId :: InstanceId
appEnvEnableMaintenanceMode :: MaintenanceMode ()
appEnvLoggingSettings :: LoggingSettings
appEnvEventingMode :: EventingMode
appEnvEnableReadOnlyMode :: ReadOnlyMode
appEnvServerMetrics :: ServerMetrics
appEnvShutdownLatch :: ShutdownLatch
appEnvMetaVersionRef :: TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: PrometheusMetrics
appEnvTraceSamplingPolicy :: SamplingPolicy
appEnvSubscriptionState :: SubscriptionsState
appEnvLockedEventsCtx :: LockedEventsCtx
appEnvConnParams :: ConnParams
appEnvTxIso :: TxIsolation
appEnvConsoleAssetsDir :: Maybe Text
appEnvConsoleSentryDsn :: Maybe Text
appEnvConnectionOptions :: ConnectionOptions
appEnvWebSocketKeepAlive :: KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: Refined NonNegative Seconds
appEnvSchemaPollInterval :: OptionalInterval
appEnvCheckFeatureFlag :: CheckFeatureFlag
appEnvLicenseKeyCache :: Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: Int
..} <- m AppEnv -> ManagedT m AppEnv
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppEnv
forall (m :: * -> *). HasAppEnv m => m AppEnv
askAppEnv
      let label :: String
label = String
"asyncActionsProcessor"
          asyncActionGracefulShutdownAction :: m ()
asyncActionGracefulShutdownAction =
            ( ((forall a. m a -> IO a) -> IO ()) -> m ()
forall c. ((forall a. m a -> IO a) -> IO c) -> m c
forall (b :: * -> *) (m :: * -> *) c.
MonadStateless b m =>
((forall a. m a -> b a) -> b c) -> m c
liftWithStateless \forall a. m a -> IO a
lowerIO ->
                ( Logger Hasura
-> String -> IO Int -> ShutdownAction -> Seconds -> IO ()
waitForProcessingAction
                    Logger Hasura
logger
                    String
"async_actions"
                    (Set CronEventId -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set CronEventId -> Int) -> IO (Set CronEventId) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Set CronEventId) -> IO (Set CronEventId)
forall a. TVar a -> IO a
readTVarIO (LockedEventsCtx -> TVar (Set CronEventId)
leActionEvents LockedEventsCtx
lockedEventsCtx))
                    (ExceptT QErr IO () -> ShutdownAction
MetadataDBShutdownAction ((forall a. m a -> IO a) -> ExceptT QErr m () -> ExceptT QErr IO ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> ExceptT QErr m b -> ExceptT QErr n b
hoist m a -> IO a
forall a. m a -> IO a
lowerIO (LockedEventsCtx -> ExceptT QErr m ()
shutdownAsyncActions LockedEventsCtx
lockedEventsCtx)))
                    (Refined NonNegative Seconds -> Seconds
forall {k} (p :: k) x. Refined p x -> x
unrefine Refined NonNegative Seconds
appEnvGracefulShutdownTimeout)
                )
            )

      -- start a background thread to handle async actions
      ManagedT m Thread -> ManagedT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
        (ManagedT m Thread -> ManagedT m ())
-> ManagedT m Thread -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ String
-> Logger Hasura
-> ThreadShutdown m
-> m (Forever m)
-> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String
-> Logger Hasura
-> ThreadShutdown m
-> m (Forever m)
-> ManagedT m Thread
C.forkManagedTWithGracefulShutdown
          String
label
          Logger Hasura
logger
          (m () -> ThreadShutdown m
forall (m :: * -> *). m () -> ThreadShutdown m
C.ThreadShutdown m ()
asyncActionGracefulShutdownAction)
        (m (Forever m) -> ManagedT m Thread)
-> m (Forever m) -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ IO Environment
-> Logger Hasura
-> IO SchemaCache
-> IO OptionalInterval
-> TVar (Set CronEventId)
-> Maybe GQLQueryText
-> m (Forever m)
forall (m :: * -> *).
(HasAppEnv m, MonadIO m, MonadBaseControl IO m, Forall (Pure m),
 MonadMetadataStorage m, MonadTrace m) =>
IO Environment
-> Logger Hasura
-> IO SchemaCache
-> IO OptionalInterval
-> TVar (Set CronEventId)
-> Maybe GQLQueryText
-> m (Forever m)
asyncActionsProcessor
          (AppContext -> Environment
acEnvironment (AppContext -> Environment) -> IO AppContext -> IO Environment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
appStateRef)
          Logger Hasura
logger
          (AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef)
          (AppContext -> OptionalInterval
acAsyncActionsFetchInterval (AppContext -> OptionalInterval)
-> IO AppContext -> IO OptionalInterval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
appStateRef)
          (LockedEventsCtx -> TVar (Set CronEventId)
leActionEvents LockedEventsCtx
lockedEventsCtx)
          Maybe GQLQueryText
forall a. Maybe a
Nothing

      -- start a background thread to handle async action live queries
      ManagedT m Thread -> ManagedT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
        (ManagedT m Thread -> ManagedT m ())
-> ManagedT m Thread -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ String -> Logger Hasura -> m Void -> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String -> Logger Hasura -> m Void -> ManagedT m Thread
C.forkManagedT String
"asyncActionSubscriptionsProcessor" Logger Hasura
logger
        (m Void -> ManagedT m Thread) -> m Void -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ AsyncActionSubscriptionState -> m Void
forall (m :: * -> *) void.
(MonadIO m, MonadMetadataStorage m) =>
AsyncActionSubscriptionState -> m void
asyncActionSubscriptionsProcessor AsyncActionSubscriptionState
actionSubState

    startScheduledEventsPollerThread :: Logger Hasura -> LockedEventsCtx -> ManagedT m ()
startScheduledEventsPollerThread Logger Hasura
logger LockedEventsCtx
lockedEventsCtx = do
      AppEnv {Int
Maybe Text
Maybe PGPool
Maybe (CredentialCache AgentLicenseKey)
SamplingPolicy
HostPreference
Manager
TxIsolation
ConnParams
PGPool
Refined NonNegative Seconds
TMVar MetadataResourceVersion
ConnectionOptions
CheckFeatureFlag
ServerMetrics
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
PrometheusMetrics
ShutdownLatch
LoggingSettings
LockedEventsCtx
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
SubscriptionsState
Loggers
appEnvPort :: AppEnv -> Port
appEnvHost :: AppEnv -> HostPreference
appEnvMetadataDbPool :: AppEnv -> PGPool
appEnvIntrospectionDbPool :: AppEnv -> Maybe PGPool
appEnvManager :: AppEnv -> Manager
appEnvLoggers :: AppEnv -> Loggers
appEnvMetadataVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvInstanceId :: AppEnv -> InstanceId
appEnvEnableMaintenanceMode :: AppEnv -> MaintenanceMode ()
appEnvLoggingSettings :: AppEnv -> LoggingSettings
appEnvEventingMode :: AppEnv -> EventingMode
appEnvEnableReadOnlyMode :: AppEnv -> ReadOnlyMode
appEnvServerMetrics :: AppEnv -> ServerMetrics
appEnvShutdownLatch :: AppEnv -> ShutdownLatch
appEnvMetaVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: AppEnv -> PrometheusMetrics
appEnvTraceSamplingPolicy :: AppEnv -> SamplingPolicy
appEnvSubscriptionState :: AppEnv -> SubscriptionsState
appEnvLockedEventsCtx :: AppEnv -> LockedEventsCtx
appEnvConnParams :: AppEnv -> ConnParams
appEnvTxIso :: AppEnv -> TxIsolation
appEnvConsoleAssetsDir :: AppEnv -> Maybe Text
appEnvConsoleSentryDsn :: AppEnv -> Maybe Text
appEnvConnectionOptions :: AppEnv -> ConnectionOptions
appEnvWebSocketKeepAlive :: AppEnv -> KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: AppEnv -> WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: AppEnv -> Refined NonNegative Seconds
appEnvCheckFeatureFlag :: AppEnv -> CheckFeatureFlag
appEnvSchemaPollInterval :: AppEnv -> OptionalInterval
appEnvLicenseKeyCache :: AppEnv -> Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: AppEnv -> Int
appEnvPort :: Port
appEnvHost :: HostPreference
appEnvMetadataDbPool :: PGPool
appEnvIntrospectionDbPool :: Maybe PGPool
appEnvManager :: Manager
appEnvLoggers :: Loggers
appEnvMetadataVersionRef :: TMVar MetadataResourceVersion
appEnvInstanceId :: InstanceId
appEnvEnableMaintenanceMode :: MaintenanceMode ()
appEnvLoggingSettings :: LoggingSettings
appEnvEventingMode :: EventingMode
appEnvEnableReadOnlyMode :: ReadOnlyMode
appEnvServerMetrics :: ServerMetrics
appEnvShutdownLatch :: ShutdownLatch
appEnvMetaVersionRef :: TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: PrometheusMetrics
appEnvTraceSamplingPolicy :: SamplingPolicy
appEnvSubscriptionState :: SubscriptionsState
appEnvLockedEventsCtx :: LockedEventsCtx
appEnvConnParams :: ConnParams
appEnvTxIso :: TxIsolation
appEnvConsoleAssetsDir :: Maybe Text
appEnvConsoleSentryDsn :: Maybe Text
appEnvConnectionOptions :: ConnectionOptions
appEnvWebSocketKeepAlive :: KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: Refined NonNegative Seconds
appEnvSchemaPollInterval :: OptionalInterval
appEnvCheckFeatureFlag :: CheckFeatureFlag
appEnvLicenseKeyCache :: Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: Int
..} <- m AppEnv -> ManagedT m AppEnv
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppEnv
forall (m :: * -> *). HasAppEnv m => m AppEnv
askAppEnv
      -- prepare scheduled triggers
      m () -> ManagedT m ()
forall (m :: * -> *) a. Monad m => m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ManagedT m ()) -> m () -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura -> m ()
forall {m :: * -> *} {impl}.
(MonadIO m, ToEngineLog StartupLog impl, MonadMetadataStorage m) =>
Logger impl -> m ()
prepareScheduledEvents Logger Hasura
logger

      -- Create logger for logging the statistics of scheduled events fetched
      FetchedScheduledEventsStatsLogger
scheduledEventsStatsLogger <-
        m FetchedScheduledEventsStatsLogger
-> (FetchedScheduledEventsStatsLogger -> m ())
-> ManagedT m FetchedScheduledEventsStatsLogger
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> (a -> m b) -> ManagedT m a
allocate
          (Logger Hasura -> m FetchedScheduledEventsStatsLogger
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> m FetchedScheduledEventsStatsLogger
createFetchedScheduledEventsStatsLogger Logger Hasura
logger)
          (Logger Hasura -> FetchedScheduledEventsStatsLogger -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> FetchedScheduledEventsStatsLogger -> m ()
closeFetchedScheduledEventsStatsLogger Logger Hasura
logger)

      -- start a background thread to deliver the scheduled events
      -- _scheduledEventsThread <- do
      let scheduledEventsGracefulShutdownAction :: m ()
scheduledEventsGracefulShutdownAction =
            ( ((forall a. m a -> IO a) -> IO ()) -> m ()
forall c. ((forall a. m a -> IO a) -> IO c) -> m c
forall (b :: * -> *) (m :: * -> *) c.
MonadStateless b m =>
((forall a. m a -> b a) -> b c) -> m c
liftWithStateless \forall a. m a -> IO a
lowerIO ->
                ( Logger Hasura
-> String -> IO Int -> ShutdownAction -> Seconds -> IO ()
waitForProcessingAction
                    Logger Hasura
logger
                    String
"scheduled_events"
                    (LockedEventsCtx -> IO Int
getProcessingScheduledEventsCount LockedEventsCtx
lockedEventsCtx)
                    (ExceptT QErr IO () -> ShutdownAction
MetadataDBShutdownAction (ExceptT QErr IO (Either QErr ()) -> ExceptT QErr IO ()
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (ExceptT QErr IO (Either QErr ()) -> ExceptT QErr IO ())
-> ExceptT QErr IO (Either QErr ()) -> ExceptT QErr IO ()
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> IO a)
-> ExceptT QErr m (Either QErr ())
-> ExceptT QErr IO (Either QErr ())
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> ExceptT QErr m b -> ExceptT QErr n b
hoist m a -> IO a
forall a. m a -> IO a
lowerIO ExceptT QErr m (Either QErr ())
forall (m :: * -> *). MonadMetadataStorage m => m (Either QErr ())
unlockAllLockedScheduledEvents))
                    (Refined NonNegative Seconds -> Seconds
forall {k} (p :: k) x. Refined p x -> x
unrefine Refined NonNegative Seconds
appEnvGracefulShutdownTimeout)
                )
            )

      ManagedT m Thread -> ManagedT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
        (ManagedT m Thread -> ManagedT m ())
-> ManagedT m Thread -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ String
-> Logger Hasura
-> ThreadShutdown m
-> m (Forever m)
-> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String
-> Logger Hasura
-> ThreadShutdown m
-> m (Forever m)
-> ManagedT m Thread
C.forkManagedTWithGracefulShutdown
          String
"processScheduledTriggers"
          Logger Hasura
logger
          (m () -> ThreadShutdown m
forall (m :: * -> *). m () -> ThreadShutdown m
C.ThreadShutdown m ()
scheduledEventsGracefulShutdownAction)
        (m (Forever m) -> ManagedT m Thread)
-> m (Forever m) -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$ IO Environment
-> Logger Hasura
-> FetchedScheduledEventsStatsLogger
-> Manager
-> ScheduledTriggerMetrics
-> IO SchemaCache
-> LockedEventsCtx
-> m (Forever m)
forall (m :: * -> *).
(MonadIO m, MonadTrace m, MonadMetadataStorage m,
 MonadBaseControl IO m) =>
IO Environment
-> Logger Hasura
-> FetchedScheduledEventsStatsLogger
-> Manager
-> ScheduledTriggerMetrics
-> IO SchemaCache
-> LockedEventsCtx
-> m (Forever m)
processScheduledTriggers
          (AppContext -> Environment
acEnvironment (AppContext -> Environment) -> IO AppContext -> IO Environment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
appStateRef)
          Logger Hasura
logger
          FetchedScheduledEventsStatsLogger
scheduledEventsStatsLogger
          Manager
appEnvManager
          (PrometheusMetrics -> ScheduledTriggerMetrics
pmScheduledTriggerMetrics PrometheusMetrics
appEnvPrometheusMetrics)
          (AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef)
          LockedEventsCtx
lockedEventsCtx

runInSeparateTx ::
  PG.TxE QErr a ->
  AppM (Either QErr a)
runInSeparateTx :: forall a. TxE QErr a -> AppM (Either QErr a)
runInSeparateTx TxE QErr a
tx = do
  PGPool
pool <- (AppEnv -> PGPool) -> AppM PGPool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> PGPool
appEnvMetadataDbPool
  IO (Either QErr a) -> AppM (Either QErr a)
forall a. IO a -> AppM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either QErr a) -> AppM (Either QErr a))
-> IO (Either QErr a) -> AppM (Either QErr a)
forall a b. (a -> b) -> a -> b
$ ExceptT QErr IO a -> IO (Either QErr a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr IO a -> IO (Either QErr a))
-> ExceptT QErr IO a -> IO (Either QErr a)
forall a b. (a -> b) -> a -> b
$ PGPool -> TxMode -> TxE QErr a -> ExceptT QErr IO a
forall (m :: * -> *) e a.
(MonadIO m, MonadBaseControl IO m, FromPGTxErr e,
 FromPGConnErr e) =>
PGPool -> TxMode -> TxET e m a -> ExceptT e m a
PG.runTx PGPool
pool (TxIsolation
PG.RepeatableRead, Maybe TxAccess
forall a. Maybe a
Nothing) TxE QErr a
tx

notifySchemaCacheSyncTx :: MetadataResourceVersion -> InstanceId -> CacheInvalidations -> PG.TxE QErr ()
notifySchemaCacheSyncTx :: MetadataResourceVersion
-> InstanceId -> CacheInvalidations -> TxE QErr ()
notifySchemaCacheSyncTx (MetadataResourceVersion Int64
resourceVersion) InstanceId
instanceId CacheInvalidations
invalidations = do
  PG.Discard () <-
    (PGTxErr -> QErr)
-> Query
-> (ViaJSON CacheInvalidations, Int64, InstanceId)
-> Bool
-> TxET QErr IO Discard
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
      INSERT INTO hdb_catalog.hdb_schema_notifications(id, notification, resource_version, instance_id)
      VALUES (1, $1::json, $2, $3::uuid)
      ON CONFLICT (id) DO UPDATE SET
        notification = $1::json,
        resource_version = $2,
        instance_id = $3::uuid
    |]
      (CacheInvalidations -> ViaJSON CacheInvalidations
forall a. a -> ViaJSON a
PG.ViaJSON CacheInvalidations
invalidations, Int64
resourceVersion, InstanceId
instanceId)
      Bool
True
  () -> TxE QErr ()
forall a. a -> TxET QErr IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

getCatalogStateTx :: PG.TxE QErr CatalogState
getCatalogStateTx :: TxE QErr CatalogState
getCatalogStateTx =
  (Text, ViaJSON Value, ViaJSON Value) -> CatalogState
mkCatalogState
    ((Text, ViaJSON Value, ViaJSON Value) -> CatalogState)
-> (SingleRow (Text, ViaJSON Value, ViaJSON Value)
    -> (Text, ViaJSON Value, ViaJSON Value))
-> SingleRow (Text, ViaJSON Value, ViaJSON Value)
-> CatalogState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow (Text, ViaJSON Value, ViaJSON Value)
-> (Text, ViaJSON Value, ViaJSON Value)
forall a. SingleRow a -> a
PG.getRow
    (SingleRow (Text, ViaJSON Value, ViaJSON Value) -> CatalogState)
-> TxET QErr IO (SingleRow (Text, ViaJSON Value, ViaJSON Value))
-> TxE QErr CatalogState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> ()
-> Bool
-> TxET QErr IO (SingleRow (Text, ViaJSON Value, ViaJSON Value))
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
    SELECT hasura_uuid::text, cli_state::json, console_state::json
      FROM hdb_catalog.hdb_version
  |]
      ()
      Bool
False
  where
    mkCatalogState :: (Text, ViaJSON Value, ViaJSON Value) -> CatalogState
mkCatalogState (Text
dbId, PG.ViaJSON Value
cliState, PG.ViaJSON Value
consoleState) =
      Text -> Value -> Value -> CatalogState
CatalogState Text
dbId Value
cliState Value
consoleState

setCatalogStateTx :: CatalogStateType -> J.Value -> PG.TxE QErr ()
setCatalogStateTx :: CatalogStateType -> Value -> TxE QErr ()
setCatalogStateTx CatalogStateType
stateTy Value
stateValue =
  case CatalogStateType
stateTy of
    CatalogStateType
CSTCli ->
      (PGTxErr -> QErr)
-> Query -> Identity (ViaJSON Value) -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
        PGTxErr -> QErr
defaultTxErrorHandler
        [PG.sql|
        UPDATE hdb_catalog.hdb_version
           SET cli_state = $1
      |]
        (ViaJSON Value -> Identity (ViaJSON Value)
forall a. a -> Identity a
Identity (ViaJSON Value -> Identity (ViaJSON Value))
-> ViaJSON Value -> Identity (ViaJSON Value)
forall a b. (a -> b) -> a -> b
$ Value -> ViaJSON Value
forall a. a -> ViaJSON a
PG.ViaJSON Value
stateValue)
        Bool
False
    CatalogStateType
CSTConsole ->
      (PGTxErr -> QErr)
-> Query -> Identity (ViaJSON Value) -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
        PGTxErr -> QErr
defaultTxErrorHandler
        [PG.sql|
        UPDATE hdb_catalog.hdb_version
           SET console_state = $1
      |]
        (ViaJSON Value -> Identity (ViaJSON Value)
forall a. a -> Identity a
Identity (ViaJSON Value -> Identity (ViaJSON Value))
-> ViaJSON Value -> Identity (ViaJSON Value)
forall a b. (a -> b) -> a -> b
$ Value -> ViaJSON Value
forall a. a -> ViaJSON a
PG.ViaJSON Value
stateValue)
        Bool
False

--- helper functions ---

mkConsoleHTML ::
  Text ->
  AuthMode ->
  TelemetryStatus ->
  Maybe Text ->
  Maybe Text ->
  CEConsoleType ->
  Either String Text
mkConsoleHTML :: Text
-> AuthMode
-> TelemetryStatus
-> Maybe Text
-> Maybe Text
-> CEConsoleType
-> Either String Text
mkConsoleHTML Text
path AuthMode
authMode TelemetryStatus
enableTelemetry Maybe Text
consoleAssetsDir Maybe Text
consoleSentryDsn CEConsoleType
ceConsoleType =
  Template -> Value -> Either String Text
renderHtmlTemplate Template
consoleTmplt
    (Value -> Either String Text) -> Value -> Either String Text
forall a b. (a -> b) -> a -> b
$
    -- variables required to render the template
    [Pair] -> Value
J.object
      [ Key
"isAdminSecretSet" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= AuthMode -> Text
isAdminSecretSet AuthMode
authMode,
        Key
"consolePath" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Text
consolePath,
        Key
"enableTelemetry" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Bool -> Text
boolToText (TelemetryStatus -> Bool
isTelemetryEnabled TelemetryStatus
enableTelemetry),
        Key
"cdnAssets" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Bool -> Text
boolToText (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
consoleAssetsDir),
        Key
"consoleSentryDsn" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
consoleSentryDsn,
        Key
"assetsVersion" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Text
consoleAssetsVersion,
        Key
"serverVersion" Key -> Version -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Version
currentVersion,
        Key
"consoleType" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= CEConsoleType -> String
ceConsoleTypeIdentifier CEConsoleType
ceConsoleType, -- TODO(awjchen): This is a kludge that will be removed when the entitlement service is fully implemented.
        Key
"consoleSentryDsn" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= (Text
"" :: Text)
      ]
  where
    consolePath :: Text
consolePath = case Text
path of
      Text
"" -> Text
"/console"
      Text
r -> Text
"/console/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r

    consoleTmplt :: Template
consoleTmplt = $(makeRelativeToProject "src-rsr/console.html" >>= M.embedSingleTemplate)

telemetryNotice :: Text
telemetryNotice :: Text
telemetryNotice =
  Text
"Help us improve Hasura! The graphql-engine server collects anonymized "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"usage stats which allows us to keep improving Hasura at warp speed. "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"To read more or opt-out, visit https://hasura.io/docs/latest/graphql/core/guides/telemetry.html"

mkPgSourceResolver :: PG.PGLogger -> SourceResolver ('Postgres 'Vanilla)
mkPgSourceResolver :: PGLogger -> SourceResolver ('Postgres 'Vanilla)
mkPgSourceResolver PGLogger
pgLogger Environment
env SourceName
_ SourceConnConfiguration ('Postgres 'Vanilla)
config = ExceptT QErr IO PGSourceConfig -> IO (Either QErr PGSourceConfig)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
  let PostgresSourceConnInfo UrlConf
urlConf Maybe PostgresPoolSettings
poolSettings Bool
allowPrepare TxIsolation
isoLevel Maybe (PGClientCerts CertVar CertVar)
_ = PostgresConnConfiguration -> PostgresSourceConnInfo
_pccConnectionInfo SourceConnConfiguration ('Postgres 'Vanilla)
PostgresConnConfiguration
config
  -- If the user does not provide values for the pool settings, then use the default values
  let (Int
maxConns, Int
idleTimeout, Int
retries) = Maybe PostgresPoolSettings
-> DefaultPostgresPoolSettings -> (Int, Int, Int)
getDefaultPGPoolSettingIfNotExists Maybe PostgresPoolSettings
poolSettings DefaultPostgresPoolSettings
defaultPostgresPoolSettings
  Text
urlText <- Environment -> UrlConf -> ExceptT QErr IO Text
forall (m :: * -> *).
MonadError QErr m =>
Environment -> UrlConf -> m Text
resolveUrlConf Environment
env UrlConf
urlConf
  let connInfo :: ConnInfo
connInfo = Int -> ConnDetails -> ConnInfo
PG.ConnInfo Int
retries (ConnDetails -> ConnInfo) -> ConnDetails -> ConnInfo
forall a b. (a -> b) -> a -> b
$ ByteString -> ConnDetails
PG.CDDatabaseURI (ByteString -> ConnDetails) -> ByteString -> ConnDetails
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
txtToBs Text
urlText
      connParams :: ConnParams
connParams =
        ConnParams
PG.defaultConnParams
          { cpIdleTime :: Int
PG.cpIdleTime = Int
idleTimeout,
            cpConns :: Int
PG.cpConns = Int
maxConns,
            cpAllowPrepare :: Bool
PG.cpAllowPrepare = Bool
allowPrepare,
            cpMbLifetime :: Maybe NominalDiffTime
PG.cpMbLifetime = PostgresPoolSettings -> Maybe NominalDiffTime
_ppsConnectionLifetime (PostgresPoolSettings -> Maybe NominalDiffTime)
-> Maybe PostgresPoolSettings -> Maybe NominalDiffTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe PostgresPoolSettings
poolSettings,
            cpTimeout :: Maybe NominalDiffTime
PG.cpTimeout = PostgresPoolSettings -> Maybe NominalDiffTime
_ppsPoolTimeout (PostgresPoolSettings -> Maybe NominalDiffTime)
-> Maybe PostgresPoolSettings -> Maybe NominalDiffTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe PostgresPoolSettings
poolSettings
          }
  PGPool
pgPool <- IO PGPool -> ExceptT QErr IO PGPool
forall a. IO a -> ExceptT QErr IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PGPool -> ExceptT QErr IO PGPool)
-> IO PGPool -> ExceptT QErr IO PGPool
forall a b. (a -> b) -> a -> b
$ ConnInfo -> ConnParams -> PGLogger -> IO PGPool
Q.initPGPool ConnInfo
connInfo ConnParams
connParams PGLogger
pgLogger
  let pgExecCtx :: PGExecCtx
pgExecCtx = TxIsolation -> PGPool -> ResizePoolStrategy -> PGExecCtx
mkPGExecCtx TxIsolation
isoLevel PGPool
pgPool ResizePoolStrategy
NeverResizePool
  PGSourceConfig -> ExceptT QErr IO PGSourceConfig
forall a. a -> ExceptT QErr IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PGSourceConfig -> ExceptT QErr IO PGSourceConfig)
-> PGSourceConfig -> ExceptT QErr IO PGSourceConfig
forall a b. (a -> b) -> a -> b
$ PGExecCtx
-> ConnInfo
-> Maybe (NonEmpty ConnInfo)
-> IO ()
-> ExtensionsSchema
-> HashMap PostgresConnectionSetMemberName ConnInfo
-> ConnectionTemplateConfig
-> PGSourceConfig
PGSourceConfig PGExecCtx
pgExecCtx ConnInfo
connInfo Maybe (NonEmpty ConnInfo)
forall a. Maybe a
Nothing IO ()
forall a. Monoid a => a
mempty (PostgresConnConfiguration -> ExtensionsSchema
_pccExtensionsSchema SourceConnConfiguration ('Postgres 'Vanilla)
PostgresConnConfiguration
config) HashMap PostgresConnectionSetMemberName ConnInfo
forall a. Monoid a => a
mempty ConnectionTemplateConfig
ConnTemplate_NotApplicable

mkMSSQLSourceResolver :: SourceResolver ('MSSQL)
mkMSSQLSourceResolver :: SourceResolver 'MSSQL
mkMSSQLSourceResolver Environment
env SourceName
_name (MSSQLConnConfiguration MSSQLConnectionInfo
connInfo Maybe (NonEmpty MSSQLConnectionInfo)
_) = ExceptT QErr IO MSSQLSourceConfig
-> IO (Either QErr MSSQLSourceConfig)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
  let MSSQLConnectionInfo InputConnectionString
iConnString MSSQLPoolSettings
poolSettings TxIsolation
isolationLevel = MSSQLConnectionInfo
connInfo
      connOptions :: ConnectionOptions
connOptions = case MSSQLPoolSettings
poolSettings of
        MSSQLPoolSettings {Int
Maybe Int
_mpsMaxConnections :: Maybe Int
_mpsTotalMaxConnections :: Maybe Int
_mpsIdleTimeout :: Int
_mpsMaxConnections :: MSSQLPoolSettings -> Maybe Int
_mpsTotalMaxConnections :: MSSQLPoolSettings -> Maybe Int
_mpsIdleTimeout :: MSSQLPoolSettings -> Int
..} ->
          MSPool.ConnectionOptions
            { _coConnections :: Int
_coConnections = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultMSSQLMaxConnections Maybe Int
_mpsMaxConnections,
              _coStripes :: Int
_coStripes = Int
1,
              _coIdleTime :: Int
_coIdleTime = Int
_mpsIdleTimeout
            }
        MSSQLPoolSettings
MSSQLPoolSettingsNoPool -> ConnectionOptions
MSPool.ConnectionOptionsNoPool
  (ConnectionString
connString, MSSQLPool
mssqlPool) <- InputConnectionString
-> ConnectionOptions
-> Environment
-> ExceptT QErr IO (ConnectionString, MSSQLPool)
forall (m :: * -> *).
(MonadIO m, QErrM m) =>
InputConnectionString
-> ConnectionOptions
-> Environment
-> m (ConnectionString, MSSQLPool)
createMSSQLPool InputConnectionString
iConnString ConnectionOptions
connOptions Environment
env
  let mssqlExecCtx :: MSSQLExecCtx
mssqlExecCtx = TxIsolation -> MSSQLPool -> ResizePoolStrategy -> MSSQLExecCtx
mkMSSQLExecCtx TxIsolation
isolationLevel MSSQLPool
mssqlPool ResizePoolStrategy
NeverResizePool
      numReadReplicas :: Int
numReadReplicas = Int
0
  MSSQLSourceConfig -> ExceptT QErr IO MSSQLSourceConfig
forall a. a -> ExceptT QErr IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MSSQLSourceConfig -> ExceptT QErr IO MSSQLSourceConfig)
-> MSSQLSourceConfig -> ExceptT QErr IO MSSQLSourceConfig
forall a b. (a -> b) -> a -> b
$ ConnectionString -> MSSQLExecCtx -> Int -> MSSQLSourceConfig
MSSQLSourceConfig ConnectionString
connString MSSQLExecCtx
mssqlExecCtx Int
numReadReplicas