module Hasura.Server.AppStateRef
  ( -- * AppState
    AppStateRef,
    initialiseAppStateRef,
    withSchemaCacheUpdate,
    withAppContextUpdate,
    updateAppStateRef,

    -- * TLS AllowList reference
    TLSAllowListRef,
    createTLSAllowListRef,
    readTLSAllowList,

    -- * Metrics config reference
    MetricsConfigRef,
    createMetricsConfigRef,
    readMetricsConfig,

    -- * Utility
    getSchemaCache,
    getSchemaCacheWithVersion,
    getRebuildableSchemaCacheWithVersion,
    readAppContextRef,
    getAppContext,
    logInconsistentMetadata,
    withSchemaCacheReadUpdate,
  )
where

import Control.Concurrent.MVar.Lifted
import Control.Concurrent.STM qualified as STM
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.IORef
import Hasura.App.State
import Hasura.Base.Error
import Hasura.Logging qualified as L
import Hasura.Prelude hiding (get, put)
import Hasura.RQL.DDL.Schema
import Hasura.RQL.Types.Common (MetricsConfig)
import Hasura.RQL.Types.Metadata.Object
import Hasura.RQL.Types.SchemaCache
import Hasura.Server.Logging
import Hasura.Server.Metrics
import Network.Types.Extended
import System.Metrics.Gauge (Gauge)
import System.Metrics.Gauge qualified as Gauge

--------------------------------------------------------------------------------
-- AppState

-- | A mutable reference to a 'AppState', plus
--
-- * a write lock,
-- * update version tracking, and
-- * a gauge metric that tracks the metadata version of the 'SchemaCache'.
data AppStateRef impl = AppStateRef
  { -- | The idea behind explicit locking here is to
    --
    --   1. Allow maximum throughput for serving requests (/v1/graphql) (as each
    --      request reads the current schemacache)
    --   2. We don't want to process more than one request at any point of time
    --      which would modify the schema cache as such queries are expensive.
    --
    -- Another option is to consider removing this lock in place of `_scrCache ::
    -- MVar ...` if it's okay or in fact correct to block during schema update in
    -- e.g.  _wseGCtxMap. Vamshi says: It is theoretically possible to have a
    -- situation (in between building new schemacache and before writing it to
    -- the IORef) where we serve a request with a stale schemacache but I guess
    -- it is an okay trade-off to pay for a higher throughput (I remember doing a
    -- bunch of benchmarks to test this hypothesis).
    forall impl. AppStateRef impl -> MVar ()
_scrLock :: MVar (),
    forall impl. AppStateRef impl -> IORef (AppState impl)
_scrCache :: IORef (AppState impl),
    -- | The gauge metric that tracks the current metadata version.
    --
    -- Invariant: This gauge must be updated via 'updateMetadataVersionGauge'
    -- whenever the _scrCache IORef is updated.
    forall impl. AppStateRef impl -> Gauge
_scrMetadataVersionGauge :: Gauge
  }

-- | A mutable reference to '(RebuildableSchemaCache, SchemaCacheVer)' and 'RebuildableAppContext'
data AppState impl = AppState
  { forall impl. AppState impl -> RebuildableSchemaCache
asSchemaCache :: RebuildableSchemaCache,
    forall impl. AppState impl -> RebuildableAppContext impl
asAppCtx :: RebuildableAppContext impl
  }

-- | Build a new 'AppStateRef'.
--
-- This function also updates the 'TLSAllowListRef' to make it point to the
-- newly minted 'SchemaCacheRef'.
initialiseAppStateRef ::
  (MonadIO m) =>
  TLSAllowListRef ->
  Maybe MetricsConfigRef ->
  ServerMetrics ->
  RebuildableSchemaCache ->
  RebuildableAppContext impl ->
  m (AppStateRef impl)
