{-# LANGUAGE CPP #-}

module Hasura.Server.SchemaCacheRef
  ( SchemaCacheRef,
    initialiseSchemaCacheRef,
    withSchemaCacheUpdate,
    readSchemaCacheRef,
    getSchemaCache,

    -- * Utility
    logInconsistentMetadata,
  )
where

import Control.Concurrent.MVar.Lifted
import Control.Concurrent.STM qualified as STM
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.IORef
import Hasura.Logging qualified as L
import Hasura.Prelude hiding (get, put)
import Hasura.RQL.DDL.Schema
import Hasura.RQL.Types.Metadata.Object
import Hasura.RQL.Types.SchemaCache
import Hasura.Server.Logging
import Hasura.Server.Metrics
  ( ServerMetrics (smSchemaCacheMetadataResourceVersion),
  )
import System.Metrics.Gauge (Gauge)
import System.Metrics.Gauge qualified as Gauge

-- | A mutable reference to a 'RebuildableSchemaCache', plus
--
-- * a write lock,
-- * update version tracking, and
-- * a gauge metric that tracks the metadata version of the 'SchemaCache'.
data SchemaCacheRef = SchemaCacheRef
  { -- | 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).
    SchemaCacheRef -> MVar ()
_scrLock :: MVar (),
    SchemaCacheRef -> IORef (RebuildableSchemaCache, SchemaCacheVer)
_scrCache :: IORef (RebuildableSchemaCache, SchemaCacheVer),
    -- | The gauge metric that tracks the current metadata version.
    --
    -- Invariant: This gauge must be updated via 'updateMetadataVersionGauge'
    -- whenever the _scrCache IORef is updated.
    SchemaCacheRef -> Gauge
_scrMetadataVersionGauge :: Gauge
  }

-- | Build a new 'SchemaCacheRef'
initialiseSchemaCacheRef ::
  MonadIO m => ServerMetrics -> RebuildableSchemaCache -> m SchemaCacheRef
initialiseSchemaCacheRef :: ServerMetrics -> RebuildableSchemaCache -> m SchemaCacheRef
initialiseSchemaCacheRef ServerMetrics
serverMetrics RebuildableSchemaCache
schemaCache = IO SchemaCacheRef -> m SchemaCacheRef
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SchemaCacheRef -> m SchemaCacheRef)
-> IO SchemaCacheRef -> m SchemaCacheRef
forall a b. (a -> b) -> a -> b
$ do
  MVar ()
cacheLock <- () -> IO (MVar ())
forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar ()
  IORef (RebuildableSchemaCache, SchemaCacheVer)
cacheCell <- (RebuildableSchemaCache, SchemaCacheVer)
-> IO (IORef (RebuildableSchemaCache, SchemaCacheVer))
forall a. a -> IO (IORef a)
newIORef (RebuildableSchemaCache
schemaCache, SchemaCacheVer
initSchemaCacheVer)
  let metadataVersionGauge :: Gauge
metadataVersionGauge = ServerMetrics -> Gauge
smSchemaCacheMetadataResourceVersion ServerMetrics
serverMetrics
  Gauge -> RebuildableSchemaCache -> IO ()
forall (m :: * -> *).
MonadIO m =>
Gauge -> RebuildableSchemaCache -> m ()
updateMetadataVersionGauge Gauge
metadataVersionGauge RebuildableSchemaCache
schemaCache
  SchemaCacheRef -> IO SchemaCacheRef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SchemaCacheRef -> IO SchemaCacheRef)
-> SchemaCacheRef -> IO SchemaCacheRef
forall a b. (a -> b) -> a -> b
$ MVar ()
-> IORef (RebuildableSchemaCache, SchemaCacheVer)
-> Gauge
-> SchemaCacheRef
SchemaCacheRef MVar ()
cacheLock IORef (RebuildableSchemaCache, SchemaCacheVer)
cacheCell Gauge
metadataVersionGauge

-- | Set the 'SchemaCacheRef' to the 'RebuildableSchemaCache' produced by the
-- given action.
--
-- An internal lock ensures that at most one update to the 'SchemaCacheRef' may
-- proceed at a time.
withSchemaCacheUpdate ::
  (MonadIO m, MonadBaseControl IO m) =>
  SchemaCacheRef ->
  L.Logger L.Hasura ->
  Maybe (STM.TVar Bool) ->
  m (a, RebuildableSchemaCache) ->
  m a
