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

module Hasura.App
  ( ExitCode (DatabaseMigrationError, DowngradeProcessError, MetadataCleanError, MetadataExportError, SchemaCacheInitError),
    ExitException (ExitException),
    GlobalCtx (..),
    Loggers (..),
    PGMetadataStorageAppT (runPGMetadataStorageAppT),
    ServeCtx (ServeCtx, _scLoggers, _scMetadataDbPool, _scShutdownLatch),
    ShutdownLatch,
    accessDeniedErrMsg,
    flushLogger,
    getCatalogStateTx,
    initGlobalCtx,
    initialiseServeCtx,
    migrateCatalogSchema,
    mkLoggers,
    mkPGLogger,
    newShutdownLatch,
    notifySchemaCacheSyncTx,
    parseArgs,
    throwErrExit,
    throwErrJExit,
    printJSON,
    printYaml,
    readTlsAllowlist,
    resolvePostgresConnInfo,
    runHGEServer,
    setCatalogStateTx,
    shutdownGracefully,
    waitForShutdown,
    shuttingDown,

    -- * Exported for testing
    mkHGEServer,
    mkPgSourceResolver,
    mkMSSQLSourceResolver,
  )
where

import Control.Concurrent.Async.Lifted.Safe qualified as LA
import Control.Concurrent.Extended qualified as C
import Control.Concurrent.STM qualified as STM
import Control.Concurrent.STM.TVar (readTVarIO)
import Control.Exception (bracket_, throwIO)
import Control.Monad.Catch
  ( Exception,
    MonadCatch,
    MonadMask,
    MonadThrow,
    onException,
  )
import Control.Monad.Morph (hoist)
import Control.Monad.STM (atomically)
import Control.Monad.Stateless
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Managed (ManagedT (..), allocate_)
import Control.Retry qualified as Retry
import Data.Aeson qualified as A
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy.Char8 qualified as BLC
import Data.Environment qualified as Env
import Data.FileEmbed (makeRelativeToProject)
import Data.HashMap.Strict qualified as HM
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 Data.Yaml qualified as Y
import Database.PG.Query qualified as Q
import GHC.AssertNF.CPP
import Hasura.Backends.MSSQL.Connection
import Hasura.Backends.Postgres.Connection
import Hasura.Base.Error
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.Backend qualified as EB
import Hasura.GraphQL.Execute.Subscription.Poll qualified as ES
import Hasura.GraphQL.Logging (MonadQueryLog (..))
import Hasura.GraphQL.Schema.Options qualified as Options
import Hasura.GraphQL.Transport.HTTP
  ( CacheStoreSuccess (CacheStoreSkipped),
    MonadExecuteQuery (..),
  )
import Hasura.GraphQL.Transport.HTTP.Protocol (toParsed)
import Hasura.GraphQL.Transport.WebSocket.Server qualified as WS
import Hasura.Logging
import Hasura.Metadata.Class
import Hasura.Prelude
import Hasura.QueryTags
import Hasura.RQL.DDL.Schema.Cache
import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.DDL.Schema.Catalog
import Hasura.RQL.Types.Allowlist
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Eventing.Backend
import Hasura.RQL.Types.Metadata
import Hasura.RQL.Types.Network
import Hasura.RQL.Types.Numeric qualified as Numeric
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.SQL.Backend
import Hasura.Server.API.Query (requiresAdmin)
import Hasura.Server.App
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.SchemaCacheRef
  ( SchemaCacheRef,
    getSchemaCache,
    initialiseSchemaCacheRef,
    logInconsistentMetadata,
  )
import Hasura.Server.SchemaUpdate
import Hasura.Server.Telemetry
import Hasura.Server.Types
import Hasura.Server.Version
import Hasura.Session
import Hasura.Tracing qualified as Tracing
import Network.HTTP.Client.CreateManager (mkHttpManager)
import Network.HTTP.Client.Manager (HasHttpManagerM (..))
import Network.HTTP.Client.Transformable qualified as HTTP
import Network.Wai (Application)
import Network.Wai.Handler.Warp qualified as Warp
import Options.Applicative
import System.Environment (getEnvironment)
import System.Log.FastLogger qualified as FL
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

data ExitCode
  = -- these are used during server initialization:
    InvalidEnvironmentVariableOptionsError
  | InvalidDatabaseConnectionParamsError
  | AuthConfigurationError
  | EventSubSystemError
  | DatabaseMigrationError
  | -- | used by MT because it initialises the schema cache only
    -- these are used in app/Main.hs:
    SchemaCacheInitError
  | MetadataExportError
  | MetadataCleanError
  | ExecuteProcessError
  | 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
showList :: [ExitCode] -> ShowS
$cshowList :: [ExitCode] -> ShowS
show :: ExitCode -> String
$cshow :: ExitCode -> String
showsPrec :: Int -> ExitCode -> ShowS
$cshowsPrec :: Int -> 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
showList :: [ExitException] -> ShowS
$cshowList :: [ExitException] -> ShowS
show :: ExitException -> String
$cshow :: ExitException -> String
showsPrec :: Int -> ExitException -> ShowS
$cshowsPrec :: Int -> ExitException -> ShowS
Show)

instance Exception ExitException

throwErrExit :: (MonadIO m) => forall a. ExitCode -> String -> m a
throwErrExit :: forall a. ExitCode -> String -> m a
throwErrExit ExitCode
reason = 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 :: (A.ToJSON a, MonadIO m) => forall b. ExitCode -> a -> m b
throwErrJExit :: forall b. ExitCode -> a -> m b
throwErrJExit ExitCode
reason = IO b -> m b
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
A.encode

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

parseArgs :: EnabledLogTypes impl => IO (HGEOptions (ServeOptions impl))
parseArgs :: IO (HGEOptions (ServeOptions impl))
parseArgs = 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
  [(String, String)]
env <- IO [(String, String)]
getEnvironment
  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 [(String, String)]
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 (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 (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)
        )

--------------------------------------------------------------------------------

printJSON :: (A.ToJSON a, MonadIO m) => a -> m ()
printJSON :: a -> m ()
printJSON = IO () -> m ()
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
A.encode

printYaml :: (A.ToJSON a, MonadIO m) => a -> m ()
printYaml :: a -> m ()
printYaml = IO () -> m ()
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 ()
BC.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
Y.encode

mkPGLogger :: Logger Hasura -> Q.PGLogger
mkPGLogger :: Logger Hasura -> PGLogger
mkPGLogger (Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) (Q.PLERetryMsg Text
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 -> Text -> PGLog
PGLog LogLevel
LevelWarn Text
msg

-- | Context required for all graphql-engine CLI commands
data GlobalCtx = GlobalCtx
  { GlobalCtx -> ConnInfo
_gcMetadataDbConnInfo :: !Q.ConnInfo,
    -- | --database-url option, @'UrlConf' is required to construct default source configuration
    -- and optional retries
    GlobalCtx -> (Maybe (UrlConf, ConnInfo), Maybe Int)
_gcDefaultPostgresConnInfo :: !(Maybe (UrlConf, Q.ConnInfo), Maybe Int)
  }

readTlsAllowlist :: SchemaCacheRef -> IO [TlsAllow]
readTlsAllowlist :: SchemaCacheRef -> IO [TlsAllow]
readTlsAllowlist SchemaCacheRef
scRef = SchemaCache -> [TlsAllow]
scTlsAllowlist (SchemaCache -> [TlsAllow]) -> IO SchemaCache -> IO [TlsAllow]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
scRef

initGlobalCtx ::
  (MonadIO m) =>
  Env.Environment ->
  -- | the metadata DB URL
  Maybe String ->
  -- | the user's DB URL
  PostgresConnInfo (Maybe UrlConf) ->
  m GlobalCtx
initGlobalCtx :: Environment
-> Maybe String -> PostgresConnInfo (Maybe UrlConf) -> m GlobalCtx
initGlobalCtx Environment
env Maybe String
metadataDbUrl PostgresConnInfo (Maybe UrlConf)
defaultPgConnInfo = do
  let PostgresConnInfo Maybe UrlConf
dbUrlConf Maybe Int
maybeRetries = PostgresConnInfo (Maybe UrlConf)
defaultPgConnInfo
      mkConnInfoFromSource :: UrlConf -> m ConnInfo
mkConnInfoFromSource UrlConf
dbUrl = do
        Environment -> UrlConf -> Maybe Int -> m ConnInfo
forall (m :: * -> *).
MonadIO m =>
Environment -> UrlConf -> Maybe Int -> m ConnInfo
resolvePostgresConnInfo Environment
env UrlConf
dbUrl Maybe Int
maybeRetries

      mkConnInfoFromMDb :: String -> ConnInfo
mkConnInfoFromMDb String
mdbUrl =
        let retries :: Int
retries = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
maybeRetries
         in (Int -> ConnDetails -> ConnInfo
Q.ConnInfo Int
retries (ConnDetails -> ConnInfo)
-> (String -> ConnDetails) -> String -> ConnInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ConnDetails
Q.CDDatabaseURI (ByteString -> ConnDetails)
-> (String -> ByteString) -> String -> ConnDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
txtToBs (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) String
mdbUrl

      mkGlobalCtx :: ConnInfo -> Maybe (UrlConf, ConnInfo) -> m GlobalCtx
mkGlobalCtx ConnInfo
mdbConnInfo Maybe (UrlConf, ConnInfo)
sourceConnInfo =
        GlobalCtx -> m GlobalCtx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalCtx -> m GlobalCtx) -> GlobalCtx -> m GlobalCtx
forall a b. (a -> b) -> a -> b
$ ConnInfo -> (Maybe (UrlConf, ConnInfo), Maybe Int) -> GlobalCtx
GlobalCtx ConnInfo
mdbConnInfo (Maybe (UrlConf, ConnInfo)
sourceConnInfo, Maybe Int
maybeRetries)

  case (Maybe String
metadataDbUrl, Maybe UrlConf
dbUrlConf) of
    (Maybe String
Nothing, Maybe UrlConf
Nothing) ->
      ExitCode -> String -> m GlobalCtx
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
dbUrl) -> do
      ConnInfo
connInfo <- UrlConf -> m ConnInfo
mkConnInfoFromSource UrlConf
dbUrl
      ConnInfo -> Maybe (UrlConf, ConnInfo) -> m GlobalCtx
mkGlobalCtx ConnInfo
connInfo (Maybe (UrlConf, ConnInfo) -> m GlobalCtx)
-> Maybe (UrlConf, ConnInfo) -> m GlobalCtx
forall a b. (a -> b) -> a -> b
$ (UrlConf, ConnInfo) -> Maybe (UrlConf, ConnInfo)
forall a. a -> Maybe a
Just (UrlConf
dbUrl, ConnInfo
connInfo)
    (Just String
mdUrl, Maybe UrlConf
Nothing) -> do
      let mdConnInfo :: ConnInfo
mdConnInfo = String -> ConnInfo
mkConnInfoFromMDb String
mdUrl
      ConnInfo -> Maybe (UrlConf, ConnInfo) -> m GlobalCtx
mkGlobalCtx ConnInfo
mdConnInfo Maybe (UrlConf, ConnInfo)
forall a. Maybe a
Nothing
    (Just String
mdUrl, Just UrlConf
dbUrl) -> do
      ConnInfo
srcConnInfo <- UrlConf -> m ConnInfo
mkConnInfoFromSource UrlConf
dbUrl
      let mdConnInfo :: ConnInfo
mdConnInfo = String -> ConnInfo
mkConnInfoFromMDb String
mdUrl
      ConnInfo -> Maybe (UrlConf, ConnInfo) -> m GlobalCtx
mkGlobalCtx ConnInfo
mdConnInfo ((UrlConf, ConnInfo) -> Maybe (UrlConf, ConnInfo)
forall a. a -> Maybe a
Just (UrlConf
dbUrl, ConnInfo
srcConnInfo))

-- | Context required for the 'serve' CLI command.
data ServeCtx = ServeCtx
  { ServeCtx -> Manager
_scHttpManager :: !HTTP.Manager,
    ServeCtx -> InstanceId
_scInstanceId :: !InstanceId,
    ServeCtx -> Loggers
_scLoggers :: !Loggers,
    ServeCtx -> HashSet (EngineLogType Hasura)
_scEnabledLogTypes :: !(HashSet (EngineLogType Hasura)),
    ServeCtx -> PGPool
_scMetadataDbPool :: !Q.PGPool,
    ServeCtx -> ShutdownLatch
_scShutdownLatch :: !ShutdownLatch,
    ServeCtx -> RebuildableSchemaCache
_scSchemaCache :: !RebuildableSchemaCache,
    ServeCtx -> SchemaCacheRef
_scSchemaCacheRef :: !SchemaCacheRef,
    ServeCtx -> TMVar MetadataResourceVersion
_scMetaVersionRef :: !(STM.TMVar MetadataResourceVersion)
  }

-- | Collection of the LoggerCtx, the regular Logger and the PGLogger
-- TODO (from master): better naming?
data Loggers = Loggers
  { Loggers -> LoggerCtx Hasura
_lsLoggerCtx :: !(LoggerCtx Hasura),
    Loggers -> Logger Hasura
_lsLogger :: !(Logger Hasura),
    Loggers -> PGLogger
_lsPgLogger :: !Q.PGLogger
  }