initialiseAppStateRef :: forall (m :: * -> *) impl.
MonadIO m =>
TLSAllowListRef
-> Maybe MetricsConfigRef
-> ServerMetrics
-> RebuildableSchemaCache
-> RebuildableAppContext impl
-> m (AppStateRef impl)
initialiseAppStateRef (TLSAllowListRef IORef (IO [TlsAllow])
tlsAllowListRef) Maybe MetricsConfigRef
metricsConfigRefM ServerMetrics
serverMetrics RebuildableSchemaCache
rebuildableSchemaCache RebuildableAppContext impl
rebuildableAppCtx = IO (AppStateRef impl) -> m (AppStateRef impl)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  MVar ()
cacheLock <- () -> IO (MVar ())
forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar ()
  let appState :: AppState impl
appState = RebuildableSchemaCache
-> RebuildableAppContext impl -> AppState impl
forall impl.
RebuildableSchemaCache
-> RebuildableAppContext impl -> AppState impl
AppState RebuildableSchemaCache
rebuildableSchemaCache RebuildableAppContext impl
rebuildableAppCtx
  IORef (AppState impl)
cacheCell <- AppState impl -> IO (IORef (AppState impl))
forall a. a -> IO (IORef a)
newIORef AppState impl
appState
  let metadataVersionGauge :: Gauge
metadataVersionGauge = ServerMetrics -> Gauge
smSchemaCacheMetadataResourceVersion ServerMetrics
serverMetrics
  Gauge -> RebuildableSchemaCache -> IO ()
forall (m :: * -> *).
MonadIO m =>
Gauge -> RebuildableSchemaCache -> m ()
updateMetadataVersionGauge Gauge
metadataVersionGauge RebuildableSchemaCache
rebuildableSchemaCache
  let ref :: AppStateRef impl
ref = MVar () -> IORef (AppState impl) -> Gauge -> AppStateRef impl
forall impl.
MVar () -> IORef (AppState impl) -> Gauge -> AppStateRef impl
AppStateRef MVar ()
cacheLock IORef (AppState impl)
cacheCell Gauge
metadataVersionGauge
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (IO [TlsAllow]) -> IO [TlsAllow] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IO [TlsAllow])
tlsAllowListRef (SchemaCache -> [TlsAllow]
scTlsAllowlist (SchemaCache -> [TlsAllow]) -> IO SchemaCache -> IO [TlsAllow]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
ref)
  Maybe MetricsConfigRef -> (MetricsConfigRef -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe MetricsConfigRef
metricsConfigRefM \(MetricsConfigRef IORef (IO MetricsConfig)
metricsConfigRef) ->
    IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (IO MetricsConfig) -> IO MetricsConfig -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IO MetricsConfig)
metricsConfigRef (SchemaCache -> MetricsConfig
scMetricsConfig (SchemaCache -> MetricsConfig)
-> IO SchemaCache -> IO MetricsConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
ref)
  AppStateRef impl -> IO (AppStateRef impl)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppStateRef impl
ref

-- TODO: This function might not be needed at all. This function is used only in `refreshSchemaCache` and we
-- can use `withSchemaCacheReadUpdate` there.
withSchemaCacheUpdate ::
  (MonadIO m, MonadBaseControl IO m, MonadError QErr m) =>
  (AppStateRef impl) ->
  L.Logger L.Hasura ->
  Maybe (STM.TVar Bool) ->
  m (a, RebuildableSchemaCache) ->
  m a
withSchemaCacheUpdate :: forall (m :: * -> *) impl a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m) =>
AppStateRef impl
-> Logger Hasura
-> Maybe (TVar Bool)
-> m (a, RebuildableSchemaCache)
-> m a
withSchemaCacheUpdate AppStateRef impl
asr Logger Hasura
logger Maybe (TVar Bool)
mLogCheckerTVar m (a, RebuildableSchemaCache)
action =
  AppStateRef impl
-> Logger Hasura
-> Maybe (TVar Bool)
-> (RebuildableSchemaCache -> m (a, RebuildableSchemaCache))
-> m a
forall (m :: * -> *) impl a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m) =>
AppStateRef impl
-> Logger Hasura
-> Maybe (TVar Bool)
-> (RebuildableSchemaCache -> m (a, RebuildableSchemaCache))
-> m a
withSchemaCacheReadUpdate AppStateRef impl
asr Logger Hasura
logger Maybe (TVar Bool)
mLogCheckerTVar (m (a, RebuildableSchemaCache)
-> RebuildableSchemaCache -> m (a, RebuildableSchemaCache)
forall a b. a -> b -> a
const m (a, RebuildableSchemaCache)
action)