withSchemaCacheUpdate :: SchemaCacheRef
-> Logger Hasura
-> Maybe (TVar Bool)
-> m (a, RebuildableSchemaCache)
-> m a
withSchemaCacheUpdate (SchemaCacheRef MVar ()
lock IORef (RebuildableSchemaCache, SchemaCacheVer)
cacheRef Gauge
metadataVersionGauge) Logger Hasura
logger Maybe (TVar Bool)
mLogCheckerTVar 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
$ \() -> do
    (!a
res, !RebuildableSchemaCache
newSC) <- m (a, RebuildableSchemaCache)
action
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      -- update schemacache in IO reference
      IORef (RebuildableSchemaCache, SchemaCacheVer)
-> ((RebuildableSchemaCache, SchemaCacheVer)
    -> (RebuildableSchemaCache, SchemaCacheVer))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (RebuildableSchemaCache, SchemaCacheVer)
cacheRef (((RebuildableSchemaCache, SchemaCacheVer)
  -> (RebuildableSchemaCache, SchemaCacheVer))
 -> IO ())
-> ((RebuildableSchemaCache, SchemaCacheVer)
    -> (RebuildableSchemaCache, SchemaCacheVer))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(RebuildableSchemaCache
_, SchemaCacheVer
prevVer) ->
        let !newVer :: SchemaCacheVer
newVer = SchemaCacheVer -> SchemaCacheVer
incSchemaCacheVer SchemaCacheVer
prevVer
         in (RebuildableSchemaCache
newSC, SchemaCacheVer
newVer)

      -- 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 -> do IO ()
logInconsistentMetadata'
        Just TVar Bool
logCheckerTVar -> do
          Bool
logCheck <- IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TVar Bool -> IO Bool
forall a. TVar a -> IO a
STM.readTVarIO TVar Bool
logCheckerTVar
          if [InconsistentMetadata] -> 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 (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 (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | Read the contents of the 'SchemaCacheRef'
readSchemaCacheRef :: SchemaCacheRef -> IO (RebuildableSchemaCache, SchemaCacheVer)
readSchemaCacheRef :: SchemaCacheRef -> IO (RebuildableSchemaCache, SchemaCacheVer)
readSchemaCacheRef SchemaCacheRef
scRef = IORef (RebuildableSchemaCache, SchemaCacheVer)
-> IO (RebuildableSchemaCache, SchemaCacheVer)
forall a. IORef a -> IO a
readIORef (IORef (RebuildableSchemaCache, SchemaCacheVer)
 -> IO (RebuildableSchemaCache, SchemaCacheVer))
-> IORef (RebuildableSchemaCache, SchemaCacheVer)
-> IO (RebuildableSchemaCache, SchemaCacheVer)
forall a b. (a -> b) -> a -> b
$ SchemaCacheRef -> IORef (RebuildableSchemaCache, SchemaCacheVer)
_scrCache SchemaCacheRef
scRef

-- | Utility function. Read the latest 'SchemaCache' from the 'SchemaCacheRef'.
--
-- > getSchemaCache == fmap (lastBuiltSchemaCache . fst) . readSchemaCacheRef
getSchemaCache :: SchemaCacheRef -> IO SchemaCache
getSchemaCache :: SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
scRef = RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache (RebuildableSchemaCache -> SchemaCache)
-> ((RebuildableSchemaCache, SchemaCacheVer)
    -> RebuildableSchemaCache)
-> (RebuildableSchemaCache, SchemaCacheVer)
-> SchemaCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RebuildableSchemaCache, SchemaCacheVer) -> RebuildableSchemaCache
forall a b. (a, b) -> a
fst ((RebuildableSchemaCache, SchemaCacheVer) -> SchemaCache)
-> IO (RebuildableSchemaCache, SchemaCacheVer) -> IO SchemaCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaCacheRef -> IO (RebuildableSchemaCache, SchemaCacheVer)
readSchemaCacheRef SchemaCacheRef
scRef

-- | Utility function
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 (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

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