graphql-engine/server/src-exec/Main.hs
Antoine Leblanc d7309b811e Partial cleanup of Hasura/App, refactor of GlobalCtx
### Description

As part of another project (the continuation of #8421), i have started a cleanup of `Hasura.App`, focusing on deleting old code and grouping together things that belong together. This quickly grew into a refactor of `GlobalCtx`, now renamed into `BasicConnectionInfo`. This small refactor adds comments, and aims at making clear what the purpose of those types and functions is.

Furthermore, it also changes the way the default postgres connection info is created, by making that part of the process of creating the `BasicConnectionInfo`, to deduplicate similar effort across different files.

This is expected to be a no-op.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/8440
GitOrigin-RevId: 412c5b1905f629beb9c6cd262b9798cb31c93bdb
2023-03-22 21:41:53 +00:00

174 lines
7.3 KiB
Haskell

module Main
( main,
)
where
import Control.Concurrent.Extended qualified as C
import Control.Exception
import Control.Monad.Trans.Managed (ManagedT (..), lowerManagedT)
import Data.ByteString.Char8 qualified as BC
import Data.Environment qualified as Env
import Data.Int (Int64)
import Data.Kind (Type)
import Data.Text.Conversions (convertText)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Database.PG.Query qualified as PG
import GHC.Debug.Stub
import GHC.TypeLits (Symbol)
import Hasura.App
import Hasura.App.State
import Hasura.Backends.Postgres.Connection.MonadTx
import Hasura.Backends.Postgres.Connection.Settings
import Hasura.GC qualified as GC
import Hasura.Logging (Hasura, LogLevel (..), defaultEnabledEngineLogTypes)
import Hasura.Prelude
import Hasura.RQL.DDL.Schema
import Hasura.Server.Init
import Hasura.Server.Metrics (ServerMetricsSpec, createServerMetrics)
import Hasura.Server.Migrate (downgradeCatalog)
import Hasura.Server.Prometheus (makeDummyPrometheusMetrics)
import Hasura.Server.Version
import Hasura.ShutdownLatch
import Hasura.Tracing (ignoreTraceT, sampleAlways)
import System.Environment (getEnvironment, lookupEnv, unsetEnv)
import System.Exit qualified as Sys
import System.Metrics qualified as EKG
import System.Posix.Signals qualified as Signals
{-# ANN main ("HLINT: ignore Use env_from_function_argument" :: String) #-}
main :: IO ()
main = maybeWithGhcDebug $ do
catch
do
env <- Env.getEnvironment
clearEnvironment
args <- parseArgs env
runApp env args
(\(ExitException _code msg) -> BC.putStrLn msg >> Sys.exitFailure)
where
-- Since the handling of environment variables works differently between the
-- Cloud version and the OSSS version we clear the process environment to
-- avoid accidentally reading directly from the operating system environment
-- variables.
clearEnvironment :: IO ()
clearEnvironment = getEnvironment >>= traverse_ \(v, _) -> unsetEnv v
runApp :: Env.Environment -> HGEOptions (ServeOptions Hasura) -> IO ()
runApp env (HGEOptions rci metadataDbUrl hgeCmd) = ignoreTraceT do
initTime <- liftIO getCurrentTime
case hgeCmd of
HCServe serveOptions@ServeOptions {..} -> do
let poolSettings =
PostgresPoolSettings
{ _ppsMaxConnections = Just $ PG.cpConns soConnParams,
_ppsTotalMaxConnections = Nothing,
_ppsIdleTimeout = Just $ PG.cpIdleTime soConnParams,
_ppsRetries = _pciRetries rci <|> Just 1,
_ppsPoolTimeout = PG.cpTimeout soConnParams,
_ppsConnectionLifetime = PG.cpMbLifetime soConnParams
}
basicConnectionInfo <-
initBasicConnectionInfo
env
metadataDbUrl
rci
(Just poolSettings)
(PG.cpAllowPrepare soConnParams)
soTxIso
(ekgStore, serverMetrics) <- liftIO $ do
store <- EKG.newStore @AppMetricsSpec
void $ EKG.register (EKG.subset GcSubset store) EKG.registerGcMetrics
let getTimeMs :: IO Int64
getTimeMs = (round . (* 1000)) `fmap` getPOSIXTime
void $ EKG.register store $ EKG.registerCounter ServerTimestampMs () getTimeMs
serverMetrics <-
liftIO $ createServerMetrics $ EKG.subset ServerSubset store
pure (EKG.subset EKG.emptyOf store, serverMetrics)
prometheusMetrics <- lift makeDummyPrometheusMetrics
-- It'd be nice if we didn't have to call runManagedT twice here, but
-- there is a data dependency problem since the call to runPGMetadataStorageApp
-- below depends on appCtx.
runManagedT (initialiseContext env basicConnectionInfo serveOptions Nothing serverMetrics prometheusMetrics sampleAlways) $ \(appStateRef, appEnv) -> do
-- Catches the SIGTERM signal and initiates a graceful shutdown.
-- Graceful shutdown for regular HTTP requests is already implemented in
-- Warp, and is triggered by invoking the 'closeSocket' callback.
-- We only catch the SIGTERM signal once, that is, if the user hits CTRL-C
-- once again, we terminate the process immediately.
liftIO $ do
void $ Signals.installHandler Signals.sigTERM (Signals.CatchOnce (shutdownGracefully $ appEnvShutdownLatch appEnv)) Nothing
void $ Signals.installHandler Signals.sigINT (Signals.CatchOnce (shutdownGracefully $ appEnvShutdownLatch appEnv)) Nothing
let Loggers _ logger _ = appEnvLoggers appEnv
_idleGCThread <-
lift $
C.forkImmortal "ourIdleGC" logger $
GC.ourIdleGC logger (seconds 0.3) (seconds 10) (seconds 60)
runPGMetadataStorageAppT appEnv $
lowerManagedT $
runHGEServer (const $ pure ()) appStateRef initTime Nothing ekgStore
HCExport -> do
metadataConnection <- initMetadataConnectionInfo env metadataDbUrl rci
res <- runTxWithMinimalPool metadataConnection fetchMetadataFromCatalog
either (throwErrJExit MetadataExportError) printJSON res
HCClean -> do
metadataConnection <- initMetadataConnectionInfo env metadataDbUrl rci
res <- runTxWithMinimalPool metadataConnection dropHdbCatalogSchema
let cleanSuccessMsg = "successfully cleaned graphql-engine related data"
either (throwErrJExit MetadataCleanError) (const $ liftIO $ putStrLn cleanSuccessMsg) res
HCDowngrade opts -> do
let poolSettings = setPostgresPoolSettings {_ppsRetries = _pciRetries rci <|> Just 1}
BasicConnectionInfo {..} <- initBasicConnectionInfo env metadataDbUrl rci (Just poolSettings) False PG.ReadCommitted
res <- runTxWithMinimalPool bciMetadataConnInfo $ downgradeCatalog bciDefaultPostgres opts initTime
either (throwErrJExit DowngradeProcessError) (liftIO . print) res
HCVersion -> liftIO $ putStrLn $ "Hasura GraphQL Engine: " ++ convertText currentVersion
where
runTxWithMinimalPool connInfo tx = lowerManagedT $ do
minimalPool <- mkMinimalPool connInfo
liftIO $ runExceptT $ PG.runTx minimalPool (PG.ReadCommitted, Nothing) tx
mkMinimalPool connInfo = do
pgLogger <- _lsPgLogger <$> mkLoggers defaultEnabledEngineLogTypes LevelInfo
let connParams = PG.defaultConnParams {PG.cpConns = 1}
liftIO $ PG.initPGPool connInfo connParams pgLogger
-- | A specification of all EKG metrics tracked in `runApp`.
data
AppMetricsSpec ::
Symbol -> -- Metric name
EKG.MetricType -> -- Metric type, e.g. Counter, Gauge
Type -> -- Tag structure
Type
where
ServerSubset ::
ServerMetricsSpec name metricType tags ->
AppMetricsSpec name metricType tags
GcSubset ::
EKG.GcMetrics name metricType tags ->
AppMetricsSpec name metricType tags
ServerTimestampMs ::
AppMetricsSpec "ekg.server_timestamp_ms" 'EKG.CounterType ()
-- | 'withGhcDebug' but conditional on the environment variable
-- @HASURA_GHC_DEBUG=true@. When this is set a debug socket will be opened,
-- otherwise the server will start normally. This must only be called once and
-- it's argument should be the program's @main@
maybeWithGhcDebug :: IO a -> IO a
maybeWithGhcDebug theMain = do
lookupEnv "HASURA_GHC_DEBUG" >>= \case
Just "true" -> do
putStrLn "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
putStrLn "!!!!! Opening a ghc-debug socket !!!!!"
putStrLn "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
withGhcDebug theMain
_ -> theMain