-- | Set the 'AppStateRef' to the 'RebuildableSchemaCache' produced by the
-- given action.
--
-- An internal lock ensures that at most one update to the 'AppStateRef' may
-- proceed at a time.
withSchemaCacheReadUpdate ::
  (MonadIO m, MonadBaseControl IO m, MonadError QErr m) =>
  (AppStateRef impl) ->
  L.Logger L.Hasura ->
  Maybe (STM.TVar Bool) ->
  (RebuildableSchemaCache -> m (a, RebuildableSchemaCache)) ->
  m a
withSchemaCacheReadUpdate :: forall (m :: * -> *) impl a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m) =>
AppStateRef impl
-> Logger Hasura
-> Maybe (TVar Bool)
-> (RebuildableSchemaCache -> m (a, RebuildableSchemaCache))
-> m a
withSchemaCacheReadUpdate (AppStateRef MVar ()
lock IORef (AppState impl)
cacheRef Gauge
metadataVersionGauge) Logger Hasura
logger Maybe (TVar Bool)
mLogCheckerTVar RebuildableSchemaCache -> m (a, RebuildableSchemaCache)
action =
  MVar () -> (() -> m a) -> m a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m b) -> m b
withMVarMasked MVar ()
lock ((() -> m a) -> m a) -> (() -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ m a -> () -> m a
forall a b. a -> b -> a
const do
    RebuildableSchemaCache
rebuildableSchemaCache <- AppState impl -> RebuildableSchemaCache
forall impl. AppState impl -> RebuildableSchemaCache
asSchemaCache (AppState impl -> RebuildableSchemaCache)
-> m (AppState impl) -> m RebuildableSchemaCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (AppState impl) -> m (AppState impl)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (AppState impl) -> IO (AppState impl)
forall a. IORef a -> IO a
readIORef IORef (AppState impl)
cacheRef)
    (!a
res, !RebuildableSchemaCache
newSC) <- RebuildableSchemaCache -> m (a, RebuildableSchemaCache)
action RebuildableSchemaCache
rebuildableSchemaCache
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SchemaCache -> MetadataResourceVersion
scMetadataResourceVersion (RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache RebuildableSchemaCache
newSC) MetadataResourceVersion -> MetadataResourceVersion -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> MetadataResourceVersion
MetadataResourceVersion (-Int64
1))
      (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 Text
"Programming error: attempting to save Schema Cache with incorrect mrv. Please report this to Hasura."
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
      -- update schemacache in IO reference
      IORef (AppState impl) -> (AppState impl -> AppState impl) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (AppState impl)
cacheRef ((AppState impl -> AppState impl) -> IO ())
-> (AppState impl -> AppState impl) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState impl
appState ->
        AppState impl
appState {asSchemaCache :: RebuildableSchemaCache
asSchemaCache = RebuildableSchemaCache
newSC}

      -- update metric with new metadata version
      Gauge -> RebuildableSchemaCache -> IO ()
forall (m :: * -> *).
MonadIO m =>
Gauge -> RebuildableSchemaCache -> m ()
updateMetadataVersionGauge Gauge
metadataVersionGauge RebuildableSchemaCache
newSC

      let inconsistentObjectsList :: [InconsistentMetadata]
inconsistentObjectsList = SchemaCache -> [InconsistentMetadata]
scInconsistentObjs (SchemaCache -> [InconsistentMetadata])
-> SchemaCache -> [InconsistentMetadata]
forall a b. (a -> b) -> a -> b
$ RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache RebuildableSchemaCache
newSC
          logInconsistentMetadata' :: IO ()
logInconsistentMetadata' = Logger Hasura -> [InconsistentMetadata] -> IO ()
logInconsistentMetadata Logger Hasura
logger [InconsistentMetadata]
inconsistentObjectsList
      -- log any inconsistent objects only once and not everytime this method is called
      case Maybe (TVar Bool)
mLogCheckerTVar of
        Maybe (TVar Bool)
Nothing -> IO ()
logInconsistentMetadata'
        Just TVar Bool
logCheckerTVar -> do
          Bool
logCheck <- TVar Bool -> IO Bool
forall a. TVar a -> IO a
STM.readTVarIO TVar Bool
logCheckerTVar
          if [InconsistentMetadata] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InconsistentMetadata]