-- | An application with Postgres database as a metadata storage
newtype PGMetadataStorageAppT m a = PGMetadataStorageAppT {PGMetadataStorageAppT m a -> (PGPool, PGLogger) -> m a
runPGMetadataStorageAppT :: (Q.PGPool, Q.PGLogger) -> m a}
  deriving
    ( a -> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
(a -> b) -> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
(forall a b.
 (a -> b) -> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b)
-> (forall a b.
    a -> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a)
-> Functor (PGMetadataStorageAppT m)
forall a b.
a -> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
forall a b.
(a -> b) -> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
forall (m :: * -> *) a b.
Functor m =>
a -> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
fmap :: (a -> b) -> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
Functor,
      Functor (PGMetadataStorageAppT m)
a -> PGMetadataStorageAppT m a
Functor (PGMetadataStorageAppT m)
-> (forall a. a -> PGMetadataStorageAppT m a)
-> (forall a b.
    PGMetadataStorageAppT m (a -> b)
    -> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b)
-> (forall a b c.
    (a -> b -> c)
    -> PGMetadataStorageAppT m a
    -> PGMetadataStorageAppT m b
    -> PGMetadataStorageAppT m c)
-> (forall a b.
    PGMetadataStorageAppT m a
    -> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b)
-> (forall a b.
    PGMetadataStorageAppT m a
    -> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a)
-> Applicative (PGMetadataStorageAppT m)
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
PGMetadataStorageAppT m (a -> b)
-> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
(a -> b -> c)
-> PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b
-> PGMetadataStorageAppT m c
forall a. a -> PGMetadataStorageAppT m a
forall a b.
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
forall a b.
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
forall a b.
PGMetadataStorageAppT m (a -> b)
-> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
forall a b c.
(a -> b -> c)
-> PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b
-> PGMetadataStorageAppT m 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
forall (m :: * -> *).
Applicative m =>
Functor (PGMetadataStorageAppT m)
forall (m :: * -> *) a.
Applicative m =>
a -> PGMetadataStorageAppT m a
forall (m :: * -> *) a b.
Applicative m =>
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
forall (m :: * -> *) a b.
Applicative m =>
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
forall (m :: * -> *) a b.
Applicative m =>
PGMetadataStorageAppT m (a -> b)
-> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b
-> PGMetadataStorageAppT m c
<* :: PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m a
*> :: PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
liftA2 :: (a -> b -> c)
-> PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b
-> PGMetadataStorageAppT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b
-> PGMetadataStorageAppT m c
<*> :: PGMetadataStorageAppT m (a -> b)
-> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
PGMetadataStorageAppT m (a -> b)
-> PGMetadataStorageAppT m a -> PGMetadataStorageAppT m b
pure :: a -> PGMetadataStorageAppT m a
$cpure :: forall (m :: * -> *) a.
Applicative m =>
a -> PGMetadataStorageAppT m a
$cp1Applicative :: forall (m :: * -> *).
Applicative m =>
Functor (PGMetadataStorageAppT m)
Applicative,
      Applicative (PGMetadataStorageAppT m)
a -> PGMetadataStorageAppT m a
Applicative (PGMetadataStorageAppT m)
-> (forall a b.
    PGMetadataStorageAppT m a
    -> (a -> PGMetadataStorageAppT m b) -> PGMetadataStorageAppT m b)
-> (forall a b.
    PGMetadataStorageAppT m a
    -> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b)
-> (forall a. a -> PGMetadataStorageAppT m a)
-> Monad (PGMetadataStorageAppT m)
PGMetadataStorageAppT m a
-> (a -> PGMetadataStorageAppT m b) -> PGMetadataStorageAppT m b
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
forall a. a -> PGMetadataStorageAppT m a
forall a b.
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
forall a b.
PGMetadataStorageAppT m a
-> (a -> PGMetadataStorageAppT m b) -> PGMetadataStorageAppT m b
forall (m :: * -> *).
Monad m =>
Applicative (PGMetadataStorageAppT m)
forall (m :: * -> *) a. Monad m => a -> PGMetadataStorageAppT m a
forall (m :: * -> *) a b.
Monad m =>
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
forall (m :: * -> *) a b.
Monad m =>
PGMetadataStorageAppT m a
-> (a -> PGMetadataStorageAppT m b) -> PGMetadataStorageAppT m 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
return :: a -> PGMetadataStorageAppT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> PGMetadataStorageAppT m a
>> :: PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
PGMetadataStorageAppT m a
-> PGMetadataStorageAppT m b -> PGMetadataStorageAppT m b
>>= :: PGMetadataStorageAppT m a
-> (a -> PGMetadataStorageAppT m b) -> PGMetadataStorageAppT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
PGMetadataStorageAppT m a
-> (a -> PGMetadataStorageAppT m b) -> PGMetadataStorageAppT m b
$cp1Monad :: forall (m :: * -> *).
Monad m =>
Applicative (PGMetadataStorageAppT m)
Monad,
      Monad (PGMetadataStorageAppT m)
Monad (PGMetadataStorageAppT m)
-> (forall a. IO a -> PGMetadataStorageAppT m a)
-> MonadIO (PGMetadataStorageAppT m)
IO a -> PGMetadataStorageAppT m a
forall a. IO a -> PGMetadataStorageAppT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (PGMetadataStorageAppT m)
forall (m :: * -> *) a.
MonadIO m =>
IO a -> PGMetadataStorageAppT m a
liftIO :: IO a -> PGMetadataStorageAppT m a
$cliftIO :: forall (m :: * -> *) a.
MonadIO m =>
IO a -> PGMetadataStorageAppT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (PGMetadataStorageAppT m)
MonadIO,
      Monad (PGMetadataStorageAppT m)
Monad (PGMetadataStorageAppT m)
-> (forall a.
    (a -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a)
-> MonadFix (PGMetadataStorageAppT m)
(a -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
forall a.
(a -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (PGMetadataStorageAppT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
mfix :: (a -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
$cp1MonadFix :: forall (m :: * -> *). MonadFix m => Monad (PGMetadataStorageAppT m)
MonadFix,
      MonadThrow (PGMetadataStorageAppT m)
MonadThrow (PGMetadataStorageAppT m)
-> (forall e a.
    Exception e =>
    PGMetadataStorageAppT m a
    -> (e -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a)
-> MonadCatch (PGMetadataStorageAppT m)
PGMetadataStorageAppT m a
-> (e -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
forall e a.
Exception e =>
PGMetadataStorageAppT m a
-> (e -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall (m :: * -> *).
MonadCatch m =>
MonadThrow (PGMetadataStorageAppT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
PGMetadataStorageAppT m a
-> (e -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
catch :: PGMetadataStorageAppT m a
-> (e -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
PGMetadataStorageAppT m a
-> (e -> PGMetadataStorageAppT m a) -> PGMetadataStorageAppT m a
$cp1MonadCatch :: forall (m :: * -> *).
MonadCatch m =>
MonadThrow (PGMetadataStorageAppT m)
MonadCatch,
      Monad (PGMetadataStorageAppT m)
e -> PGMetadataStorageAppT m a
Monad (PGMetadataStorageAppT m)
-> (forall e a. Exception e => e -> PGMetadataStorageAppT m a)
-> MonadThrow (PGMetadataStorageAppT m)
forall e a. Exception e => e -> PGMetadataStorageAppT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall (m :: * -> *).
MonadThrow m =>
Monad (PGMetadataStorageAppT m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> PGMetadataStorageAppT m a
throwM :: e -> PGMetadataStorageAppT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> PGMetadataStorageAppT m a
$cp1MonadThrow :: forall (m :: * -> *).
MonadThrow m =>
Monad (PGMetadataStorageAppT m)
MonadThrow,
      MonadCatch (PGMetadataStorageAppT m)
MonadCatch (PGMetadataStorageAppT m)
-> (forall b.
    ((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
     -> PGMetadataStorageAppT m b)
    -> PGMetadataStorageAppT m b)
-> (forall b.
    ((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
     -> PGMetadataStorageAppT m b)
    -> PGMetadataStorageAppT m b)
-> (forall a b c.
    PGMetadataStorageAppT m a
    -> (a -> ExitCase b -> PGMetadataStorageAppT m c)
    -> (a -> PGMetadataStorageAppT m b)
    -> PGMetadataStorageAppT m (b, c))
-> MonadMask (PGMetadataStorageAppT m)
PGMetadataStorageAppT m a
-> (a -> ExitCase b -> PGMetadataStorageAppT m c)
-> (a -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m (b, c)
((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
 -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m b
((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
 -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m b
forall b.
((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
 -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m b
forall a b c.
PGMetadataStorageAppT m a
-> (a -> ExitCase b -> PGMetadataStorageAppT m c)
-> (a -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m (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
forall (m :: * -> *).
MonadMask m =>
MonadCatch (PGMetadataStorageAppT m)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
 -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m b
forall (m :: * -> *) a b c.
MonadMask m =>
PGMetadataStorageAppT m a
-> (a -> ExitCase b -> PGMetadataStorageAppT m c)
-> (a -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m (b, c)
generalBracket :: PGMetadataStorageAppT m a
-> (a -> ExitCase b -> PGMetadataStorageAppT m c)
-> (a -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
MonadMask m =>
PGMetadataStorageAppT m a
-> (a -> ExitCase b -> PGMetadataStorageAppT m c)
-> (a -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m (b, c)
uninterruptibleMask :: ((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
 -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
 -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m b
mask :: ((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
 -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m b
$cmask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. PGMetadataStorageAppT m a -> PGMetadataStorageAppT m a)
 -> PGMetadataStorageAppT m b)
-> PGMetadataStorageAppT m b
$cp1MonadMask :: forall (m :: * -> *).
MonadMask m =>
MonadCatch (PGMetadataStorageAppT m)
MonadMask,
      Monad (PGMetadataStorageAppT m)
PGMetadataStorageAppT m Manager
Monad (PGMetadataStorageAppT m)
-> PGMetadataStorageAppT m Manager
-> HasHttpManagerM (PGMetadataStorageAppT m)
forall (m :: * -> *). Monad m -> m Manager -> HasHttpManagerM m
forall (m :: * -> *).
HasHttpManagerM m =>
Monad (PGMetadataStorageAppT m)
forall (m :: * -> *).
HasHttpManagerM m =>
PGMetadataStorageAppT m Manager
askHttpManager :: PGMetadataStorageAppT m Manager
$caskHttpManager :: forall (m :: * -> *).
HasHttpManagerM m =>
PGMetadataStorageAppT m Manager
$cp1HasHttpManagerM :: forall (m :: * -> *).
HasHttpManagerM m =>
Monad (PGMetadataStorageAppT m)
HasHttpManagerM,
      Monad (PGMetadataStorageAppT m)
PGMetadataStorageAppT m ServerConfigCtx
Monad (PGMetadataStorageAppT m)
-> PGMetadataStorageAppT m ServerConfigCtx
-> HasServerConfigCtx (PGMetadataStorageAppT m)
forall (m :: * -> *).
Monad m -> m ServerConfigCtx -> HasServerConfigCtx m
forall (m :: * -> *).
HasServerConfigCtx m =>
Monad (PGMetadataStorageAppT m)
forall (m :: * -> *).
HasServerConfigCtx m =>
PGMetadataStorageAppT m ServerConfigCtx
askServerConfigCtx :: PGMetadataStorageAppT m ServerConfigCtx
$caskServerConfigCtx :: forall (m :: * -> *).
HasServerConfigCtx m =>
PGMetadataStorageAppT m ServerConfigCtx
$cp1HasServerConfigCtx :: forall (m :: * -> *).
HasServerConfigCtx m =>
Monad (PGMetadataStorageAppT m)
HasServerConfigCtx,
      MonadReader (Q.PGPool, Q.PGLogger),
      MonadBase b,
      MonadBaseControl b
    )
    via (ReaderT (Q.PGPool, Q.PGLogger) m)
  deriving
    ( m a -> PGMetadataStorageAppT m a
(forall (m :: * -> *) a.
 Monad m =>
 m a -> PGMetadataStorageAppT m a)
-> MonadTrans PGMetadataStorageAppT
forall (m :: * -> *) a. Monad m => m a -> PGMetadataStorageAppT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> PGMetadataStorageAppT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> PGMetadataStorageAppT m a
MonadTrans
    )
    via (ReaderT (Q.PGPool, Q.PGLogger))

resolvePostgresConnInfo ::
  (MonadIO m) => Env.Environment -> UrlConf -> Maybe Int -> m Q.ConnInfo
resolvePostgresConnInfo :: Environment -> UrlConf -> Maybe Int -> m ConnInfo
resolvePostgresConnInfo Environment
env UrlConf
dbUrlConf Maybe Int
maybeRetries = do
  Text
dbUrlText <-
    Except QErr Text -> Either QErr Text
forall e a. Except e a -> Either e a
runExcept (Environment -> UrlConf -> Except 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExitCode -> QErr -> IO Text
forall a (m :: * -> *) b.
(ToJSON a, MonadIO m) =>
ExitCode -> a -> m b
throwErrJExit ExitCode
InvalidDatabaseConnectionParamsError QErr
err)
  ConnInfo -> m ConnInfo
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
Q.ConnInfo Int
retries (ConnDetails -> ConnInfo) -> ConnDetails -> ConnInfo
forall a b. (a -> b) -> a -> b
$ ByteString -> ConnDetails
Q.CDDatabaseURI (ByteString -> ConnDetails) -> ByteString -> ConnDetails
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
txtToBs Text
dbUrlText
  where
    retries :: Int
retries = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
maybeRetries

-- | Initializes or migrates the catalog and returns the context required to start the server.
initialiseServeCtx ::
  (C.ForkableMonadIO m, MonadCatch m) =>
  Env.Environment ->
  GlobalCtx ->
  ServeOptions Hasura ->
  ServerMetrics ->
  ManagedT m ServeCtx
initialiseServeCtx :: Environment
-> GlobalCtx
-> ServeOptions Hasura
-> ServerMetrics
-> ManagedT m ServeCtx
initialiseServeCtx Environment
env GlobalCtx {(Maybe (UrlConf, ConnInfo), Maybe Int)
ConnInfo
_gcDefaultPostgresConnInfo :: (Maybe (UrlConf, ConnInfo), Maybe Int)
_gcMetadataDbConnInfo :: ConnInfo
_gcDefaultPostgresConnInfo :: GlobalCtx -> (Maybe (UrlConf, ConnInfo), Maybe Int)
_gcMetadataDbConnInfo :: GlobalCtx -> ConnInfo
..} so :: ServeOptions Hasura
so@ServeOptions {Bool
[JWTConfig]
Maybe Text
Maybe RoleName
Maybe NamingCase
Maybe AuthHook
HashSet (EngineLogType Hasura)
HashSet ExperimentalFeature
HashSet AdminSecretHash
HashSet API
LogLevel
RemoteSchemaPermissions
InferFunctionPermissions
DangerouslyCollapseBooleans
StringifyNumbers
ConnParams
TxIsolation
CorsConfig
ExtensionsSchema
PositiveInt
NonNegativeInt
NonNegative Milliseconds
NonNegative Seconds
StreamQueriesOptions
EventingMode
ReadOnlyMode
MaintenanceMode ()
MetadataQueryLoggingMode
HostPreference
ConnectionOptions
ResponseInternalErrorsConfig
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
soExtensionsSchema :: forall impl. ServeOptions impl -> ExtensionsSchema
soDefaultNamingConvention :: forall impl. ServeOptions impl -> Maybe NamingCase
soEnableMetadataQueryLogging :: forall impl. ServeOptions impl -> MetadataQueryLoggingMode
soReadOnlyMode :: forall impl. ServeOptions impl -> ReadOnlyMode
soEventingMode :: forall impl. ServeOptions impl -> EventingMode
soWebSocketConnectionInitTimeout :: forall impl. ServeOptions impl -> WSConnectionInitTimeout
soGracefulShutdownTimeout :: forall impl. ServeOptions impl -> NonNegative Seconds
soDevMode :: forall impl. ServeOptions impl -> Bool
soEventsFetchBatchSize :: forall impl. ServeOptions impl -> NonNegativeInt
soExperimentalFeatures :: forall impl. ServeOptions impl -> HashSet ExperimentalFeature
soSchemaPollInterval :: forall impl. ServeOptions impl -> OptionalInterval
soEnableMaintenanceMode :: forall impl. ServeOptions impl -> MaintenanceMode ()
soInferFunctionPermissions :: forall impl. ServeOptions impl -> InferFunctionPermissions
soWebSocketKeepAlive :: forall impl. ServeOptions impl -> KeepAliveDelay
soConnectionOptions :: forall impl. ServeOptions impl -> ConnectionOptions
soEnableRemoteSchemaPermissions :: forall impl. ServeOptions impl -> RemoteSchemaPermissions
soAsyncActionsFetchInterval :: forall impl. ServeOptions impl -> OptionalInterval
soEventsFetchInterval :: forall impl. ServeOptions impl -> NonNegative Milliseconds
soEventsHttpPoolSize :: forall impl. ServeOptions impl -> PositiveInt
soResponseInternalErrorsConfig :: forall impl. ServeOptions impl -> ResponseInternalErrorsConfig
soLogLevel :: forall impl. ServeOptions impl -> LogLevel
soEnabledLogTypes :: forall impl. ServeOptions impl -> HashSet (EngineLogType impl)
soEnableAllowlist :: forall impl. ServeOptions impl -> Bool
soStreamingQueryOpts :: forall impl. ServeOptions impl -> StreamQueriesOptions
soLiveQueryOpts :: forall impl. ServeOptions impl -> StreamQueriesOptions
soEnabledAPIs :: forall impl. ServeOptions impl -> HashSet API
soDangerousBooleanCollapse :: forall impl. ServeOptions impl -> DangerouslyCollapseBooleans
soStringifyNum :: forall impl. ServeOptions impl -> StringifyNumbers
soEnableTelemetry :: forall impl. ServeOptions impl -> Bool
soConsoleAssetsDir :: forall impl. ServeOptions impl -> Maybe Text
soEnableConsole :: forall impl. ServeOptions impl -> Bool
soCorsConfig :: forall impl. ServeOptions impl -> CorsConfig
soUnAuthRole :: forall impl. ServeOptions impl -> Maybe RoleName
soJwtSecret :: forall impl. ServeOptions impl -> [JWTConfig]
soAuthHook :: forall impl. ServeOptions impl -> Maybe AuthHook
soAdminSecret :: forall impl. ServeOptions impl -> HashSet AdminSecretHash
soTxIso :: forall impl. ServeOptions impl -> TxIsolation
soConnParams :: forall impl. ServeOptions impl -> ConnParams
soHost :: forall impl. ServeOptions impl -> HostPreference
soPort :: forall impl. ServeOptions impl -> Port
soExtensionsSchema :: ExtensionsSchema
soDefaultNamingConvention :: Maybe NamingCase
soEnableMetadataQueryLogging :: MetadataQueryLoggingMode
soReadOnlyMode :: ReadOnlyMode
soEventingMode :: EventingMode
soWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
soGracefulShutdownTimeout :: NonNegative Seconds
soDevMode :: Bool
soEventsFetchBatchSize :: NonNegativeInt
soExperimentalFeatures :: HashSet ExperimentalFeature
soSchemaPollInterval :: OptionalInterval
soEnableMaintenanceMode :: MaintenanceMode ()
soInferFunctionPermissions :: InferFunctionPermissions
soWebSocketKeepAlive :: KeepAliveDelay
soConnectionOptions :: ConnectionOptions
soEnableRemoteSchemaPermissions :: RemoteSchemaPermissions
soAsyncActionsFetchInterval :: OptionalInterval
soEventsFetchInterval :: NonNegative Milliseconds
soEventsHttpPoolSize :: PositiveInt
soResponseInternalErrorsConfig :: ResponseInternalErrorsConfig
soLogLevel :: LogLevel
soEnabledLogTypes :: HashSet (EngineLogType Hasura)
soEnableAllowlist :: Bool
soStreamingQueryOpts :: StreamQueriesOptions
soLiveQueryOpts :: StreamQueriesOptions
soEnabledAPIs :: HashSet API
soDangerousBooleanCollapse :: DangerouslyCollapseBooleans
soStringifyNum :: StringifyNumbers
soEnableTelemetry :: Bool
soConsoleAssetsDir :: Maybe Text
soEnableConsole :: Bool
soCorsConfig :: CorsConfig
soUnAuthRole :: Maybe RoleName
soJwtSecret :: [JWTConfig]
soAuthHook :: Maybe AuthHook
soAdminSecret :: HashSet AdminSecretHash
soTxIso :: TxIsolation
soConnParams :: ConnParams
soHost :: HostPreference
soPort :: Port
..} ServerMetrics
serverMetrics = do
  InstanceId
instanceId <- IO InstanceId -> ManagedT m InstanceId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InstanceId
generateInstanceId
  ShutdownLatch
latch <- IO ShutdownLatch -> ManagedT m ShutdownLatch
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ShutdownLatch
newShutdownLatch
  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
  Bool -> ManagedT m () -> ManagedT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HashSet AdminSecretHash -> 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
$ do
    let errMsg :: Text
        errMsg :: Text
errMsg = Text
"WARNING: No admin secret provided"
    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
$
      StartupLog :: LogLevel -> Text -> Value -> StartupLog
StartupLog
        { slLogLevel :: LogLevel
slLogLevel = LogLevel
LevelWarn,
          slKind :: Text
slKind = Text
"no_admin_secret",
          slInfo :: Value
slInfo = Text -> Value
forall a. ToJSON a => a -> Value
A.toJSON Text
errMsg
        }
  -- log serve 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
so

  -- log 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
_gcMetadataDbConnInfo

  PGPool
metadataDbPool <- IO PGPool -> ManagedT m PGPool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PGPool -> ManagedT m PGPool) -> IO PGPool -> ManagedT m PGPool
forall a b. (a -> b) -> a -> b
$ ConnInfo -> ConnParams -> PGLogger -> IO PGPool
Q.initPGPool ConnInfo
_gcMetadataDbConnInfo ConnParams
soConnParams PGLogger
pgLogger

  let maybeDefaultSourceConfig :: Maybe PostgresConnConfiguration
maybeDefaultSourceConfig =
        (Maybe (UrlConf, ConnInfo), Maybe Int) -> Maybe (UrlConf, ConnInfo)
forall a b. (a, b) -> a
fst (Maybe (UrlConf, ConnInfo), Maybe Int)
_gcDefaultPostgresConnInfo Maybe (UrlConf, ConnInfo)
-> ((UrlConf, ConnInfo) -> PostgresConnConfiguration)
-> Maybe PostgresConnConfiguration
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(UrlConf
dbUrlConf, ConnInfo
_) ->
          let connSettings :: PostgresPoolSettings
connSettings =
                PostgresPoolSettings :: Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe NominalDiffTime
-> Maybe NominalDiffTime
-> PostgresPoolSettings
PostgresPoolSettings
                  { _ppsMaxConnections :: Maybe Int
_ppsMaxConnections = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ConnParams -> Int
Q.cpConns ConnParams
soConnParams,
                    _ppsIdleTimeout :: Maybe Int
_ppsIdleTimeout = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ConnParams -> Int
Q.cpIdleTime ConnParams
soConnParams,
                    _ppsRetries :: Maybe Int
_ppsRetries = (Maybe (UrlConf, ConnInfo), Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd (Maybe (UrlConf, ConnInfo), Maybe Int)
_gcDefaultPostgresConnInfo Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1,
                    _ppsPoolTimeout :: Maybe NominalDiffTime
_ppsPoolTimeout = ConnParams -> Maybe NominalDiffTime
Q.cpTimeout ConnParams
soConnParams,
                    _ppsConnectionLifetime :: Maybe NominalDiffTime
_ppsConnectionLifetime = ConnParams -> Maybe NominalDiffTime
Q.cpMbLifetime ConnParams
soConnParams
                  }
              sourceConnInfo :: PostgresSourceConnInfo
sourceConnInfo = UrlConf
-> Maybe PostgresPoolSettings
-> Bool
-> TxIsolation
-> Maybe (PGClientCerts CertVar CertVar)
-> PostgresSourceConnInfo
PostgresSourceConnInfo UrlConf
dbUrlConf (PostgresPoolSettings -> Maybe PostgresPoolSettings
forall a. a -> Maybe a
Just PostgresPoolSettings
connSettings) (ConnParams -> Bool
Q.cpAllowPrepare ConnParams
soConnParams) TxIsolation
soTxIso Maybe (PGClientCerts CertVar CertVar)
forall a. Maybe a
Nothing
           in PostgresSourceConnInfo
-> Maybe (NonEmpty PostgresSourceConnInfo)
-> ExtensionsSchema
-> PostgresConnConfiguration
PostgresConnConfiguration PostgresSourceConnInfo
sourceConnInfo Maybe (NonEmpty PostgresSourceConnInfo)
forall a. Maybe a
Nothing ExtensionsSchema
defaultPostgresExtensionsSchema
      optimizePermissionFilters :: OptimizePermissionFilters
optimizePermissionFilters
        | ExperimentalFeature
EFOptimizePermissionFilters ExperimentalFeature -> HashSet ExperimentalFeature -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` HashSet ExperimentalFeature
soExperimentalFeatures = OptimizePermissionFilters
Options.OptimizePermissionFilters
        | Bool
otherwise = OptimizePermissionFilters
Options.Don'tOptimizePermissionFilters
      sqlGenCtx :: SQLGenCtx
sqlGenCtx = StringifyNumbers
-> DangerouslyCollapseBooleans
-> OptimizePermissionFilters
-> SQLGenCtx
SQLGenCtx StringifyNumbers
soStringifyNum DangerouslyCollapseBooleans
soDangerousBooleanCollapse OptimizePermissionFilters
optimizePermissionFilters

  let serverConfigCtx :: ServerConfigCtx
serverConfigCtx =
        InferFunctionPermissions
-> RemoteSchemaPermissions
-> SQLGenCtx
-> MaintenanceMode ()
-> HashSet ExperimentalFeature
-> EventingMode
-> ReadOnlyMode
-> Maybe NamingCase
-> ServerConfigCtx
ServerConfigCtx
          InferFunctionPermissions
soInferFunctionPermissions
          RemoteSchemaPermissions
soEnableRemoteSchemaPermissions
          SQLGenCtx
sqlGenCtx
          MaintenanceMode ()
soEnableMaintenanceMode
          HashSet ExperimentalFeature
soExperimentalFeatures
          EventingMode
soEventingMode
          ReadOnlyMode
soReadOnlyMode
          Maybe NamingCase
soDefaultNamingConvention

  Manager
schemaCacheHttpManager <- IO Manager -> ManagedT m Manager
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
$ ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.tlsManagerSettings
  RebuildableSchemaCache
rebuildableSchemaCache <-
    m RebuildableSchemaCache -> ManagedT m RebuildableSchemaCache
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m RebuildableSchemaCache -> ManagedT m RebuildableSchemaCache)
-> (m RebuildableSchemaCache -> m RebuildableSchemaCache)
-> m RebuildableSchemaCache
-> ManagedT m RebuildableSchemaCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m RebuildableSchemaCache -> m () -> m RebuildableSchemaCache)
-> m () -> m RebuildableSchemaCache -> m RebuildableSchemaCache
forall a b c. (a -> b -> c) -> b -> a -> c
flip m RebuildableSchemaCache -> m () -> m RebuildableSchemaCache
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
onException (LoggerCtx Hasura -> m ()
forall (m :: * -> *) impl. MonadIO m => LoggerCtx impl -> m ()
flushLogger LoggerCtx Hasura
loggerCtx) (m RebuildableSchemaCache -> ManagedT m RebuildableSchemaCache)
-> m RebuildableSchemaCache -> ManagedT m RebuildableSchemaCache
forall a b. (a -> b) -> a -> b
$
      Environment
-> Logger Hasura
-> PGPool
-> Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> Manager
-> ServerConfigCtx
-> SourceResolver ('Postgres 'Vanilla)
-> SourceResolver 'MSSQL
-> ExtensionsSchema
-> m RebuildableSchemaCache
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
Environment
-> Logger Hasura
-> PGPool
-> Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> Manager
-> ServerConfigCtx
-> SourceResolver ('Postgres 'Vanilla)
-> SourceResolver 'MSSQL
-> ExtensionsSchema
-> m RebuildableSchemaCache
migrateCatalogSchema
        Environment
env
        Logger Hasura
logger
        PGPool
metadataDbPool
        Maybe PostgresConnConfiguration
Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
maybeDefaultSourceConfig
        Manager
schemaCacheHttpManager
        ServerConfigCtx
serverConfigCtx
        (PGLogger -> SourceResolver ('Postgres 'Vanilla)
mkPgSourceResolver PGLogger
pgLogger)
        SourceResolver 'MSSQL
mkMSSQLSourceResolver
        ExtensionsSchema
soExtensionsSchema

  -- Start a background thread for listening schema sync events from other server instances,
  TMVar MetadataResourceVersion
metaVersionRef <- IO (TMVar MetadataResourceVersion)
-> ManagedT m (TMVar MetadataResourceVersion)
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

  -- An interval of 0 indicates that no schema sync is required
  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
$ LogLevel -> Text -> String -> StartupLog
mkGenericStrLog LogLevel
LevelInfo Text
"schema-sync" String
"Schema sync disabled"
    Interval 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
$ LogLevel -> Text -> String -> StartupLog
mkGenericStrLog LogLevel
LevelInfo Text
"schema-sync" (String
"Schema sync enabled. Polling at " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NonNegative Milliseconds -> String
forall a. Show a => a -> String
show 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
-> NonNegative Milliseconds
-> TMVar MetadataResourceVersion
-> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
Logger Hasura
-> PGPool
-> InstanceId
-> NonNegative Milliseconds
-> TMVar MetadataResourceVersion
-> ManagedT m Thread
startSchemaSyncListenerThread Logger Hasura
logger PGPool
metadataDbPool InstanceId
instanceId NonNegative Milliseconds
interval TMVar MetadataResourceVersion
metaVersionRef

  SchemaCacheRef
schemaCacheRef <- ServerMetrics
-> RebuildableSchemaCache -> ManagedT m SchemaCacheRef
forall (m :: * -> *).
MonadIO m =>
ServerMetrics -> RebuildableSchemaCache -> m SchemaCacheRef
initialiseSchemaCacheRef ServerMetrics
serverMetrics RebuildableSchemaCache
rebuildableSchemaCache

  Manager
srvMgr <- IO Manager -> ManagedT m Manager
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 (SchemaCacheRef -> IO [TlsAllow]
readTlsAllowlist SchemaCacheRef
schemaCacheRef) Blocklist
forall a. Monoid a => a
mempty

  ServeCtx -> ManagedT m ServeCtx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServeCtx -> ManagedT m ServeCtx)
-> ServeCtx -> ManagedT m ServeCtx
forall a b. (a -> b) -> a -> b
$
    Manager
-> InstanceId
-> Loggers
-> HashSet (EngineLogType Hasura)
-> PGPool
-> ShutdownLatch
-> RebuildableSchemaCache
-> SchemaCacheRef
-> TMVar MetadataResourceVersion
-> ServeCtx
ServeCtx
      Manager
srvMgr
      InstanceId
instanceId
      Loggers
loggers
      HashSet (EngineLogType Hasura)
soEnabledLogTypes
      PGPool
metadataDbPool
      ShutdownLatch
latch
      RebuildableSchemaCache
rebuildableSchemaCache
      SchemaCacheRef
schemaCacheRef
      TMVar MetadataResourceVersion
metaVersionRef

mkLoggers ::
  (MonadIO m, MonadBaseControl IO m) =>
  HashSet (EngineLogType Hasura) ->
  LogLevel ->
  ManagedT m Loggers
mkLoggers :: 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 (m :: * -> *) a. Monad m => a -> m a
return (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

-- | helper function to initialize or migrate the @hdb_catalog@ schema (used by pro as well)
migrateCatalogSchema ::
  (MonadIO m, MonadBaseControl IO m) =>
  Env.Environment ->
  Logger Hasura ->
  Q.PGPool ->
  Maybe (SourceConnConfiguration ('Postgres 'Vanilla)) ->
  HTTP.Manager ->
  ServerConfigCtx ->
  SourceResolver ('Postgres 'Vanilla) ->
  SourceResolver ('MSSQL) ->
  ExtensionsSchema ->
  m RebuildableSchemaCache
migrateCatalogSchema :: Environment
-> Logger Hasura
-> PGPool
-> Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> Manager
-> ServerConfigCtx
-> SourceResolver ('Postgres 'Vanilla)
-> SourceResolver 'MSSQL
-> ExtensionsSchema
-> m RebuildableSchemaCache
migrateCatalogSchema
  Environment
env
  Logger Hasura
logger
  PGPool
pool
  Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
defaultSourceConfig
  Manager
httpManager
  ServerConfigCtx
serverConfigCtx
  SourceResolver ('Postgres 'Vanilla)
pgSourceResolver
  SourceResolver 'MSSQL
mssqlSourceResolver
  ExtensionsSchema
extensionsSchema = do
    Either QErr (MigrationResult, RebuildableSchemaCache)
initialiseResult <- ExceptT QErr m (MigrationResult, RebuildableSchemaCache)
-> m (Either QErr (MigrationResult, RebuildableSchemaCache))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m (MigrationResult, RebuildableSchemaCache)
 -> m (Either QErr (MigrationResult, RebuildableSchemaCache)))
-> ExceptT QErr m (MigrationResult, RebuildableSchemaCache)
-> m (Either QErr (MigrationResult, RebuildableSchemaCache))
forall a b. (a -> b) -> a -> b
$ 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 -> ExceptT QErr m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Clock.getCurrentTime
      (MigrationResult
migrationResult, Metadata
metadata) <-
        PGPool
-> TxMode
-> TxET QErr m (MigrationResult, Metadata)
-> ExceptT QErr m (MigrationResult, Metadata)
forall (m :: * -> *) e a.
(MonadIO m, MonadBaseControl IO m, FromPGTxErr e,
 FromPGConnErr e) =>
PGPool -> TxMode -> TxET e m a -> ExceptT e m a
Q.runTx PGPool
pool (TxIsolation
Q.Serializable, TxAccess -> Maybe TxAccess
forall a. a -> Maybe a
Just TxAccess
Q.ReadWrite) (TxET QErr m (MigrationResult, Metadata)
 -> ExceptT QErr m (MigrationResult, Metadata))
-> TxET QErr m (MigrationResult, Metadata)
-> ExceptT QErr m (MigrationResult, Metadata)
forall a b. (a -> b) -> a -> b
$
          Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> ExtensionsSchema
-> MaintenanceMode ()
-> UTCTime
-> TxET QErr m (MigrationResult, Metadata)
forall (m :: * -> *).
(MonadTx m, MonadIO m, MonadBaseControl IO m) =>
Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
-> ExtensionsSchema
-> MaintenanceMode ()
-> UTCTime
-> m (MigrationResult, Metadata)
migrateCatalog
            Maybe (SourceConnConfiguration ('Postgres 'Vanilla))
defaultSourceConfig
            ExtensionsSchema
extensionsSchema
            (ServerConfigCtx -> MaintenanceMode ()
_sccMaintenanceMode ServerConfigCtx
serverConfigCtx)
            UTCTime
currentTime
      let cacheBuildParams :: CacheBuildParams
cacheBuildParams =
            Manager
-> SourceResolver ('Postgres 'Vanilla)
-> SourceResolver 'MSSQL
-> ServerConfigCtx
-> CacheBuildParams
CacheBuildParams Manager
httpManager SourceResolver ('Postgres 'Vanilla)
pgSourceResolver SourceResolver 'MSSQL
mssqlSourceResolver ServerConfigCtx
serverConfigCtx
          buildReason :: BuildReason
buildReason = BuildReason
CatalogSync
      RebuildableSchemaCache
schemaCache <-
        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
$
          BuildReason
-> Logger Hasura
-> Environment
-> Metadata
-> CacheBuild RebuildableSchemaCache
buildRebuildableSchemaCacheWithReason BuildReason
buildReason Logger Hasura
logger Environment
env Metadata
metadata
      (MigrationResult, RebuildableSchemaCache)
-> ExceptT QErr m (MigrationResult, RebuildableSchemaCache)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MigrationResult
migrationResult, RebuildableSchemaCache
schemaCache)

    (MigrationResult
migrationResult, RebuildableSchemaCache
schemaCache) <-
      Either QErr (MigrationResult, RebuildableSchemaCache)
initialiseResult Either QErr (MigrationResult, RebuildableSchemaCache)
-> (QErr -> m (MigrationResult, RebuildableSchemaCache))
-> m (MigrationResult, RebuildableSchemaCache)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` \QErr
err -> do
        Logger Hasura -> StartupLog -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger
          Logger Hasura
logger
          StartupLog :: LogLevel -> Text -> Value -> StartupLog
StartupLog
            { slLogLevel :: LogLevel
slLogLevel = LogLevel
LevelError,
              slKind :: Text
slKind = Text
"catalog_migrate",
              slInfo :: Value
slInfo = QErr -> Value
forall a. ToJSON a => a -> Value
A.toJSON QErr
err
            }
        IO (MigrationResult, RebuildableSchemaCache)
-> m (MigrationResult, RebuildableSchemaCache)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExitCode -> QErr -> IO (MigrationResult, RebuildableSchemaCache)
forall a (m :: * -> *) b.
(ToJSON a, MonadIO m) =>
ExitCode -> a -> m b
throwErrJExit ExitCode
DatabaseMigrationError QErr
err)
    Logger Hasura -> MigrationResult -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger MigrationResult
migrationResult
    RebuildableSchemaCache -> m RebuildableSchemaCache
forall (f :: * -> *) a. Applicative f => a -> f a
pure RebuildableSchemaCache
schemaCache

-- | A latch for the graceful shutdown of a server process.
newtype ShutdownLatch = ShutdownLatch {ShutdownLatch -> MVar ()
unShutdownLatch :: C.MVar ()}

-- | 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 (MetadataStorageT IO ())

newShutdownLatch :: IO ShutdownLatch
newShutdownLatch :: IO ShutdownLatch
newShutdownLatch = (MVar () -> ShutdownLatch) -> IO (MVar ()) -> IO ShutdownLatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVar () -> ShutdownLatch
ShutdownLatch IO (MVar ())
forall a. IO (MVar a)
C.newEmptyMVar

-- | Block the current thread, waiting on the latch.
waitForShutdown :: ShutdownLatch -> IO ()
waitForShutdown :: ShutdownLatch -> IO ()
waitForShutdown = MVar () -> IO ()
forall a. MVar a -> IO a
C.readMVar (MVar () -> IO ())
-> (ShutdownLatch -> MVar ()) -> ShutdownLatch -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShutdownLatch -> MVar ()
unShutdownLatch

-- | Initiate a graceful shutdown of the server associated with the provided
-- latch.
shutdownGracefully :: ShutdownLatch -> IO ()
shutdownGracefully :: ShutdownLatch -> IO ()
shutdownGracefully = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ())
-> (ShutdownLatch -> IO Bool) -> ShutdownLatch -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar () -> () -> IO Bool) -> () -> MVar () -> IO Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
C.tryPutMVar () (MVar () -> IO Bool)
-> (ShutdownLatch -> MVar ()) -> ShutdownLatch -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShutdownLatch -> MVar ()
unShutdownLatch

-- | Returns True if the latch is set for shutdown and vice-versa
shuttingDown :: ShutdownLatch -> IO Bool
shuttingDown :: ShutdownLatch -> IO Bool
shuttingDown ShutdownLatch
latch = Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar () -> IO Bool
forall a. MVar a -> IO Bool
C.isEmptyMVar (ShutdownLatch -> MVar ()
unShutdownLatch ShutdownLatch
latch)

-- | If an exception is encountered , flush the log buffer and
-- rethrow If we do not flush the log buffer on exception, then log lines
-- may be missed
-- See: https://github.com/hasura/graphql-engine/issues/4772
flushLogger :: MonadIO m => LoggerCtx impl -> m ()
flushLogger :: LoggerCtx impl -> m ()
flushLogger = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (LoggerCtx impl -> IO ()) -> LoggerCtx impl -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerSet -> IO ()
FL.flushLogStr (LoggerSet -> IO ())
-> (LoggerCtx impl -> LoggerSet) -> LoggerCtx impl -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerCtx impl -> LoggerSet
forall impl. LoggerCtx impl -> LoggerSet
_lcLoggerSet

-- | 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" -}
runHGEServer ::
  forall m impl.
  ( MonadIO m,
    MonadFix m,
    MonadMask m,
    MonadStateless IO m,
    LA.Forall (LA.Pure m),
    UserAuthentication (Tracing.TraceT m),
    HttpLog m,
    ConsoleRenderer m,
    MonadMetadataApiAuthorization m,
    MonadGQLExecutionCheck m,
    MonadConfigApiHandler m,
    MonadQueryLog m,
    WS.MonadWSLog m,
    MonadExecuteQuery m,
    Tracing.HasReporter m,
    HasResourceLimits m,
    MonadMetadataStorage (MetadataStorageT m),
    MonadResolveSource m,
    EB.MonadQueryTags m
  ) =>
  (ServerCtx -> Spock.SpockT m ()) ->
  Env.Environment ->
  ServeOptions impl ->
  ServeCtx ->
  -- and mutations

  -- | start time
  UTCTime ->
  Maybe ES.SubscriptionPostPollHook ->
  ServerMetrics ->
  EKG.Store EKG.EmptyMetrics ->
  -- | A hook which can be called to indicate when the server is started succesfully
  Maybe (IO ()) ->
  PrometheusMetrics ->
  ManagedT m ()
runHGEServer :: (ServerCtx -> SpockT m ())
-> Environment
-> ServeOptions impl
-> ServeCtx
-> UTCTime
-> Maybe SubscriptionPostPollHook
-> ServerMetrics
-> Store EmptyMetrics
-> Maybe (IO ())
-> PrometheusMetrics
-> ManagedT m ()
runHGEServer ServerCtx -> SpockT m ()
setupHook Environment
env ServeOptions impl
serveOptions ServeCtx
serveCtx UTCTime
initTime Maybe SubscriptionPostPollHook
postPollHook ServerMetrics
serverMetrics Store EmptyMetrics
ekgStore Maybe (IO ())
startupStatusHook PrometheusMetrics
prometheusMetrics = do
  Application
waiApplication <-
    (ServerCtx -> SpockT m ())
-> Environment
-> ServeOptions impl
-> ServeCtx
-> UTCTime
-> Maybe SubscriptionPostPollHook
-> ServerMetrics
-> Store EmptyMetrics
-> PrometheusMetrics
-> ManagedT m Application
forall (m :: * -> *) impl.
(MonadIO m, MonadFix m, MonadMask m, MonadStateless IO m,
 Forall (Pure m), UserAuthentication (TraceT m), HttpLog m,
 ConsoleRenderer m, MonadMetadataApiAuthorization m,
 MonadGQLExecutionCheck m, MonadConfigApiHandler m, MonadQueryLog m,
 MonadWSLog m, MonadExecuteQuery m, HasReporter m,
 HasResourceLimits m, MonadMetadataStorage (MetadataStorageT m),
 MonadResolveSource m, MonadQueryTags m) =>
(ServerCtx -> SpockT m ())
-> Environment
-> ServeOptions impl
-> ServeCtx
-> UTCTime
-> Maybe SubscriptionPostPollHook
-> ServerMetrics
-> Store EmptyMetrics
-> PrometheusMetrics
-> ManagedT m Application
mkHGEServer ServerCtx -> SpockT m ()
setupHook Environment
env ServeOptions impl
serveOptions ServeCtx
serveCtx UTCTime
initTime Maybe SubscriptionPostPollHook
postPollHook ServerMetrics
serverMetrics Store EmptyMetrics
ekgStore PrometheusMetrics
prometheusMetrics

  -- `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 -> Int) -> Port -> Int
forall a b. (a -> b) -> a -> b
$ ServeOptions impl -> Port
forall impl. ServeOptions impl -> Port
soPort ServeOptions impl
serveOptions)
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostPreference -> Settings -> Settings
Warp.setHost (ServeOptions impl -> HostPreference
forall impl. ServeOptions impl -> HostPreference
soHost ServeOptions impl
serveOptions)
          (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 (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
onJust 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
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
serverMetrics)
                      ConnectionsGauge -> IO ()
incWarpThreads (PrometheusMetrics -> ConnectionsGauge
pmConnections PrometheusMetrics
prometheusMetrics)
                  )
                  ( do
                      Gauge -> IO ()
EKG.Gauge.dec (ServerMetrics -> Gauge
smWarpThreads ServerMetrics
serverMetrics)
                      ConnectionsGauge -> IO ()
decWarpThreads (PrometheusMetrics -> ConnectionsGauge
pmConnections PrometheusMetrics
prometheusMetrics)
                  )
                  ((forall a. IO a -> IO a) -> IO ()
f 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 -> IO ()) -> ShutdownLatch -> IO ()
forall a b. (a -> b) -> a -> b
$ ServeCtx -> ShutdownLatch
_scShutdownLatch ServeCtx
serveCtx
          let logger :: Logger Hasura
logger = Loggers -> Logger Hasura
_lsLogger (Loggers -> Logger Hasura) -> Loggers -> Logger Hasura
forall a b. (a -> b) -> a -> b
$ ServeCtx -> Loggers
_scLoggers ServeCtx
serveCtx
          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
$ LogLevel -> Text -> String -> StartupLog
mkGenericStrLog LogLevel
LevelInfo Text
"server" String
"gracefully shutting down server"
          IO ()
closeSocket

  -- 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 (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 (Tracing.TraceT m),
    HttpLog m,
    ConsoleRenderer m,
    MonadMetadataApiAuthorization m,
    MonadGQLExecutionCheck m,
    MonadConfigApiHandler m,
    MonadQueryLog m,
    WS.MonadWSLog m,
    MonadExecuteQuery m,
    Tracing.HasReporter m,
    HasResourceLimits m,
    MonadMetadataStorage (MetadataStorageT m),
    MonadResolveSource m,
    EB.MonadQueryTags m
  ) =>
  (ServerCtx -> Spock.SpockT m ()) ->
  Env.Environment ->
  ServeOptions impl ->
  ServeCtx ->
  -- and mutations

  -- | start time
  UTCTime ->
  Maybe ES.SubscriptionPostPollHook ->
  ServerMetrics ->
  EKG.Store EKG.EmptyMetrics ->
  PrometheusMetrics ->
  ManagedT m Application
mkHGEServer :: (ServerCtx -> SpockT m ())
-> Environment
-> ServeOptions impl
-> ServeCtx
-> UTCTime
-> Maybe SubscriptionPostPollHook
-> ServerMetrics
-> Store EmptyMetrics
-> PrometheusMetrics
-> ManagedT m Application
mkHGEServer ServerCtx -> SpockT m ()
setupHook Environment
env ServeOptions {Bool
[JWTConfig]
Maybe Text
Maybe RoleName
Maybe NamingCase
Maybe AuthHook
HashSet (EngineLogType impl)
HashSet ExperimentalFeature
HashSet AdminSecretHash
HashSet API
LogLevel
RemoteSchemaPermissions
InferFunctionPermissions
DangerouslyCollapseBooleans
StringifyNumbers
ConnParams
TxIsolation
CorsConfig
ExtensionsSchema
PositiveInt
NonNegativeInt
NonNegative Milliseconds
NonNegative Seconds
StreamQueriesOptions
EventingMode
ReadOnlyMode
MaintenanceMode ()
MetadataQueryLoggingMode
HostPreference
ConnectionOptions
ResponseInternalErrorsConfig
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
soExtensionsSchema :: ExtensionsSchema
soDefaultNamingConvention :: Maybe NamingCase
soEnableMetadataQueryLogging :: MetadataQueryLoggingMode
soReadOnlyMode :: ReadOnlyMode
soEventingMode :: EventingMode
soWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
soGracefulShutdownTimeout :: NonNegative Seconds
soDevMode :: Bool
soEventsFetchBatchSize :: NonNegativeInt
soExperimentalFeatures :: HashSet ExperimentalFeature
soSchemaPollInterval :: OptionalInterval
soEnableMaintenanceMode :: MaintenanceMode ()
soInferFunctionPermissions :: InferFunctionPermissions
soWebSocketKeepAlive :: KeepAliveDelay
soConnectionOptions :: ConnectionOptions
soEnableRemoteSchemaPermissions :: RemoteSchemaPermissions
soAsyncActionsFetchInterval :: OptionalInterval
soEventsFetchInterval :: NonNegative Milliseconds
soEventsHttpPoolSize :: PositiveInt
soResponseInternalErrorsConfig :: ResponseInternalErrorsConfig
soLogLevel :: LogLevel
soEnabledLogTypes :: HashSet (EngineLogType impl)
soEnableAllowlist :: Bool
soStreamingQueryOpts :: StreamQueriesOptions
soLiveQueryOpts :: StreamQueriesOptions
soEnabledAPIs :: HashSet API
soDangerousBooleanCollapse :: DangerouslyCollapseBooleans
soStringifyNum :: StringifyNumbers
soEnableTelemetry :: Bool
soConsoleAssetsDir :: Maybe Text
soEnableConsole :: Bool
soCorsConfig :: CorsConfig
soUnAuthRole :: Maybe RoleName
soJwtSecret :: [JWTConfig]
soAuthHook :: Maybe AuthHook
soAdminSecret :: HashSet AdminSecretHash
soTxIso :: TxIsolation
soConnParams :: ConnParams
soHost :: HostPreference
soPort :: Port
soExtensionsSchema :: forall impl. ServeOptions impl -> ExtensionsSchema
soDefaultNamingConvention :: forall impl. ServeOptions impl -> Maybe NamingCase
soEnableMetadataQueryLogging :: forall impl. ServeOptions impl -> MetadataQueryLoggingMode
soReadOnlyMode :: forall impl. ServeOptions impl -> ReadOnlyMode
soEventingMode :: forall impl. ServeOptions impl -> EventingMode
soWebSocketConnectionInitTimeout :: forall impl. ServeOptions impl -> WSConnectionInitTimeout
soGracefulShutdownTimeout :: forall impl. ServeOptions impl -> NonNegative Seconds
soDevMode :: forall impl. ServeOptions impl -> Bool
soEventsFetchBatchSize :: forall impl. ServeOptions impl -> NonNegativeInt
soExperimentalFeatures :: forall impl. ServeOptions impl -> HashSet ExperimentalFeature
soSchemaPollInterval :: forall impl. ServeOptions impl -> OptionalInterval
soEnableMaintenanceMode :: forall impl. ServeOptions impl -> MaintenanceMode ()
soInferFunctionPermissions :: forall impl. ServeOptions impl -> InferFunctionPermissions
soWebSocketKeepAlive :: forall impl. ServeOptions impl -> KeepAliveDelay
soConnectionOptions :: forall impl. ServeOptions impl -> ConnectionOptions
soEnableRemoteSchemaPermissions :: forall impl. ServeOptions impl -> RemoteSchemaPermissions
soAsyncActionsFetchInterval :: forall impl. ServeOptions impl -> OptionalInterval
soEventsFetchInterval :: forall impl. ServeOptions impl -> NonNegative Milliseconds
soEventsHttpPoolSize :: forall impl. ServeOptions impl -> PositiveInt
soResponseInternalErrorsConfig :: forall impl. ServeOptions impl -> ResponseInternalErrorsConfig
soLogLevel :: forall impl. ServeOptions impl -> LogLevel
soEnabledLogTypes :: forall impl. ServeOptions impl -> HashSet (EngineLogType impl)
soEnableAllowlist :: forall impl. ServeOptions impl -> Bool
soStreamingQueryOpts :: forall impl. ServeOptions impl -> StreamQueriesOptions
soLiveQueryOpts :: forall impl. ServeOptions impl -> StreamQueriesOptions
soEnabledAPIs :: forall impl. ServeOptions impl -> HashSet API
soDangerousBooleanCollapse :: forall impl. ServeOptions impl -> DangerouslyCollapseBooleans
soStringifyNum :: forall impl. ServeOptions impl -> StringifyNumbers
soEnableTelemetry :: forall impl. ServeOptions impl -> Bool
soConsoleAssetsDir :: forall impl. ServeOptions impl -> Maybe Text
soEnableConsole :: forall impl. ServeOptions impl -> Bool
soCorsConfig :: forall impl. ServeOptions impl -> CorsConfig
soUnAuthRole :: forall impl. ServeOptions impl -> Maybe RoleName
soJwtSecret :: forall impl. ServeOptions impl -> [JWTConfig]
soAuthHook :: forall impl. ServeOptions impl -> Maybe AuthHook
soAdminSecret :: forall impl. ServeOptions impl -> HashSet AdminSecretHash
soTxIso :: forall impl. ServeOptions impl -> TxIsolation
soConnParams :: forall impl. ServeOptions impl -> ConnParams
soHost :: forall impl. ServeOptions impl -> HostPreference
soPort :: forall impl. ServeOptions impl -> Port
..} ServeCtx {TMVar MetadataResourceVersion
HashSet (EngineLogType Hasura)
PGPool
Manager
InstanceId
RebuildableSchemaCache
SchemaCacheRef
ShutdownLatch
Loggers
_scMetaVersionRef :: TMVar MetadataResourceVersion
_scSchemaCacheRef :: SchemaCacheRef
_scSchemaCache :: RebuildableSchemaCache
_scShutdownLatch :: ShutdownLatch
_scMetadataDbPool :: PGPool
_scEnabledLogTypes :: HashSet (EngineLogType Hasura)
_scLoggers :: Loggers
_scInstanceId :: InstanceId
_scHttpManager :: Manager
_scMetaVersionRef :: ServeCtx -> TMVar MetadataResourceVersion
_scSchemaCacheRef :: ServeCtx -> SchemaCacheRef
_scSchemaCache :: ServeCtx -> RebuildableSchemaCache
_scEnabledLogTypes :: ServeCtx -> HashSet (EngineLogType Hasura)
_scInstanceId :: ServeCtx -> InstanceId
_scHttpManager :: ServeCtx -> Manager
_scShutdownLatch :: ServeCtx -> ShutdownLatch
_scMetadataDbPool :: ServeCtx -> PGPool
_scLoggers :: ServeCtx -> Loggers
..} UTCTime
initTime Maybe SubscriptionPostPollHook
postPollHook ServerMetrics
serverMetrics Store EmptyMetrics
ekgStore PrometheusMetrics
prometheusMetrics = 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
disableAssertNF

  let optimizePermissionFilters :: OptimizePermissionFilters
optimizePermissionFilters
        | ExperimentalFeature
EFOptimizePermissionFilters ExperimentalFeature -> HashSet ExperimentalFeature -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` HashSet ExperimentalFeature
soExperimentalFeatures = OptimizePermissionFilters
Options.OptimizePermissionFilters
        | Bool
otherwise = OptimizePermissionFilters
Options.Don'tOptimizePermissionFilters
      sqlGenCtx :: SQLGenCtx
sqlGenCtx = StringifyNumbers
-> DangerouslyCollapseBooleans
-> OptimizePermissionFilters
-> SQLGenCtx
SQLGenCtx StringifyNumbers
soStringifyNum DangerouslyCollapseBooleans
soDangerousBooleanCollapse OptimizePermissionFilters
optimizePermissionFilters
      Loggers LoggerCtx Hasura
loggerCtx Logger Hasura
logger PGLogger
_ = Loggers
_scLoggers

  Either Text AuthMode
authModeRes <-
    ExceptT Text (ManagedT m) AuthMode
-> ManagedT m (Either Text AuthMode)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text (ManagedT m) AuthMode
 -> ManagedT m (Either Text AuthMode))
-> ExceptT Text (ManagedT m) AuthMode
-> ManagedT m (Either Text AuthMode)
forall a b. (a -> b) -> a -> b
$
      HashSet AdminSecretHash
-> Maybe AuthHook
-> [JWTConfig]
-> Maybe RoleName
-> Manager
-> Logger Hasura
-> ExceptT Text (ManagedT m) AuthMode
forall (m :: * -> *).
(ForkableMonadIO m, HasReporter m) =>
HashSet AdminSecretHash
-> Maybe AuthHook
-> [JWTConfig]
-> Maybe RoleName
-> Manager
-> Logger Hasura
-> ExceptT Text (ManagedT m) AuthMode
setupAuthMode
        HashSet AdminSecretHash
soAdminSecret
        Maybe AuthHook
soAuthHook
        [JWTConfig]
soJwtSecret
        Maybe RoleName
soUnAuthRole
        Manager
_scHttpManager
        Logger Hasura
logger

  AuthMode
authMode <- Either Text AuthMode
-> (Text -> ManagedT m AuthMode) -> ManagedT m AuthMode
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either Text AuthMode
authModeRes (ExitCode -> String -> ManagedT m AuthMode
forall (m :: * -> *) a. MonadIO m => ExitCode -> String -> m a
throwErrExit ExitCode
AuthConfigurationError (String -> ManagedT m AuthMode)
-> (Text -> String) -> Text -> ManagedT m AuthMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)

  HasuraApp Application
app SchemaCacheRef
cacheRef AsyncActionSubscriptionState
actionSubState IO ()
stopWsServer <-
    m HasuraApp -> ManagedT m HasuraApp
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
$
      (m HasuraApp -> m () -> m HasuraApp)
-> m () -> m HasuraApp -> m HasuraApp
forall a b c. (a -> b -> c) -> b -> a -> c
flip m HasuraApp -> m () -> m HasuraApp
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
onException (LoggerCtx Hasura -> m ()
forall (m :: * -> *) impl. MonadIO m => LoggerCtx impl -> m ()
flushLogger LoggerCtx Hasura
loggerCtx) (m HasuraApp -> m HasuraApp) -> m HasuraApp -> m HasuraApp
forall a b. (a -> b) -> a -> b
$
        (ServerCtx -> SpockT m ())
-> Environment
-> Logger Hasura
-> SQLGenCtx
-> Bool
-> Manager
-> AuthMode
-> CorsConfig
-> Bool
-> Maybe Text
-> Bool
-> InstanceId
-> HashSet API
-> StreamQueriesOptions
-> StreamQueriesOptions
-> ResponseInternalErrorsConfig
-> Maybe SubscriptionPostPollHook
-> SchemaCacheRef
-> Store EmptyMetrics
-> ServerMetrics
-> PrometheusMetrics
-> RemoteSchemaPermissions
-> InferFunctionPermissions
-> ConnectionOptions
-> KeepAliveDelay
-> MaintenanceMode ()
-> EventingMode
-> ReadOnlyMode
-> HashSet ExperimentalFeature
-> HashSet (EngineLogType Hasura)
-> WSConnectionInitTimeout
-> MetadataQueryLoggingMode
-> Maybe NamingCase
-> m HasuraApp
forall (m :: * -> *).
(MonadIO m, MonadFix m, MonadStateless IO m, Forall (Pure m),
 ConsoleRenderer m, HttpLog m, UserAuthentication (TraceT m),
 MonadMetadataApiAuthorization m, MonadGQLExecutionCheck m,
 MonadConfigApiHandler m, MonadQueryLog m, MonadWSLog m,
 HasReporter m, MonadExecuteQuery m, HasResourceLimits m,
 MonadMetadataStorage (MetadataStorageT m), MonadResolveSource m,
 MonadQueryTags m) =>
(ServerCtx -> SpockT m ())
-> Environment
-> Logger Hasura
-> SQLGenCtx
-> Bool
-> Manager
-> AuthMode
-> CorsConfig
-> Bool
-> Maybe Text
-> Bool
-> InstanceId
-> HashSet API
-> StreamQueriesOptions
-> StreamQueriesOptions
-> ResponseInternalErrorsConfig
-> Maybe SubscriptionPostPollHook
-> SchemaCacheRef
-> Store EmptyMetrics
-> ServerMetrics
-> PrometheusMetrics
-> RemoteSchemaPermissions
-> InferFunctionPermissions
-> ConnectionOptions
-> KeepAliveDelay
-> MaintenanceMode ()
-> EventingMode
-> ReadOnlyMode
-> HashSet ExperimentalFeature
-> HashSet (EngineLogType Hasura)
-> WSConnectionInitTimeout
-> MetadataQueryLoggingMode
-> Maybe NamingCase
-> m HasuraApp
mkWaiApp
          ServerCtx -> SpockT m ()
setupHook
          Environment
env
          Logger Hasura
logger
          SQLGenCtx
sqlGenCtx
          Bool
soEnableAllowlist
          Manager
_scHttpManager
          AuthMode
authMode
          CorsConfig
soCorsConfig
          Bool
soEnableConsole
          Maybe Text
soConsoleAssetsDir
          Bool
soEnableTelemetry
          InstanceId
_scInstanceId
          HashSet API
soEnabledAPIs
          StreamQueriesOptions
soLiveQueryOpts
          StreamQueriesOptions
soStreamingQueryOpts
          ResponseInternalErrorsConfig
soResponseInternalErrorsConfig
          Maybe SubscriptionPostPollHook
postPollHook
          SchemaCacheRef
_scSchemaCacheRef
          Store EmptyMetrics
ekgStore
          ServerMetrics
serverMetrics
          PrometheusMetrics
prometheusMetrics
          RemoteSchemaPermissions
soEnableRemoteSchemaPermissions
          InferFunctionPermissions
soInferFunctionPermissions
          ConnectionOptions
soConnectionOptions
          KeepAliveDelay
soWebSocketKeepAlive
          MaintenanceMode ()
soEnableMaintenanceMode
          EventingMode
soEventingMode
          ReadOnlyMode
soReadOnlyMode
          HashSet ExperimentalFeature
soExperimentalFeatures
          HashSet (EngineLogType Hasura)
_scEnabledLogTypes
          WSConnectionInitTimeout
soWebSocketConnectionInitTimeout
          MetadataQueryLoggingMode
soEnableMetadataQueryLogging
          Maybe NamingCase
soDefaultNamingConvention

  let serverConfigCtx :: ServerConfigCtx
serverConfigCtx =
        InferFunctionPermissions
-> RemoteSchemaPermissions
-> SQLGenCtx
-> MaintenanceMode ()
-> HashSet ExperimentalFeature
-> EventingMode
-> ReadOnlyMode
-> Maybe NamingCase
-> ServerConfigCtx
ServerConfigCtx
          InferFunctionPermissions
soInferFunctionPermissions
          RemoteSchemaPermissions
soEnableRemoteSchemaPermissions
          SQLGenCtx
sqlGenCtx
          MaintenanceMode ()
soEnableMaintenanceMode
          HashSet ExperimentalFeature
soExperimentalFeatures
          EventingMode
soEventingMode
          ReadOnlyMode
soReadOnlyMode
          Maybe NamingCase
soDefaultNamingConvention

  -- 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
cacheRef)
  IO () -> ManagedT m ()
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
env 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
cacheRef)
  IO () -> ManagedT m ()
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 (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
_ <-
    Logger Hasura
-> Manager
-> TMVar MetadataResourceVersion
-> SchemaCacheRef
-> InstanceId
-> ServerConfigCtx
-> TVar Bool
-> ManagedT m Thread
forall (m :: * -> *).
(ForkableMonadIO m, MonadMetadataStorage (MetadataStorageT m),
 MonadResolveSource m) =>
Logger Hasura
-> Manager
-> TMVar MetadataResourceVersion
-> SchemaCacheRef
-> InstanceId
-> ServerConfigCtx
-> TVar Bool
-> ManagedT m Thread
startSchemaSyncProcessorThread
      Logger Hasura
logger
      Manager
_scHttpManager
      TMVar MetadataResourceVersion
_scMetaVersionRef
      SchemaCacheRef
cacheRef
      InstanceId
_scInstanceId
      ServerConfigCtx
serverConfigCtx
      TVar Bool
newLogTVar

  LockedEventsCtx
lockedEventsCtx <-
    IO LockedEventsCtx -> ManagedT m LockedEventsCtx
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
$
      TVar (Set CronEventId)
-> TVar (Set CronEventId)
-> TVar (HashMap SourceName (Set CronEventId))
-> TVar (Set CronEventId)
-> LockedEventsCtx
LockedEventsCtx
        (TVar (Set CronEventId)
 -> TVar (Set CronEventId)
 -> TVar (HashMap SourceName (Set CronEventId))
 -> TVar (Set CronEventId)
 -> LockedEventsCtx)
-> IO (TVar (Set CronEventId))
-> IO
     (TVar (Set CronEventId)
      -> TVar (HashMap SourceName (Set CronEventId))
      -> TVar (Set CronEventId)
      -> LockedEventsCtx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set CronEventId -> IO (TVar (Set CronEventId))
forall a. a -> IO (TVar a)
STM.newTVarIO Set CronEventId
forall a. Monoid a => a
mempty
        IO
  (TVar (Set CronEventId)
   -> TVar (HashMap SourceName (Set CronEventId))
   -> TVar (Set CronEventId)
   -> LockedEventsCtx)
-> IO (TVar (Set CronEventId))
-> IO
     (TVar (HashMap SourceName (Set CronEventId))
      -> TVar (Set CronEventId) -> LockedEventsCtx)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set CronEventId -> IO (TVar (Set CronEventId))
forall a. a -> IO (TVar a)
STM.newTVarIO Set CronEventId
forall a. Monoid a => a
mempty
        IO
  (TVar (HashMap SourceName (Set CronEventId))
   -> TVar (Set CronEventId) -> LockedEventsCtx)
-> IO (TVar (HashMap SourceName (Set CronEventId)))
-> IO (TVar (Set CronEventId) -> LockedEventsCtx)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
        IO (TVar (Set CronEventId) -> LockedEventsCtx)
-> IO (TVar (Set CronEventId)) -> IO LockedEventsCtx
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set CronEventId -> IO (TVar (Set CronEventId))
forall a. a -> IO (TVar a)
STM.newTVarIO Set CronEventId
forall a. Monoid a => a
mempty

  case EventingMode
soEventingMode of
    EventingMode
EventingEnabled -> do
      Logger Hasura -> LockedEventsCtx -> SchemaCacheRef -> ManagedT m ()
startEventTriggerPollerThread Logger Hasura
logger LockedEventsCtx
lockedEventsCtx SchemaCacheRef
cacheRef
      Logger Hasura
-> LockedEventsCtx
-> SchemaCacheRef
-> AsyncActionSubscriptionState
-> ManagedT m ()
startAsyncActionsPollerThread Logger Hasura
logger LockedEventsCtx
lockedEventsCtx SchemaCacheRef
cacheRef AsyncActionSubscriptionState
actionSubState

      -- 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 -> IO SchemaCache -> m Void
forall (m :: * -> *) void.
(MonadIO m, MonadMetadataStorage (MetadataStorageT m)) =>
Logger Hasura -> IO SchemaCache -> m void
runCronEventsGenerator Logger Hasura
logger (SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
cacheRef)

      Logger Hasura -> LockedEventsCtx -> SchemaCacheRef -> ManagedT m ()
startScheduledEventsPollerThread Logger Hasura
logger LockedEventsCtx
lockedEventsCtx SchemaCacheRef
cacheRef
    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
$ LogLevel -> Text -> String -> StartupLog
mkGenericStrLog LogLevel
LevelInfo Text
"server" String
"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 (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
_scHttpManager

  -- start a background thread for telemetry
  Maybe Thread
_telemetryThread <-
    if Bool
soEnableTelemetry
      then do
        m () -> ManagedT m ()
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
$ LogLevel -> Text -> String -> StartupLog
mkGenericStrLog LogLevel
LevelInfo Text
"telemetry" String
telemetryNotice

        MetadataDbId
dbUid <-
          MetadataStorageT (ManagedT m) MetadataDbId
-> ManagedT m (Either QErr MetadataDbId)
forall (m :: * -> *) a. MetadataStorageT m a -> m (Either QErr a)
runMetadataStorageT MetadataStorageT (ManagedT m) MetadataDbId
forall (m :: * -> *). MonadMetadataStorage m => m MetadataDbId
getMetadataDbUid
            ManagedT m (Either QErr MetadataDbId)
-> (Either QErr MetadataDbId -> ManagedT m MetadataDbId)
-> ManagedT m MetadataDbId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either QErr MetadataDbId
-> (QErr -> ManagedT m MetadataDbId) -> ManagedT m MetadataDbId
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` ExitCode -> QErr -> ManagedT m MetadataDbId
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 (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
Q.runTx PGPool
_scMetadataDbPool (TxIsolation
Q.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)
-> (Either QErr PGVersion -> ManagedT m PGVersion)
-> ManagedT m PGVersion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either QErr PGVersion
-> (QErr -> ManagedT m PGVersion) -> ManagedT m PGVersion
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` ExitCode -> QErr -> ManagedT m PGVersion
forall a (m :: * -> *) b.
(ToJSON a, MonadIO m) =>
ExitCode -> a -> m b
throwErrJExit ExitCode
DatabaseMigrationError)

        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
$
            IO Void -> m Void
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
$ Logger Hasura
-> Manager
-> IO SchemaCache
-> MetadataDbId
-> InstanceId
-> PGVersion
-> IO Void
forall void.
Logger Hasura
-> Manager
-> IO SchemaCache
-> MetadataDbId
-> InstanceId
-> PGVersion
-> IO void
runTelemetry Logger Hasura
logger Manager
_scHttpManager (SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
cacheRef) MetadataDbId
dbUid InstanceId
_scInstanceId PGVersion
pgVersion
        Maybe Thread -> ManagedT m (Maybe Thread)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Thread -> ManagedT m (Maybe Thread))
-> Maybe Thread -> ManagedT m (Maybe Thread)
forall a b. (a -> b) -> a -> b
$ Thread -> Maybe Thread
forall a. a -> Maybe a
Just Thread
telemetryThread
      else Maybe Thread -> ManagedT m (Maybe Thread)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Thread
forall a. Maybe a
Nothing

  UTCTime
finishTime <- IO UTCTime -> ManagedT m UTCTime
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

  -- 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
stopWsServer)

  Application -> ManagedT m Application
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 (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

    prepareScheduledEvents :: Logger impl -> m ()
prepareScheduledEvents (Logger forall a (m :: * -> *).
(ToEngineLog a impl, MonadIO m) =>
a -> m ()
logger) = do
      IO () -> m ()
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
$ LogLevel -> Text -> String -> StartupLog
mkGenericStrLog LogLevel
LevelInfo Text
"scheduled_triggers" String
"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 (m :: * -> *) a. Monad m => a -> m a
return (m (Either QErr ()) -> RetryStatus -> m (Either QErr ()))
-> m (Either QErr ()) -> RetryStatus -> m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ MetadataStorageT m () -> m (Either QErr ())
forall (m :: * -> *) a. MetadataStorageT m a -> m (Either QErr a)
runMetadataStorageT MetadataStorageT m ()
forall (m :: * -> *). MonadMetadataStorage m => m ()
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
$ LogLevel -> Text -> String -> StartupLog
mkGenericStrLog 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 (Set CronEventId)
TVar (HashMap SourceName (Set CronEventId))
leActionEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leEvents :: LockedEventsCtx -> TVar (HashMap SourceName (Set CronEventId))
leOneOffEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leCronEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leActionEvents :: TVar (Set CronEventId)
leEvents :: TVar (HashMap SourceName (Set CronEventId))
leOneOffEvents :: TVar (Set CronEventId)
leCronEvents :: 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 (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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length Set CronEventId
processingCronEvents

    shutdownEventTriggerEvents ::
      [BackendSourceInfo] ->
      Logger Hasura ->
      LockedEventsCtx ->
      IO ()
    shutdownEventTriggerEvents :: [BackendSourceInfo] -> Logger Hasura -> LockedEventsCtx -> IO ()
shutdownEventTriggerEvents [BackendSourceInfo]
sources (Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) LockedEventsCtx {TVar (Set CronEventId)
TVar (HashMap SourceName (Set CronEventId))
leActionEvents :: TVar (Set CronEventId)
leEvents :: TVar (HashMap SourceName (Set CronEventId))
leOneOffEvents :: TVar (Set CronEventId)
leCronEvents :: TVar (Set CronEventId)
leActionEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leEvents :: LockedEventsCtx -> TVar (HashMap SourceName (Set CronEventId))
leOneOffEvents :: LockedEventsCtx -> TVar (Set CronEventId)
leCronEvents :: LockedEventsCtx -> 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
      [BackendSourceInfo] -> (BackendSourceInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [BackendSourceInfo]
sources ((BackendSourceInfo -> IO ()) -> IO ())
-> (BackendSourceInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BackendSourceInfo
backendSourceInfo -> do
        BackendSourceInfo
-> (forall (b :: BackendType).
    BackendEventTrigger b =>
    SourceInfo b -> IO ())
-> IO ()
forall (c :: BackendType -> Constraint) (i :: BackendType -> *) r.
AllBackendsSatisfy c =>
AnyBackend i -> (forall (b :: BackendType). c b => i b -> r) -> r
AB.dispatchAnyBackend @BackendEventTrigger BackendSourceInfo
backendSourceInfo \(SourceInfo SourceName
sourceName TableCache b
_ FunctionCache b
_ SourceConfig b
sourceConfig Maybe QueryTagsConfig
_ SourceCustomization
_ :: SourceInfo b) -> do
          let sourceNameText :: Text
sourceNameText = SourceName -> Text
sourceNameToText SourceName
sourceName
          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 (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
onJust (SourceName
-> HashMap SourceName (Set CronEventId) -> Maybe (Set CronEventId)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup SourceName
sourceName 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 (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
onJust (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 (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
$ SourceConfig b -> NESet CronEventId -> IO (Either QErr Int)
forall (b :: BackendType) (m :: * -> *).
(BackendEventTrigger b, MonadIO m) =>
SourceConfig b -> NESet CronEventId -> m (Either QErr Int)
unlockEventsInSource @b SourceConfig b
sourceConfig 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 ->
      MetadataStorageT m ()
    shutdownAsyncActions :: LockedEventsCtx -> MetadataStorageT m ()
shutdownAsyncActions LockedEventsCtx
lockedEventsCtx = do
      Set CronEventId
lockedActionEvents <- IO (Set CronEventId) -> MetadataStorageT m (Set CronEventId)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set CronEventId) -> MetadataStorageT m (Set CronEventId))
-> IO (Set CronEventId) -> MetadataStorageT 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
      LockedActionIdArray -> MetadataStorageT m ()
forall (m :: * -> *).
MonadMetadataStorage m =>
LockedActionIdArray -> m ()
setProcessingActionLogsToPending ([CronEventId] -> LockedActionIdArray
LockedActionIdArray ([CronEventId] -> LockedActionIdArray)
-> [CronEventId] -> LockedActionIdArray
forall a b. (a -> b) -> a -> b
$ Set CronEventId -> [CronEventId]
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 MetadataStorageT IO ()
metadataDBShutdownAction ->
            MetadataStorageT IO () -> IO (Either QErr ())
forall (m :: * -> *) a. MetadataStorageT m a -> m (Either QErr a)
runMetadataStorageT MetadataStorageT IO ()
metadataDBShutdownAction IO (Either QErr ()) -> (Either QErr () -> IO ()) -> IO ()
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 (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
$
              LogLevel -> Text -> String -> StartupLog
mkGenericStrLog LogLevel
LevelInfo (String -> Text
T.pack String
actionType) (String -> StartupLog) -> String -> StartupLog
forall a b. (a -> b) -> a -> b
$
                String
"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 -> SchemaCacheRef -> ManagedT m ()
startEventTriggerPollerThread Logger Hasura
logger LockedEventsCtx
lockedEventsCtx SchemaCacheRef
cacheRef = do
      let maxEventThreads :: Int
maxEventThreads = PositiveInt -> Int
Numeric.getPositiveInt PositiveInt
soEventsHttpPoolSize
          fetchInterval :: DiffTime
fetchInterval = Milliseconds -> DiffTime
milliseconds (Milliseconds -> DiffTime) -> Milliseconds -> DiffTime
forall a b. (a -> b) -> a -> b
$ NonNegative Milliseconds -> Milliseconds
forall a. NonNegative a -> a
Numeric.getNonNegative NonNegative Milliseconds
soEventsFetchInterval
          allSources :: [BackendSourceInfo]
allSources = SourceCache -> [BackendSourceInfo]
forall k v. HashMap k v -> [v]
HM.elems (SourceCache -> [BackendSourceInfo])
-> SourceCache -> [BackendSourceInfo]
forall a b. (a -> b) -> a -> b
$ SchemaCache -> SourceCache
scSources (SchemaCache -> SourceCache) -> SchemaCache -> SourceCache
forall a b. (a -> b) -> a -> b
$ RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache RebuildableSchemaCache
_scSchemaCache

      Bool -> ManagedT m () -> ManagedT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NonNegativeInt -> Int
Numeric.getNonNegativeInt NonNegativeInt
soEventsFetchBatchSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| DiffTime
fetchInterval DiffTime -> DiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== DiffTime
0) (ManagedT m () -> ManagedT m ()) -> ManagedT m () -> ManagedT m ()
forall a b. (a -> b) -> a -> b
$ do
        -- Don't start the events poller thread when fetchBatchSize or fetchInterval is 0
        -- prepare event triggers data
        EventEngineCtx
eventEngineCtx <- IO EventEngineCtx -> ManagedT m EventEngineCtx
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EventEngineCtx -> ManagedT m EventEngineCtx)
-> IO EventEngineCtx -> ManagedT m EventEngineCtx
forall a b. (a -> b) -> a -> b
$ STM EventEngineCtx -> IO EventEngineCtx
forall a. STM a -> IO a
atomically (STM EventEngineCtx -> IO EventEngineCtx)
-> STM EventEngineCtx -> IO EventEngineCtx
forall a b. (a -> b) -> a -> b
$ Int -> DiffTime -> NonNegativeInt -> STM EventEngineCtx
initEventEngineCtx Int
maxEventThreads DiffTime
fetchInterval NonNegativeInt
soEventsFetchBatchSize
        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 (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 ([BackendSourceInfo] -> Logger Hasura -> LockedEventsCtx -> IO ()
shutdownEventTriggerEvents [BackendSourceInfo]
allSources Logger Hasura
logger LockedEventsCtx
lockedEventsCtx))
                (NonNegative Seconds -> Seconds
forall a. NonNegative a -> a
Numeric.getNonNegative NonNegative Seconds
soGracefulShutdownTimeout)
        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 -> String -> StartupLog
mkGenericStrLog LogLevel
LevelInfo Text
"event_triggers" String
"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 (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
-> Manager
-> IO SchemaCache
-> EventEngineCtx
-> LockedEventsCtx
-> ServerMetrics
-> EventTriggerMetrics
-> MaintenanceMode ()
-> m (Forever m)
forall (m :: * -> *).
(MonadIO m, HasReporter m, MonadBaseControl IO m, Forall (Pure m),
 MonadMask m) =>
Logger Hasura
-> Manager
-> IO SchemaCache
-> EventEngineCtx
-> LockedEventsCtx
-> ServerMetrics
-> EventTriggerMetrics
-> MaintenanceMode ()
-> m (Forever m)
processEventQueue
              Logger Hasura
logger
              Manager
_scHttpManager
              (SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
cacheRef)
              EventEngineCtx
eventEngineCtx
              LockedEventsCtx
lockedEventsCtx
              ServerMetrics
serverMetrics
              (PrometheusMetrics -> EventTriggerMetrics
pmEventTriggerMetrics PrometheusMetrics
prometheusMetrics)
              MaintenanceMode ()
soEnableMaintenanceMode

    startAsyncActionsPollerThread :: Logger Hasura
-> LockedEventsCtx
-> SchemaCacheRef
-> AsyncActionSubscriptionState
-> ManagedT m ()
startAsyncActionsPollerThread Logger Hasura
logger LockedEventsCtx
lockedEventsCtx SchemaCacheRef
cacheRef AsyncActionSubscriptionState
actionSubState = do
      -- start a background thread to handle async actions
      case OptionalInterval
soAsyncActionsFetchInterval of
        OptionalInterval
Skip -> () -> ManagedT m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Don't start the poller thread
        Interval (NonNegative Milliseconds -> Milliseconds
forall a. NonNegative a -> a
Numeric.getNonNegative -> Milliseconds
sleepTime) -> do
          let label :: String
label = String
"asyncActionsProcessor"
              asyncActionGracefulShutdownAction :: m ()
asyncActionGracefulShutdownAction =
                ( ((forall a. m a -> IO a) -> IO ()) -> m ()
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 (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))
                        (MetadataStorageT IO () -> ShutdownAction
MetadataDBShutdownAction ((forall a. m a -> IO a)
-> MetadataStorageT m () -> MetadataStorageT 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
hoist forall a. m a -> IO a
lowerIO (LockedEventsCtx -> MetadataStorageT m ()
shutdownAsyncActions LockedEventsCtx
lockedEventsCtx)))
                        (NonNegative Seconds -> Seconds
forall a. NonNegative a -> a
Numeric.getNonNegative NonNegative Seconds
soGracefulShutdownTimeout)
                    )
                )

          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
$ Environment
-> Logger Hasura
-> IO SchemaCache
-> TVar (Set CronEventId)
-> Manager
-> Milliseconds
-> Maybe GQLQueryText
-> m (Forever m)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, Forall (Pure m), HasReporter m,
 MonadMetadataStorage (MetadataStorageT m)) =>
Environment
-> Logger Hasura
-> IO SchemaCache
-> TVar (Set CronEventId)
-> Manager
-> Milliseconds
-> Maybe GQLQueryText
-> m (Forever m)
asyncActionsProcessor
                Environment
env
                Logger Hasura
logger
                (SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
cacheRef)
                (LockedEventsCtx -> TVar (Set CronEventId)
leActionEvents LockedEventsCtx
lockedEventsCtx)
                Manager
_scHttpManager
                Milliseconds
sleepTime
                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 (MetadataStorageT m)) =>
AsyncActionSubscriptionState -> m void
asyncActionSubscriptionsProcessor AsyncActionSubscriptionState
actionSubState

    startScheduledEventsPollerThread :: Logger Hasura -> LockedEventsCtx -> SchemaCacheRef -> ManagedT m ()
startScheduledEventsPollerThread Logger Hasura
logger LockedEventsCtx
lockedEventsCtx SchemaCacheRef
cacheRef = do
      -- prepare scheduled triggers
      m () -> ManagedT m ()
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 (MetadataStorageT m)) =>
Logger impl -> m ()
prepareScheduledEvents 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 (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)
                    (MetadataStorageT IO () -> ShutdownAction
MetadataDBShutdownAction ((forall a. m a -> IO a)
-> MetadataStorageT m () -> MetadataStorageT 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
hoist forall a. m a -> IO a
lowerIO MetadataStorageT m ()
forall (m :: * -> *). MonadMetadataStorage m => m ()
unlockAllLockedScheduledEvents))
                    (NonNegative Seconds -> Seconds
forall a. NonNegative a -> a
Numeric.getNonNegative NonNegative Seconds
soGracefulShutdownTimeout)
                )
            )

      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
$ Environment
-> Logger Hasura
-> Manager
-> IO SchemaCache
-> LockedEventsCtx
-> m (Forever m)
forall (m :: * -> *).
(MonadIO m, HasReporter m,
 MonadMetadataStorage (MetadataStorageT m)) =>
Environment
-> Logger Hasura
-> Manager
-> IO SchemaCache
-> LockedEventsCtx
-> m (Forever m)
processScheduledTriggers
            Environment
env
            Logger Hasura
logger
            Manager
_scHttpManager
            (SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
cacheRef)
            LockedEventsCtx
lockedEventsCtx

instance (Monad m) => Tracing.HasReporter (PGMetadataStorageAppT m)

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

instance (MonadIO m) => HttpLog (PGMetadataStorageAppT m) where
  type ExtraHttpLogMetadata (PGMetadataStorageAppT m) = ()

  emptyExtraHttpLogMetadata :: ExtraHttpLogMetadata (PGMetadataStorageAppT m)
emptyExtraHttpLogMetadata = ()

  buildExtraHttpLogMetadata :: ParameterizedQueryHashList
-> ExtraHttpLogMetadata (PGMetadataStorageAppT m)
buildExtraHttpLogMetadata ParameterizedQueryHashList
_ = ()

  logHttpError :: Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> QErr
-> [Header]
-> PGMetadataStorageAppT m ()
logHttpError Logger Hasura
logger LoggingSettings
loggingSettings Maybe UserInfo
userInfoM RequestId
reqId Request
waiReq (ByteString, Maybe Value)
req QErr
qErr [Header]
headers =
    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 -> PGMetadataStorageAppT m ())
-> HttpLogLine -> PGMetadataStorageAppT m ()
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 (PGMetadataStorageAppT m)
-> PGMetadataStorageAppT m ()
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 -> PGMetadataStorageAppT m ())
-> HttpLogLine -> PGMetadataStorageAppT m ()
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)
-> 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
compressedResponse Maybe (DiffTime, DiffTime)
qTime Maybe CompressionType
cType [Header]
headers RequestMode
rb Maybe (GQLBatchedReqs GQLBatchQueryOperationLog)
batchQueryOpLogs

instance (Monad m) => MonadExecuteQuery (PGMetadataStorageAppT m) where
  cacheLookup :: [RemoteSchemaInfo]
-> [ActionsInfo]
-> QueryCacheKey
-> Maybe CachedDirective
-> TraceT
     (ExceptT QErr (PGMetadataStorageAppT m)) ([Header], Maybe EncJSON)
cacheLookup [RemoteSchemaInfo]
_ [ActionsInfo]
_ QueryCacheKey
_ Maybe CachedDirective
_ = ([Header], Maybe EncJSON)
-> TraceT
     (ExceptT QErr (PGMetadataStorageAppT m)) ([Header], Maybe EncJSON)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe EncJSON
forall a. Maybe a
Nothing)
  cacheStore :: QueryCacheKey
-> Maybe CachedDirective
-> EncJSON
-> TraceT
     (ExceptT QErr (PGMetadataStorageAppT m)) CacheStoreResponse
cacheStore QueryCacheKey
_ Maybe CachedDirective
_ EncJSON
_ = CacheStoreResponse
-> TraceT
     (ExceptT QErr (PGMetadataStorageAppT m)) CacheStoreResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CacheStoreSuccess -> CacheStoreResponse
forall a b. b -> Either a b
Right CacheStoreSuccess
CacheStoreSkipped)

instance (MonadIO m, MonadBaseControl IO m) => UserAuthentication (Tracing.TraceT (PGMetadataStorageAppT m)) where
  resolveUserInfo :: Logger Hasura
-> Manager
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> TraceT
     (PGMetadataStorageAppT m)
     (Either QErr (UserInfo, Maybe UTCTime, [Header]))
resolveUserInfo Logger Hasura
logger Manager
manager [Header]
headers AuthMode
authMode Maybe ReqsText
reqs =
    ExceptT
  QErr
  (TraceT (PGMetadataStorageAppT m))
  (UserInfo, Maybe UTCTime, [Header])
-> TraceT
     (PGMetadataStorageAppT m)
     (Either QErr (UserInfo, Maybe UTCTime, [Header]))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   QErr
   (TraceT (PGMetadataStorageAppT m))
   (UserInfo, Maybe UTCTime, [Header])
 -> TraceT
      (PGMetadataStorageAppT m)
      (Either QErr (UserInfo, Maybe UTCTime, [Header])))
-> ExceptT
     QErr
     (TraceT (PGMetadataStorageAppT m))
     (UserInfo, Maybe UTCTime, [Header])
-> TraceT
     (PGMetadataStorageAppT m)
     (Either QErr (UserInfo, Maybe UTCTime, [Header]))
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> Manager
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> ExceptT
     QErr
     (TraceT (PGMetadataStorageAppT m))
     (UserInfo, Maybe UTCTime, [Header])
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace 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

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

instance (Monad m) => MonadMetadataApiAuthorization (PGMetadataStorageAppT m) where
  authorizeV1QueryApi :: RQLQuery -> HandlerCtx -> PGMetadataStorageAppT m (Either QErr ())
authorizeV1QueryApi RQLQuery
query HandlerCtx
handlerCtx = ExceptT QErr (PGMetadataStorageAppT m) ()
-> PGMetadataStorageAppT m (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 (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
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 (PGMetadataStorageAppT m) ()
 -> ExceptT QErr (PGMetadataStorageAppT m) ())
-> ExceptT QErr (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$
      Text
-> ExceptT QErr (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK Text
"args" (ExceptT QErr (PGMetadataStorageAppT m) ()
 -> ExceptT QErr (PGMetadataStorageAppT m) ())
-> ExceptT QErr (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> ExceptT QErr (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
AccessDenied Text
accessDeniedErrMsg

  authorizeV1MetadataApi :: RQLMetadata
-> HandlerCtx -> PGMetadataStorageAppT m (Either QErr ())
authorizeV1MetadataApi RQLMetadata
_ HandlerCtx
handlerCtx = ExceptT QErr (PGMetadataStorageAppT m) ()
-> PGMetadataStorageAppT m (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 (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RoleName
currRole RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
/= RoleName
adminRoleName) (ExceptT QErr (PGMetadataStorageAppT m) ()
 -> ExceptT QErr (PGMetadataStorageAppT m) ())
-> ExceptT QErr (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$
      Text
-> ExceptT QErr (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK Text
"args" (ExceptT QErr (PGMetadataStorageAppT m) ()
 -> ExceptT QErr (PGMetadataStorageAppT m) ())
-> ExceptT QErr (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> ExceptT QErr (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
AccessDenied Text
accessDeniedErrMsg

  authorizeV2QueryApi :: RQLQuery -> HandlerCtx -> PGMetadataStorageAppT m (Either QErr ())
authorizeV2QueryApi RQLQuery
_ HandlerCtx
handlerCtx = ExceptT QErr (PGMetadataStorageAppT m) ()
-> PGMetadataStorageAppT m (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 (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RoleName
currRole RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
/= RoleName
adminRoleName) (ExceptT QErr (PGMetadataStorageAppT m) ()
 -> ExceptT QErr (PGMetadataStorageAppT m) ())
-> ExceptT QErr (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$
      Text
-> ExceptT QErr (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK Text
"args" (ExceptT QErr (PGMetadataStorageAppT m) ()
 -> ExceptT QErr (PGMetadataStorageAppT m) ())
-> ExceptT QErr (PGMetadataStorageAppT m) ()
-> ExceptT QErr (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> ExceptT QErr (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
AccessDenied Text
accessDeniedErrMsg

instance (Monad m) => ConsoleRenderer (PGMetadataStorageAppT m) where
  renderConsole :: Text
-> AuthMode
-> Bool
-> Maybe Text
-> PGMetadataStorageAppT m (Either String Text)
renderConsole Text
path AuthMode
authMode Bool
enableTelemetry Maybe Text
consoleAssetsDir =
    Either String Text -> PGMetadataStorageAppT m (Either String Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Text
 -> PGMetadataStorageAppT m (Either String Text))
-> Either String Text
-> PGMetadataStorageAppT m (Either String Text)
forall a b. (a -> b) -> a -> b
$ Text -> AuthMode -> Bool -> Maybe Text -> Either String Text
mkConsoleHTML Text
path AuthMode
authMode Bool
enableTelemetry Maybe Text
consoleAssetsDir

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

  executeIntrospection :: UserInfo
-> Value
-> SetGraphqlIntrospectionOptions
-> PGMetadataStorageAppT m (Either QErr ExecutionStep)
executeIntrospection UserInfo
_ Value
introspectionQuery SetGraphqlIntrospectionOptions
_ =
    Either QErr ExecutionStep
-> PGMetadataStorageAppT m (Either QErr ExecutionStep)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either QErr ExecutionStep
 -> PGMetadataStorageAppT m (Either QErr ExecutionStep))
-> Either QErr ExecutionStep
-> PGMetadataStorageAppT m (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

instance (MonadIO m, MonadBaseControl IO m) => MonadConfigApiHandler (PGMetadataStorageAppT m) where
  runConfigApiHandler :: ServerCtx
-> Maybe Text -> SpockCtxT () (PGMetadataStorageAppT m) ()
runConfigApiHandler = ServerCtx
-> Maybe Text -> SpockCtxT () (PGMetadataStorageAppT m) ()
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, UserAuthentication (TraceT m),
 HttpLog m, HasReporter m, HasResourceLimits m) =>
ServerCtx -> Maybe Text -> SpockCtxT () m ()
configApiGetHandler

instance (MonadIO m) => MonadQueryLog (PGMetadataStorageAppT m) where
  logQueryLog :: Logger Hasura -> QueryLog -> PGMetadataStorageAppT m ()
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 (MonadIO m) => WS.MonadWSLog (PGMetadataStorageAppT m) where
  logWSLog :: Logger Hasura -> WSLog -> PGMetadataStorageAppT m ()
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 (Monad m) => MonadResolveSource (PGMetadataStorageAppT m) where
  getPGSourceResolver :: PGMetadataStorageAppT m (SourceResolver ('Postgres 'Vanilla))
getPGSourceResolver = PGLogger
-> SourceName
-> PostgresConnConfiguration
-> IO (Either QErr PGSourceConfig)
PGLogger -> SourceResolver ('Postgres 'Vanilla)
mkPgSourceResolver (PGLogger
 -> SourceName
 -> PostgresConnConfiguration
 -> IO (Either QErr PGSourceConfig))
-> PGMetadataStorageAppT m PGLogger
-> PGMetadataStorageAppT
     m
     (SourceName
      -> PostgresConnConfiguration -> IO (Either QErr PGSourceConfig))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PGPool, PGLogger) -> PGLogger)
-> PGMetadataStorageAppT m PGLogger
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PGPool, PGLogger) -> PGLogger
forall a b. (a, b) -> b
snd
  getMSSQLSourceResolver :: PGMetadataStorageAppT m (SourceResolver 'MSSQL)
getMSSQLSourceResolver = (SourceName
 -> MSSQLConnConfiguration -> IO (Either QErr MSSQLSourceConfig))
-> PGMetadataStorageAppT
     m
     (SourceName
      -> MSSQLConnConfiguration -> IO (Either QErr MSSQLSourceConfig))
forall (m :: * -> *) a. Monad m => a -> m a
return SourceName
-> MSSQLConnConfiguration -> IO (Either QErr MSSQLSourceConfig)
SourceResolver 'MSSQL
mkMSSQLSourceResolver

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

runInSeparateTx ::
  (MonadIO m) =>
  Q.TxE QErr a ->
  MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx :: TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx TxE QErr a
tx = do
  PGPool
pool <- PGMetadataStorageAppT m PGPool
-> MetadataStorageT (PGMetadataStorageAppT m) PGPool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PGMetadataStorageAppT m PGPool
 -> MetadataStorageT (PGMetadataStorageAppT m) PGPool)
-> PGMetadataStorageAppT m PGPool
-> MetadataStorageT (PGMetadataStorageAppT m) PGPool
forall a b. (a -> b) -> a -> b
$ ((PGPool, PGLogger) -> PGPool) -> PGMetadataStorageAppT m PGPool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PGPool, PGLogger) -> PGPool
forall a b. (a, b) -> a
fst
  MetadataStorageT (PGMetadataStorageAppT m) (Either QErr a)
-> MetadataStorageT (PGMetadataStorageAppT m) a
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (MetadataStorageT (PGMetadataStorageAppT m) (Either QErr a)
 -> MetadataStorageT (PGMetadataStorageAppT m) a)
-> MetadataStorageT (PGMetadataStorageAppT m) (Either QErr a)
-> MetadataStorageT (PGMetadataStorageAppT m) a
forall a b. (a -> b) -> a -> b
$ IO (Either QErr a)
-> MetadataStorageT (PGMetadataStorageAppT m) (Either QErr a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either QErr a)
 -> MetadataStorageT (PGMetadataStorageAppT m) (Either QErr a))
-> IO (Either QErr a)
-> MetadataStorageT (PGMetadataStorageAppT m) (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
Q.runTx PGPool
pool (TxIsolation
Q.RepeatableRead, Maybe TxAccess
forall a. Maybe a
Nothing) TxE QErr a
tx

notifySchemaCacheSyncTx :: MetadataResourceVersion -> InstanceId -> CacheInvalidations -> Q.TxE QErr ()
notifySchemaCacheSyncTx :: MetadataResourceVersion
-> InstanceId -> CacheInvalidations -> TxE QErr ()
notifySchemaCacheSyncTx (MetadataResourceVersion Int64
resourceVersion) InstanceId
instanceId CacheInvalidations
invalidations = do
  Q.Discard () <-
    (PGTxErr -> QErr)
-> Query
-> (AltJ 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
Q.withQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [Q.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 -> AltJ CacheInvalidations
forall a. a -> AltJ a
Q.AltJ CacheInvalidations
invalidations, Int64
resourceVersion, InstanceId
instanceId)
      Bool
True
  () -> TxE QErr ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

-- | Each of the function in the type class is executed in a totally separate transaction.
--
-- To learn more about why the instance is derived as following, see Note [Generic MetadataStorageT transformer]
instance {-# OVERLAPPING #-} MonadIO m => MonadMetadataStorage (MetadataStorageT (PGMetadataStorageAppT m)) where
  fetchMetadataResourceVersion :: MetadataStorageT (PGMetadataStorageAppT m) MetadataResourceVersion
fetchMetadataResourceVersion = TxE QErr MetadataResourceVersion
-> MetadataStorageT
     (PGMetadataStorageAppT m) MetadataResourceVersion
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx TxE QErr MetadataResourceVersion
fetchMetadataResourceVersionFromCatalog
  fetchMetadata :: MetadataStorageT
  (PGMetadataStorageAppT m) (Metadata, MetadataResourceVersion)
fetchMetadata = TxE QErr (Metadata, MetadataResourceVersion)
-> MetadataStorageT
     (PGMetadataStorageAppT m) (Metadata, MetadataResourceVersion)
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx TxE QErr (Metadata, MetadataResourceVersion)
fetchMetadataAndResourceVersionFromCatalog
  fetchMetadataNotifications :: MetadataResourceVersion
-> InstanceId
-> MetadataStorageT
     (PGMetadataStorageAppT m)
     [(MetadataResourceVersion, CacheInvalidations)]
fetchMetadataNotifications MetadataResourceVersion
a InstanceId
b = TxE QErr [(MetadataResourceVersion, CacheInvalidations)]
-> MetadataStorageT
     (PGMetadataStorageAppT m)
     [(MetadataResourceVersion, CacheInvalidations)]
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr [(MetadataResourceVersion, CacheInvalidations)]
 -> MetadataStorageT
      (PGMetadataStorageAppT m)
      [(MetadataResourceVersion, CacheInvalidations)])
-> TxE QErr [(MetadataResourceVersion, CacheInvalidations)]
-> MetadataStorageT
     (PGMetadataStorageAppT m)
     [(MetadataResourceVersion, CacheInvalidations)]
forall a b. (a -> b) -> a -> b
$ MetadataResourceVersion
-> InstanceId
-> TxE QErr [(MetadataResourceVersion, CacheInvalidations)]
fetchMetadataNotificationsFromCatalog MetadataResourceVersion
a InstanceId
b
  setMetadata :: MetadataResourceVersion
-> Metadata
-> MetadataStorageT
     (PGMetadataStorageAppT m) MetadataResourceVersion
setMetadata MetadataResourceVersion
r = TxE QErr MetadataResourceVersion
-> MetadataStorageT
     (PGMetadataStorageAppT m) MetadataResourceVersion
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr MetadataResourceVersion
 -> MetadataStorageT
      (PGMetadataStorageAppT m) MetadataResourceVersion)
-> (Metadata -> TxE QErr MetadataResourceVersion)
-> Metadata
-> MetadataStorageT
     (PGMetadataStorageAppT m) MetadataResourceVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetadataResourceVersion
-> Metadata -> TxE QErr MetadataResourceVersion
setMetadataInCatalog MetadataResourceVersion
r
  notifySchemaCacheSync :: MetadataResourceVersion
-> InstanceId
-> CacheInvalidations
-> MetadataStorageT (PGMetadataStorageAppT m) ()
notifySchemaCacheSync MetadataResourceVersion
a InstanceId
b CacheInvalidations
c = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$ MetadataResourceVersion
-> InstanceId -> CacheInvalidations -> TxE QErr ()
notifySchemaCacheSyncTx MetadataResourceVersion
a InstanceId
b CacheInvalidations
c
  getCatalogState :: MetadataStorageT (PGMetadataStorageAppT m) CatalogState
getCatalogState = TxE QErr CatalogState
-> MetadataStorageT (PGMetadataStorageAppT m) CatalogState
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx TxE QErr CatalogState
getCatalogStateTx
  setCatalogState :: CatalogStateType
-> Value -> MetadataStorageT (PGMetadataStorageAppT m) ()
setCatalogState CatalogStateType
a Value
b = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$ CatalogStateType -> Value -> TxE QErr ()
setCatalogStateTx CatalogStateType
a Value
b

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

  getDeprivedCronTriggerStats :: [TriggerName]
-> MetadataStorageT (PGMetadataStorageAppT m) [CronTriggerStats]
getDeprivedCronTriggerStats = TxE QErr [CronTriggerStats]
-> MetadataStorageT (PGMetadataStorageAppT m) [CronTriggerStats]
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr [CronTriggerStats]
 -> MetadataStorageT (PGMetadataStorageAppT m) [CronTriggerStats])
-> ([TriggerName] -> TxE QErr [CronTriggerStats])
-> [TriggerName]
-> MetadataStorageT (PGMetadataStorageAppT m) [CronTriggerStats]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TriggerName] -> TxE QErr [CronTriggerStats]
getDeprivedCronTriggerStatsTx
  getScheduledEventsForDelivery :: MetadataStorageT
  (PGMetadataStorageAppT m) ([CronEvent], [OneOffScheduledEvent])
getScheduledEventsForDelivery = TxE QErr ([CronEvent], [OneOffScheduledEvent])
-> MetadataStorageT
     (PGMetadataStorageAppT m) ([CronEvent], [OneOffScheduledEvent])
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx TxE QErr ([CronEvent], [OneOffScheduledEvent])
getScheduledEventsForDeliveryTx
  insertCronEvents :: [CronEventSeed] -> MetadataStorageT (PGMetadataStorageAppT m) ()
insertCronEvents = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> ([CronEventSeed] -> TxE QErr ())
-> [CronEventSeed]
-> MetadataStorageT (PGMetadataStorageAppT m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CronEventSeed] -> TxE QErr ()
insertCronEventsTx
  insertOneOffScheduledEvent :: OneOffEvent
-> MetadataStorageT (PGMetadataStorageAppT m) CronEventId
insertOneOffScheduledEvent = TxE QErr CronEventId
-> MetadataStorageT (PGMetadataStorageAppT m) CronEventId
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr CronEventId
 -> MetadataStorageT (PGMetadataStorageAppT m) CronEventId)
-> (OneOffEvent -> TxE QErr CronEventId)
-> OneOffEvent
-> MetadataStorageT (PGMetadataStorageAppT m) CronEventId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneOffEvent -> TxE QErr CronEventId
insertOneOffScheduledEventTx
  insertScheduledEventInvocation :: Invocation 'ScheduledType
-> ScheduledEventType
-> MetadataStorageT (PGMetadataStorageAppT m) ()
insertScheduledEventInvocation Invocation 'ScheduledType
a ScheduledEventType
b = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$ Invocation 'ScheduledType -> ScheduledEventType -> TxE QErr ()
insertInvocationTx Invocation 'ScheduledType
a ScheduledEventType
b
  setScheduledEventOp :: CronEventId
-> ScheduledEventOp
-> ScheduledEventType
-> MetadataStorageT (PGMetadataStorageAppT m) ()
setScheduledEventOp CronEventId
a ScheduledEventOp
b ScheduledEventType
c = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$ CronEventId
-> ScheduledEventOp -> ScheduledEventType -> TxE QErr ()
setScheduledEventOpTx CronEventId
a ScheduledEventOp
b ScheduledEventType
c
  unlockScheduledEvents :: ScheduledEventType
-> [CronEventId] -> MetadataStorageT (PGMetadataStorageAppT m) Int
unlockScheduledEvents ScheduledEventType
a [CronEventId]
b = TxE QErr Int -> MetadataStorageT (PGMetadataStorageAppT m) Int
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr Int -> MetadataStorageT (PGMetadataStorageAppT m) Int)
-> TxE QErr Int -> MetadataStorageT (PGMetadataStorageAppT m) Int
forall a b. (a -> b) -> a -> b
$ ScheduledEventType -> [CronEventId] -> TxE QErr Int
unlockScheduledEventsTx ScheduledEventType
a [CronEventId]
b
  unlockAllLockedScheduledEvents :: MetadataStorageT (PGMetadataStorageAppT m) ()
unlockAllLockedScheduledEvents = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx TxE QErr ()
unlockAllLockedScheduledEventsTx
  clearFutureCronEvents :: ClearCronEvents -> MetadataStorageT (PGMetadataStorageAppT m) ()
clearFutureCronEvents = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> (ClearCronEvents -> TxE QErr ())
-> ClearCronEvents
-> MetadataStorageT (PGMetadataStorageAppT m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClearCronEvents -> TxE QErr ()
dropFutureCronEventsTx
  getOneOffScheduledEvents :: ScheduledEventPagination
-> [ScheduledEventStatus]
-> MetadataStorageT
     (PGMetadataStorageAppT m) (WithTotalCount [OneOffScheduledEvent])
getOneOffScheduledEvents ScheduledEventPagination
a [ScheduledEventStatus]
b = TxE QErr (WithTotalCount [OneOffScheduledEvent])
-> MetadataStorageT
     (PGMetadataStorageAppT m) (WithTotalCount [OneOffScheduledEvent])
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr (WithTotalCount [OneOffScheduledEvent])
 -> MetadataStorageT
      (PGMetadataStorageAppT m) (WithTotalCount [OneOffScheduledEvent]))
-> TxE QErr (WithTotalCount [OneOffScheduledEvent])
-> MetadataStorageT
     (PGMetadataStorageAppT m) (WithTotalCount [OneOffScheduledEvent])
forall a b. (a -> b) -> a -> b
$ ScheduledEventPagination
-> [ScheduledEventStatus]
-> TxE QErr (WithTotalCount [OneOffScheduledEvent])
getOneOffScheduledEventsTx ScheduledEventPagination
a [ScheduledEventStatus]
b
  getCronEvents :: TriggerName
-> ScheduledEventPagination
-> [ScheduledEventStatus]
-> MetadataStorageT
     (PGMetadataStorageAppT m) (WithTotalCount [CronEvent])
getCronEvents TriggerName
a ScheduledEventPagination
b [ScheduledEventStatus]
c = TxE QErr (WithTotalCount [CronEvent])
-> MetadataStorageT
     (PGMetadataStorageAppT m) (WithTotalCount [CronEvent])
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr (WithTotalCount [CronEvent])
 -> MetadataStorageT
      (PGMetadataStorageAppT m) (WithTotalCount [CronEvent]))
-> TxE QErr (WithTotalCount [CronEvent])
-> MetadataStorageT
     (PGMetadataStorageAppT m) (WithTotalCount [CronEvent])
forall a b. (a -> b) -> a -> b
$ TriggerName
-> ScheduledEventPagination
-> [ScheduledEventStatus]
-> TxE QErr (WithTotalCount [CronEvent])
getCronEventsTx TriggerName
a ScheduledEventPagination
b [ScheduledEventStatus]
c
  getInvocations :: GetInvocationsBy
-> ScheduledEventPagination
-> MetadataStorageT
     (PGMetadataStorageAppT m)
     (WithTotalCount [ScheduledEventInvocation])
getInvocations GetInvocationsBy
a ScheduledEventPagination
b = TxE QErr (WithTotalCount [ScheduledEventInvocation])
-> MetadataStorageT
     (PGMetadataStorageAppT m)
     (WithTotalCount [ScheduledEventInvocation])
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr (WithTotalCount [ScheduledEventInvocation])
 -> MetadataStorageT
      (PGMetadataStorageAppT m)
      (WithTotalCount [ScheduledEventInvocation]))
-> TxE QErr (WithTotalCount [ScheduledEventInvocation])
-> MetadataStorageT
     (PGMetadataStorageAppT m)
     (WithTotalCount [ScheduledEventInvocation])
forall a b. (a -> b) -> a -> b
$ GetInvocationsBy
-> ScheduledEventPagination
-> TxE QErr (WithTotalCount [ScheduledEventInvocation])
getInvocationsTx GetInvocationsBy
a ScheduledEventPagination
b
  deleteScheduledEvent :: CronEventId
-> ScheduledEventType
-> MetadataStorageT (PGMetadataStorageAppT m) ()
deleteScheduledEvent CronEventId
a ScheduledEventType
b = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$ CronEventId -> ScheduledEventType -> TxE QErr ()
deleteScheduledEventTx CronEventId
a ScheduledEventType
b

  insertAction :: ActionName
-> SessionVariables
-> [Header]
-> Value
-> MetadataStorageT (PGMetadataStorageAppT m) ActionId
insertAction ActionName
a SessionVariables
b [Header]
c Value
d = TxE QErr ActionId
-> MetadataStorageT (PGMetadataStorageAppT m) ActionId
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr ActionId
 -> MetadataStorageT (PGMetadataStorageAppT m) ActionId)
-> TxE QErr ActionId
-> MetadataStorageT (PGMetadataStorageAppT m) 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 :: MetadataStorageT (PGMetadataStorageAppT m) [ActionLogItem]
fetchUndeliveredActionEvents = TxE QErr [ActionLogItem]
-> MetadataStorageT (PGMetadataStorageAppT m) [ActionLogItem]
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx TxE QErr [ActionLogItem]
fetchUndeliveredActionEventsTx
  setActionStatus :: ActionId
-> AsyncActionStatus
-> MetadataStorageT (PGMetadataStorageAppT m) ()
setActionStatus ActionId
a AsyncActionStatus
b = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall a b. (a -> b) -> a -> b
$ ActionId -> AsyncActionStatus -> TxE QErr ()
setActionStatusTx ActionId
a AsyncActionStatus
b
  fetchActionResponse :: ActionId
-> MetadataStorageT (PGMetadataStorageAppT m) ActionLogResponse
fetchActionResponse = TxE QErr ActionLogResponse
-> MetadataStorageT (PGMetadataStorageAppT m) ActionLogResponse
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr ActionLogResponse
 -> MetadataStorageT (PGMetadataStorageAppT m) ActionLogResponse)
-> (ActionId -> TxE QErr ActionLogResponse)
-> ActionId
-> MetadataStorageT (PGMetadataStorageAppT m) ActionLogResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionId -> TxE QErr ActionLogResponse
fetchActionResponseTx
  clearActionData :: ActionName -> MetadataStorageT (PGMetadataStorageAppT m) ()
clearActionData = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> (ActionName -> TxE QErr ())
-> ActionName
-> MetadataStorageT (PGMetadataStorageAppT m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionName -> TxE QErr ()
clearActionDataTx
  setProcessingActionLogsToPending :: LockedActionIdArray
-> MetadataStorageT (PGMetadataStorageAppT m) ()
setProcessingActionLogsToPending = TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ()
forall (m :: * -> *) a.
MonadIO m =>
TxE QErr a -> MetadataStorageT (PGMetadataStorageAppT m) a
runInSeparateTx (TxE QErr () -> MetadataStorageT (PGMetadataStorageAppT m) ())
-> (LockedActionIdArray -> TxE QErr ())
-> LockedActionIdArray
-> MetadataStorageT (PGMetadataStorageAppT m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LockedActionIdArray -> TxE QErr ()
setProcessingActionLogsToPendingTx

instance MonadMetadataStorageQueryAPI (MetadataStorageT (PGMetadataStorageAppT CacheBuild))

--- helper functions ---

mkConsoleHTML :: Text -> AuthMode -> Bool -> Maybe Text -> Either String Text
mkConsoleHTML :: Text -> AuthMode -> Bool -> Maybe Text -> Either String Text
mkConsoleHTML Text
path AuthMode
authMode Bool
enableTelemetry Maybe Text
consoleAssetsDir =
  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
A.object
      [ Key
"isAdminSecretSet" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= AuthMode -> Text
isAdminSecretSet AuthMode
authMode,
        Key
"consolePath" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text
consolePath,
        Key
"enableTelemetry" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool -> Text
boolToText Bool
enableTelemetry,
        Key
"cdnAssets" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool -> Text
boolToText (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
consoleAssetsDir),
        Key
"assetsVersion" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Text
consoleAssetsVersion,
        Key
"serverVersion" Key -> Version -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Version
currentVersion
      ]
  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 :: String
telemetryNotice :: String
telemetryNotice =
  String
"Help us improve Hasura! The graphql-engine server collects anonymized "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"usage stats which allows us to keep improving Hasura at warp speed. "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"To read more or opt-out, visit https://hasura.io/docs/latest/graphql/core/guides/telemetry.html"

mkPgSourceResolver :: Q.PGLogger -> SourceResolver ('Postgres 'Vanilla)
mkPgSourceResolver :: PGLogger -> SourceResolver ('Postgres 'Vanilla)
mkPgSourceResolver PGLogger
pgLogger 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
  Environment
env <- IO Environment -> ExceptT QErr IO Environment
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO Environment
Env.getEnvironment
  let PostgresSourceConnInfo UrlConf
urlConf Maybe PostgresPoolSettings
poolSettings Bool
allowPrepare TxIsolation
isoLevel Maybe (PGClientCerts CertVar CertVar)
_ = PostgresConnConfiguration -> PostgresSourceConnInfo
_pccConnectionInfo PostgresConnConfiguration
SourceConnConfiguration ('Postgres 'Vanilla)
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
Q.ConnInfo Int
retries (ConnDetails -> ConnInfo) -> ConnDetails -> ConnInfo
forall a b. (a -> b) -> a -> b
$ ByteString -> ConnDetails
Q.CDDatabaseURI (ByteString -> ConnDetails) -> ByteString -> ConnDetails
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
txtToBs Text
urlText
      connParams :: ConnParams
connParams =
        ConnParams
Q.defaultConnParams
          { cpIdleTime :: Int
Q.cpIdleTime = Int
idleTimeout,
            cpConns :: Int
Q.cpConns = Int
maxConns,
            cpAllowPrepare :: Bool
Q.cpAllowPrepare = Bool
allowPrepare,
            cpMbLifetime :: Maybe NominalDiffTime
Q.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
Q.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 (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 -> PGExecCtx
mkPGExecCtx TxIsolation
isoLevel PGPool
pgPool
  PGSourceConfig -> ExceptT QErr IO PGSourceConfig
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
-> PGSourceConfig
PGSourceConfig PGExecCtx
pgExecCtx ConnInfo
connInfo Maybe (NonEmpty ConnInfo)
forall a. Maybe a
Nothing IO ()
forall a. Monoid a => a
mempty (ExtensionsSchema -> PGSourceConfig)
-> ExtensionsSchema -> PGSourceConfig
forall a b. (a -> b) -> a -> b
$ PostgresConnConfiguration -> ExtensionsSchema
_pccExtensionsSchema PostgresConnConfiguration
SourceConnConfiguration ('Postgres 'Vanilla)
config

mkMSSQLSourceResolver :: SourceResolver ('MSSQL)
mkMSSQLSourceResolver :: SourceResolver 'MSSQL
mkMSSQLSourceResolver SourceName
_name (MSSQLConnConfiguration connInfo _) = ExceptT QErr IO MSSQLSourceConfig
-> IO (Either QErr MSSQLSourceConfig)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
  Environment
env <- IO Environment -> ExceptT QErr IO Environment
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO Environment
Env.getEnvironment
  (ConnectionString
connString, MSSQLPool
mssqlPool) <- MSSQLConnectionInfo
-> Environment -> ExceptT QErr IO (ConnectionString, MSSQLPool)
forall (m :: * -> *).
(MonadIO m, QErrM m) =>
MSSQLConnectionInfo
-> Environment -> m (ConnectionString, MSSQLPool)
createMSSQLPool MSSQLConnectionInfo
connInfo Environment
env
  let mssqlExecCtx :: MSSQLExecCtx
mssqlExecCtx = MSSQLPool -> MSSQLExecCtx
mkMSSQLExecCtx MSSQLPool
mssqlPool
  MSSQLSourceConfig -> ExceptT QErr IO MSSQLSourceConfig
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 -> MSSQLSourceConfig
MSSQLSourceConfig ConnectionString
connString MSSQLExecCtx
mssqlExecCtx