inconsistentObjectsList Bool -> Bool -> Bool
&& Bool
logCheck
            then do
              STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar Bool
logCheckerTVar Bool
False
            else do
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
logCheck Bool -> Bool -> Bool
|| [InconsistentMetadata] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InconsistentMetadata]
inconsistentObjectsList) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar Bool
logCheckerTVar Bool
True
                IO ()
logInconsistentMetadata'
    a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

-- | Read the contents of the 'AppStateRef' to get the latest 'RebuildableAppContext'
readAppContextRef :: AppStateRef impl -> IO (RebuildableAppContext impl)
readAppContextRef :: forall impl. AppStateRef impl -> IO (RebuildableAppContext impl)
readAppContextRef AppStateRef impl
scRef = AppState impl -> RebuildableAppContext impl
forall impl. AppState impl -> RebuildableAppContext impl
asAppCtx (AppState impl -> RebuildableAppContext impl)
-> IO (AppState impl) -> IO (RebuildableAppContext impl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (AppState impl) -> IO (AppState impl)
forall a. IORef a -> IO a
readIORef (AppStateRef impl -> IORef (AppState impl)
forall impl. AppStateRef impl -> IORef (AppState impl)
_scrCache AppStateRef impl
scRef)

-- | Read the contents of the 'AppStateRef' to get the latest 'RebuildableSchemaCache' and 'SchemaCacheVer'
getRebuildableSchemaCacheWithVersion :: AppStateRef impl -> IO RebuildableSchemaCache
getRebuildableSchemaCacheWithVersion :: forall impl. AppStateRef impl -> IO RebuildableSchemaCache
getRebuildableSchemaCacheWithVersion AppStateRef impl
scRef = AppState impl -> RebuildableSchemaCache
forall impl. AppState impl -> RebuildableSchemaCache
asSchemaCache (AppState impl -> RebuildableSchemaCache)
-> IO (AppState impl) -> IO RebuildableSchemaCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (AppState impl) -> IO (AppState impl)
forall a. IORef a -> IO a
readIORef (AppStateRef impl -> IORef (AppState impl)
forall impl. AppStateRef impl -> IORef (AppState impl)
_scrCache AppStateRef impl
scRef)

--------------------------------------------------------------------------------
-- TLS Allow List

-- | Reference to a TLS AllowList, used for dynamic TLS settings in the app's
-- HTTP Manager.
--
-- This exists to break a chicken-and-egg problem in the initialisation of the
-- engine: the IO action that dynamically reads the TLS settings reads it from
-- the schema cache; but to build the schema cache we need a HTTP manager that
-- has access to the TLS settings... In the past, we were using a temporary HTTP
-- Manager to create the first schema cache, to then create the *real* Manager
-- that would refer to the list in the schema cache. Now, instead, we only
-- create one Manager, which uses a 'TLSAllowListRef' to dynamically access the
-- Allow List.
newtype TLSAllowListRef = TLSAllowListRef (IORef (IO [TlsAllow]))

-- | Creates a new 'TLSAllowListRef' that points to the given list.
createTLSAllowListRef :: [TlsAllow] -> IO TLSAllowListRef
createTLSAllowListRef :: [TlsAllow] -> IO TLSAllowListRef
createTLSAllowListRef = (IORef (IO [TlsAllow]) -> TLSAllowListRef)
-> IO (IORef (IO [TlsAllow])) -> IO TLSAllowListRef
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef (IO [TlsAllow]) -> TLSAllowListRef
TLSAllowListRef (IO (IORef (IO [TlsAllow])) -> IO TLSAllowListRef)
-> ([TlsAllow] -> IO (IORef (IO [TlsAllow])))
-> [TlsAllow]
-> IO TLSAllowListRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [TlsAllow] -> IO (IORef (IO [TlsAllow]))
forall a. a -> IO (IORef a)
newIORef (IO [TlsAllow] -> IO (IORef (IO [TlsAllow])))
-> ([TlsAllow] -> IO [TlsAllow])
-> [TlsAllow]
-> IO (IORef (IO [TlsAllow]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TlsAllow] -> IO [TlsAllow]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Reads the TLS AllowList by attempting to read from the schema cache, and
-- defaulting to the list given when the ref was created.
readTLSAllowList :: TLSAllowListRef -> IO [TlsAllow]
readTLSAllowList :: TLSAllowListRef -> IO [TlsAllow]
readTLSAllowList (TLSAllowListRef IORef (IO [TlsAllow])
ref) = IO (IO [TlsAllow]) -> IO [TlsAllow]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO [TlsAllow]) -> IO [TlsAllow])
-> IO (IO [TlsAllow]) -> IO [TlsAllow]
forall a b. (a -> b) -> a -> b
$ IORef (IO [TlsAllow]) -> IO (IO [TlsAllow])
forall a. IORef a -> IO a
readIORef IORef (IO [TlsAllow])
ref

--------------------------------------------------------------------------------
-- Metrics config

-- | Reference to the metadata's 'MetricsConfig'.
--
-- Similarly to the 'TLSAllowListRef', this exists to break a
-- chicken-and-egg problem in the initialisation of the engine: the
-- implementation of several behaviour classes requires access to said
-- config, but those classes are implemented on the app monad, that
-- doesn't have access to the schema cache. This small type allows the
-- app monad to have access to the config, even before we build the
-- first schema cache.
newtype MetricsConfigRef
  = MetricsConfigRef (IORef (IO MetricsConfig))

-- | Creates a new 'MetricsConfigRef' that points to the given config.
createMetricsConfigRef :: MetricsConfig -> IO (MetricsConfigRef)
createMetricsConfigRef :: MetricsConfig -> IO MetricsConfigRef
createMetricsConfigRef = (IORef (IO MetricsConfig) -> MetricsConfigRef)
-> IO (IORef (IO MetricsConfig)) -> IO MetricsConfigRef
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef (IO MetricsConfig) -> MetricsConfigRef
MetricsConfigRef (IO (IORef (IO MetricsConfig)) -> IO MetricsConfigRef)
-> (MetricsConfig -> IO (IORef (IO MetricsConfig)))
-> MetricsConfig
-> IO MetricsConfigRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO MetricsConfig -> IO (IORef (IO MetricsConfig))
forall a. a -> IO (IORef a)
newIORef (IO MetricsConfig -> IO (IORef (IO MetricsConfig)))
-> (MetricsConfig -> IO MetricsConfig)
-> MetricsConfig
-> IO (IORef (IO MetricsConfig))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetricsConfig -> IO MetricsConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Reads the TLS AllowList by attempting to read from the schema cache, and
-- defaulting to the list given when the ref was created.
readMetricsConfig :: MetricsConfigRef -> IO MetricsConfig
readMetricsConfig :: MetricsConfigRef -> IO MetricsConfig
readMetricsConfig (MetricsConfigRef IORef (IO MetricsConfig)
ref) = IO (IO MetricsConfig) -> IO MetricsConfig
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO MetricsConfig) -> IO MetricsConfig)
-> IO (IO MetricsConfig) -> IO MetricsConfig
forall a b. (a -> b) -> a -> b
$ IORef (IO MetricsConfig) -> IO (IO MetricsConfig)
forall a. IORef a -> IO a
readIORef IORef (IO MetricsConfig)
ref

--------------------------------------------------------------------------------
-- Utility functions

-- | Read the latest 'SchemaCache' from the 'AppStateRef'.
getSchemaCache :: AppStateRef impl -> IO SchemaCache
getSchemaCache :: forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
asRef = RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache (RebuildableSchemaCache -> SchemaCache)
-> IO RebuildableSchemaCache -> IO SchemaCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO RebuildableSchemaCache
forall impl. AppStateRef impl -> IO RebuildableSchemaCache
getRebuildableSchemaCacheWithVersion AppStateRef impl
asRef

-- | Read the latest 'SchemaCache' and its version from the 'AppStateRef'.
getSchemaCacheWithVersion :: AppStateRef impl -> IO (SchemaCache)
getSchemaCacheWithVersion :: forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCacheWithVersion AppStateRef impl
scRef = (RebuildableSchemaCache -> SchemaCache)
-> IO RebuildableSchemaCache -> IO SchemaCache
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache (IO RebuildableSchemaCache -> IO SchemaCache)
-> IO RebuildableSchemaCache -> IO SchemaCache
forall a b. (a -> b) -> a -> b
$ AppStateRef impl -> IO RebuildableSchemaCache
forall impl. AppStateRef impl -> IO RebuildableSchemaCache
getRebuildableSchemaCacheWithVersion AppStateRef impl
scRef

-- | Read the latest 'AppContext' from the 'AppStateRef'.
getAppContext :: AppStateRef impl -> IO AppContext
getAppContext :: forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
asRef = RebuildableAppContext impl -> AppContext
forall impl. RebuildableAppContext impl -> AppContext
lastBuiltAppContext (RebuildableAppContext impl -> AppContext)
-> IO (RebuildableAppContext impl) -> IO AppContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO (RebuildableAppContext impl)
forall impl. AppStateRef impl -> IO (RebuildableAppContext impl)
readAppContextRef AppStateRef impl
asRef

-- | Formats and logs a list of inconsistent metadata objects.
logInconsistentMetadata :: L.Logger L.Hasura -> [InconsistentMetadata] -> IO ()
logInconsistentMetadata :: Logger Hasura -> [InconsistentMetadata] -> IO ()
logInconsistentMetadata Logger Hasura
logger [InconsistentMetadata]
objs =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([InconsistentMetadata] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InconsistentMetadata]
objs)
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
L.unLogger Logger Hasura
logger
    (MetadataLog -> IO ()) -> MetadataLog -> IO ()
forall a b. (a -> b) -> a -> b
$ [InconsistentMetadata] -> MetadataLog
mkInconsMetadataLog [InconsistentMetadata]
objs

--------------------------------------------------------------------------------
-- Local helpers

-- | Set the gauge metric to the metadata version of the schema cache, if it exists.
updateMetadataVersionGauge :: (MonadIO m) => Gauge -> RebuildableSchemaCache -> m ()
updateMetadataVersionGauge :: forall (m :: * -> *).
MonadIO m =>
Gauge -> RebuildableSchemaCache -> m ()
updateMetadataVersionGauge Gauge
metadataVersionGauge RebuildableSchemaCache
schemaCache = do
  let metadataVersion :: MetadataResourceVersion
metadataVersion = SchemaCache -> MetadataResourceVersion
scMetadataResourceVersion (SchemaCache -> MetadataResourceVersion)
-> (RebuildableSchemaCache -> SchemaCache)
-> RebuildableSchemaCache
-> MetadataResourceVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache (RebuildableSchemaCache -> MetadataResourceVersion)
-> RebuildableSchemaCache -> MetadataResourceVersion
forall a b. (a -> b) -> a -> b
$ RebuildableSchemaCache
schemaCache
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Gauge -> Int64 -> IO ()
Gauge.set Gauge
metadataVersionGauge (Int64 -> IO ()) -> Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ MetadataResourceVersion -> Int64
getMetadataResourceVersion MetadataResourceVersion
metadataVersion

-- | Set the 'RebuildableAppContext' to the 'AppStateRef' produced by the given
-- action.
--
-- An internal lock ensures that at most one update to the 'AppStateRef' may
-- proceed at a time.
withAppContextUpdate ::
  (MonadIO m, MonadBaseControl IO m) =>
  AppStateRef impl ->
  m (a, RebuildableAppContext impl) ->
  m a
withAppContextUpdate :: forall (m :: * -> *) impl a.
(MonadIO m, MonadBaseControl IO m) =>
AppStateRef impl -> m (a, RebuildableAppContext impl) -> m a
withAppContextUpdate (AppStateRef MVar ()
lock IORef (AppState impl)
cacheRef Gauge
_) m (a, RebuildableAppContext impl)
action =
  MVar () -> (() -> m a) -> m a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m b) -> m b
withMVarMasked MVar ()
lock ((() -> m a) -> m a) -> (() -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \() -> do
    (!a
res, !RebuildableAppContext impl
newCtx) <- m (a, RebuildableAppContext impl)
action
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      -- update app ctx in IO reference
      IORef (AppState impl) -> (AppState impl -> AppState impl) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (AppState impl)
cacheRef ((AppState impl -> AppState impl) -> IO ())
-> (AppState impl -> AppState impl) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState impl
appState -> AppState impl
appState {asAppCtx :: RebuildableAppContext impl
asAppCtx = RebuildableAppContext impl
newCtx}
    a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | Set the 'AppStateRef', atomically, to the ('RebuildableSchemaCache',
-- 'RebuildableAppContext') produced by the given action.
--
-- An internal lock ensures that at most one update to the 'AppStateRef' may
-- proceed at a time.
updateAppStateRef ::
  (MonadIO m, MonadBaseControl IO m) =>
  AppStateRef impl ->
  L.Logger L.Hasura ->
  (RebuildableAppContext impl -> m (RebuildableAppContext impl, RebuildableSchemaCache)) ->
  m ()
updateAppStateRef :: forall (m :: * -> *) impl.
(MonadIO m, MonadBaseControl IO m) =>
AppStateRef impl
-> Logger Hasura
-> (RebuildableAppContext impl
    -> m (RebuildableAppContext impl, RebuildableSchemaCache))
-> m ()
updateAppStateRef appStateRef :: AppStateRef impl
appStateRef@(AppStateRef MVar ()
lock IORef (AppState impl)
cacheRef Gauge
metadataVersionGauge) Logger Hasura
logger RebuildableAppContext impl
-> m (RebuildableAppContext impl, RebuildableSchemaCache)
action =
  MVar () -> (() -> m ()) -> m ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m b) -> m b
withMVarMasked MVar ()
lock ((() -> m ()) -> m ()) -> (() -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> () -> m ()
forall a b. a -> b -> a
const do
    RebuildableAppContext impl
rebuildableAppContext <- IO (RebuildableAppContext impl) -> m (RebuildableAppContext impl)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RebuildableAppContext impl) -> m (RebuildableAppContext impl))
-> IO (RebuildableAppContext impl)
-> m (RebuildableAppContext impl)
forall a b. (a -> b) -> a -> b
$ AppStateRef impl -> IO (RebuildableAppContext impl)
forall impl. AppStateRef impl -> IO (RebuildableAppContext impl)
readAppContextRef AppStateRef impl
appStateRef
    (!RebuildableAppContext impl
newAppCtx, !RebuildableSchemaCache
newSC) <- RebuildableAppContext impl
-> m (RebuildableAppContext impl, RebuildableSchemaCache)
action RebuildableAppContext impl
rebuildableAppContext
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
      -- update schemacache in IO reference
      IORef (AppState impl) -> (AppState impl -> AppState impl) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (AppState impl)
cacheRef ((AppState impl -> AppState impl) -> IO ())
-> (AppState impl -> AppState impl) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState impl
appState ->
        AppState impl
appState {asSchemaCache :: RebuildableSchemaCache
asSchemaCache = RebuildableSchemaCache
newSC, asAppCtx :: RebuildableAppContext impl
asAppCtx = RebuildableAppContext impl
newAppCtx}

      -- update metric with new metadata version
      Gauge -> RebuildableSchemaCache -> IO ()
forall (m :: * -> *).
MonadIO m =>
Gauge -> RebuildableSchemaCache -> m ()
updateMetadataVersionGauge Gauge
metadataVersionGauge RebuildableSchemaCache
newSC

      let inconsistentObjectsList :: [InconsistentMetadata]
inconsistentObjectsList = SchemaCache -> [InconsistentMetadata]
scInconsistentObjs (SchemaCache -> [InconsistentMetadata])
-> SchemaCache -> [InconsistentMetadata]
forall a b. (a -> b) -> a -> b
$ RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache RebuildableSchemaCache
newSC
          logInconsistentMetadata' :: IO ()
logInconsistentMetadata' = Logger Hasura -> [InconsistentMetadata] -> IO ()
logInconsistentMetadata Logger Hasura
logger [InconsistentMetadata]
inconsistentObjectsList
      -- log any inconsistent objects everytime this method is called
      IO ()
logInconsistentMetadata'