mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-19 13:31:43 +03:00
cdac24c79f
What is the `Cacheable` type class about? ```haskell class Eq a => Cacheable a where unchanged :: Accesses -> a -> a -> Bool default unchanged :: (Generic a, GCacheable (Rep a)) => Accesses -> a -> a -> Bool unchanged accesses a b = gunchanged (from a) (from b) accesses ``` Its only method is an alternative to `(==)`. The added value of `unchanged` (and the additional `Accesses` argument) arises _only_ for one type, namely `Dependency`. Indeed, the `Cacheable (Dependency a)` instance is non-trivial, whereas every other `Cacheable` instance is completely boilerplate (and indeed either generated from `Generic`, or simply `unchanged _ = (==)`). The `Cacheable (Dependency a)` instance is the only one where the `Accesses` argument is not just passed onwards. The only callsite of the `unchanged` method is in the `ArrowCache (Rule m)` method. That is to say that the `Cacheable` type class is used to decide when we can re-use parts of the schema cache between Metadata operations. So what is the `Cacheable (Dependency a)` instance about? Normally, the output of a `Rule m a b` is re-used when the new input (of type `a`) is equal to the old one. But sometimes, that's too coarse: it might be that a certain `Rule m a b` only depends on a small part of its input of type `a`. A `Dependency` allows us to spell out what parts of `a` are being depended on, and these parts are recorded as values of types `Access a` in the state `Accesses`. If the input `a` changes, but not in a way that touches the recorded `Accesses`, then the output `b` of that rule can be re-used without recomputing. So now you understand _why_ we're passing `Accesses` to the `unchanged` method: `unchanged` is an equality check in disguise that just needs some additional context. But we don't need to pass `Accesses` as a function argument. We can use the `reflection` package to pass it as type-level context. So the core of this PR is that we change the instance declaration from ```haskell instance (Cacheable a) => Cacheable (Dependency a) where ``` to ```haskell instance (Given Accesses, Eq a) => Eq (Dependency a) where ``` and use `(==)` instead of `unchanged`. If you haven't seen `reflection` before: it's like a `MonadReader`, but it doesn't require a `Monad`. In order to pass the current `Accesses` value, instead of simply passing the `Accesses` as a function argument, we need to instantiate the `Given Accesses` context. We use the `give` method from the `reflection` package for that. ```haskell give :: forall r. Accesses -> (Given Accesses => r) -> r unchanged :: (Given Accesses => Eq a) => Accesses -> a -> a -> Bool unchanged accesses a b = give accesses (a == b) ``` With these three components in place, we can delete the `Cacheable` type class entirely. The remainder of this PR is just to remove the `Cacheable` type class and its instances. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6877 GitOrigin-RevId: 7125f5e11d856e7672ab810a23d5bf5ad176e77f
355 lines
12 KiB
Haskell
355 lines
12 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
||
{-# LANGUAGE TemplateHaskell #-}
|
||
{-# LANGUAGE UndecidableInstances #-}
|
||
|
||
-- | Types/functions shared between modules that implement "Hasura.RQL.DDL.Schema.Cache". Other
|
||
-- modules should not import this module directly.
|
||
module Hasura.RQL.DDL.Schema.Cache.Common
|
||
( ApolloFederationConfig (..),
|
||
ApolloFederationVersion (..),
|
||
BackendInvalidationKeysWrapper (..),
|
||
BuildOutputs (..),
|
||
CacheBuild,
|
||
CacheBuildParams (CacheBuildParams),
|
||
InvalidationKeys (..),
|
||
ikMetadata,
|
||
ikRemoteSchemas,
|
||
ikSources,
|
||
ikBackends,
|
||
NonColumnTableInputs (..),
|
||
RebuildableSchemaCache (RebuildableSchemaCache, lastBuiltSchemaCache),
|
||
TableBuildInput (TableBuildInput, _tbiName),
|
||
TablePermissionInputs (..),
|
||
addTableContext,
|
||
bindErrorA,
|
||
boActions,
|
||
boCronTriggers,
|
||
boCustomTypes,
|
||
boBackendCache,
|
||
boEndpoints,
|
||
boOpenTelemetryInfo,
|
||
boRemoteSchemas,
|
||
boRoles,
|
||
boSources,
|
||
buildInfoMap,
|
||
buildInfoMapPreservingMetadata,
|
||
initialInvalidationKeys,
|
||
invalidateKeys,
|
||
mkTableInputs,
|
||
runCacheBuild,
|
||
runCacheBuildM,
|
||
withRecordDependencies,
|
||
)
|
||
where
|
||
|
||
import Control.Arrow.Extended
|
||
import Control.Arrow.Interpret
|
||
import Control.Lens
|
||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||
import Control.Monad.Unique
|
||
import Data.HashMap.Strict.Extended qualified as M
|
||
import Data.HashMap.Strict.InsOrd qualified as OMap
|
||
import Data.Sequence qualified as Seq
|
||
import Data.Text.Extended
|
||
import Hasura.Base.Error
|
||
import Hasura.Incremental qualified as Inc
|
||
import Hasura.Prelude
|
||
import Hasura.RQL.Types.Backend
|
||
import Hasura.RQL.Types.Common
|
||
import Hasura.RQL.Types.CustomTypes
|
||
import Hasura.RQL.Types.Endpoint
|
||
import Hasura.RQL.Types.EventTrigger
|
||
import Hasura.RQL.Types.Metadata
|
||
import Hasura.RQL.Types.Metadata.Backend (BackendMetadata (..))
|
||
import Hasura.RQL.Types.Metadata.Instances ()
|
||
import Hasura.RQL.Types.Metadata.Object
|
||
import Hasura.RQL.Types.OpenTelemetry (OpenTelemetryInfo)
|
||
import Hasura.RQL.Types.Permission
|
||
import Hasura.RQL.Types.QueryCollection
|
||
import Hasura.RQL.Types.Relationships.Local
|
||
import Hasura.RQL.Types.Relationships.Remote
|
||
import Hasura.RQL.Types.Roles
|
||
import Hasura.RQL.Types.SchemaCache
|
||
import Hasura.RQL.Types.SchemaCache.Build
|
||
import Hasura.RQL.Types.Source
|
||
import Hasura.RemoteSchema.Metadata
|
||
import Hasura.SQL.Backend
|
||
import Hasura.SQL.BackendMap (BackendMap)
|
||
import Hasura.SQL.BackendMap qualified as BackendMap
|
||
import Hasura.Server.Types
|
||
import Hasura.Session
|
||
import Network.HTTP.Client.Manager (HasHttpManagerM (..))
|
||
import Network.HTTP.Client.Transformable qualified as HTTP
|
||
|
||
newtype BackendInvalidationKeysWrapper (b :: BackendType) = BackendInvalidationKeysWrapper
|
||
{ unBackendInvalidationKeysWrapper :: BackendInvalidationKeys b
|
||
}
|
||
|
||
deriving newtype instance Eq (BackendInvalidationKeys b) => Eq (BackendInvalidationKeysWrapper b)
|
||
|
||
deriving newtype instance Ord (BackendInvalidationKeys b) => Ord (BackendInvalidationKeysWrapper b)
|
||
|
||
deriving newtype instance Show (BackendInvalidationKeys b) => Show (BackendInvalidationKeysWrapper b)
|
||
|
||
deriving newtype instance Semigroup (BackendInvalidationKeys b) => Semigroup (BackendInvalidationKeysWrapper b)
|
||
|
||
deriving newtype instance Monoid (BackendInvalidationKeys b) => Monoid (BackendInvalidationKeysWrapper b)
|
||
|
||
instance Inc.Select (BackendInvalidationKeysWrapper b)
|
||
|
||
-- | 'InvalidationKeys' used to apply requested 'CacheInvalidations'.
|
||
data InvalidationKeys = InvalidationKeys
|
||
{ _ikMetadata :: Inc.InvalidationKey,
|
||
_ikRemoteSchemas :: HashMap RemoteSchemaName Inc.InvalidationKey,
|
||
_ikSources :: HashMap SourceName Inc.InvalidationKey,
|
||
_ikBackends :: BackendMap BackendInvalidationKeysWrapper
|
||
}
|
||
deriving (Show, Eq, Generic)
|
||
|
||
instance Inc.Select InvalidationKeys
|
||
|
||
$(makeLenses ''InvalidationKeys)
|
||
|
||
initialInvalidationKeys :: InvalidationKeys
|
||
initialInvalidationKeys = InvalidationKeys Inc.initialInvalidationKey mempty mempty mempty
|
||
|
||
invalidateKeys :: CacheInvalidations -> InvalidationKeys -> InvalidationKeys
|
||
invalidateKeys CacheInvalidations {..} InvalidationKeys {..} =
|
||
InvalidationKeys
|
||
{ _ikMetadata = if ciMetadata then Inc.invalidate _ikMetadata else _ikMetadata,
|
||
_ikRemoteSchemas = foldl' (flip invalidate) _ikRemoteSchemas ciRemoteSchemas,
|
||
_ikSources = foldl' (flip invalidate) _ikSources ciSources,
|
||
_ikBackends = BackendMap.modify @'DataConnector invalidateDataConnectors _ikBackends
|
||
}
|
||
where
|
||
invalidate ::
|
||
Hashable a =>
|
||
a ->
|
||
HashMap a Inc.InvalidationKey ->
|
||
HashMap a Inc.InvalidationKey
|
||
invalidate = M.alter $ Just . maybe Inc.initialInvalidationKey Inc.invalidate
|
||
|
||
invalidateDataConnectors :: BackendInvalidationKeysWrapper 'DataConnector -> BackendInvalidationKeysWrapper 'DataConnector
|
||
invalidateDataConnectors (BackendInvalidationKeysWrapper invalidationKeys) =
|
||
BackendInvalidationKeysWrapper $ foldl' (flip invalidate) invalidationKeys ciDataConnectors
|
||
|
||
data TableBuildInput b = TableBuildInput
|
||
{ _tbiName :: TableName b,
|
||
_tbiIsEnum :: Bool,
|
||
_tbiConfiguration :: TableConfig b,
|
||
_tbiApolloFederationConfig :: Maybe ApolloFederationConfig
|
||
}
|
||
deriving (Show, Eq, Generic)
|
||
|
||
instance (Backend b) => NFData (TableBuildInput b)
|
||
|
||
data NonColumnTableInputs b = NonColumnTableInputs
|
||
{ _nctiTable :: TableName b,
|
||
_nctiObjectRelationships :: [ObjRelDef b],
|
||
_nctiArrayRelationships :: [ArrRelDef b],
|
||
_nctiComputedFields :: [ComputedFieldMetadata b],
|
||
_nctiRemoteRelationships :: [RemoteRelationship]
|
||
}
|
||
deriving (Show, Eq, Generic)
|
||
|
||
data TablePermissionInputs b = TablePermissionInputs
|
||
{ _tpiTable :: TableName b,
|
||
_tpiInsert :: [InsPermDef b],
|
||
_tpiSelect :: [SelPermDef b],
|
||
_tpiUpdate :: [UpdPermDef b],
|
||
_tpiDelete :: [DelPermDef b]
|
||
}
|
||
deriving (Generic)
|
||
|
||
deriving instance (Backend b) => Show (TablePermissionInputs b)
|
||
|
||
deriving instance (Backend b) => Eq (TablePermissionInputs b)
|
||
|
||
mkTableInputs ::
|
||
TableMetadata b -> (TableBuildInput b, NonColumnTableInputs b, TablePermissionInputs b)
|
||
mkTableInputs TableMetadata {..} =
|
||
(buildInput, nonColumns, permissions)
|
||
where
|
||
buildInput = TableBuildInput _tmTable _tmIsEnum _tmConfiguration _tmApolloFederationConfig
|
||
nonColumns =
|
||
NonColumnTableInputs
|
||
_tmTable
|
||
(OMap.elems _tmObjectRelationships)
|
||
(OMap.elems _tmArrayRelationships)
|
||
(OMap.elems _tmComputedFields)
|
||
(OMap.elems _tmRemoteRelationships)
|
||
permissions =
|
||
TablePermissionInputs
|
||
_tmTable
|
||
(OMap.elems _tmInsertPermissions)
|
||
(OMap.elems _tmSelectPermissions)
|
||
(OMap.elems _tmUpdatePermissions)
|
||
(OMap.elems _tmDeletePermissions)
|
||
|
||
-- | The direct output of 'buildSchemaCacheRule'. Contains most of the things necessary to build a
|
||
-- schema cache, but dependencies and inconsistent metadata objects are collected via a separate
|
||
-- 'MonadWriter' side channel.
|
||
data BuildOutputs = BuildOutputs
|
||
{ _boSources :: SourceCache,
|
||
_boActions :: ActionCache,
|
||
-- | We preserve the 'MetadataObject' from the original catalog metadata in the output so we can
|
||
-- reuse it later if we need to mark the remote schema inconsistent during GraphQL schema
|
||
-- generation (because of field conflicts).
|
||
_boRemoteSchemas :: HashMap RemoteSchemaName (RemoteSchemaCtx, MetadataObject),
|
||
_boCustomTypes :: AnnotatedCustomTypes,
|
||
_boCronTriggers :: M.HashMap TriggerName CronTriggerInfo,
|
||
_boEndpoints :: M.HashMap EndpointName (EndpointMetadata GQLQueryWithText),
|
||
_boRoles :: HashMap RoleName Role,
|
||
_boBackendCache :: BackendCache,
|
||
_boOpenTelemetryInfo :: OpenTelemetryInfo
|
||
}
|
||
|
||
$(makeLenses ''BuildOutputs)
|
||
|
||
-- | Parameters required for schema cache build
|
||
data CacheBuildParams = CacheBuildParams
|
||
{ _cbpManager :: HTTP.Manager,
|
||
_cbpPGSourceResolver :: SourceResolver ('Postgres 'Vanilla),
|
||
_cbpMSSQLSourceResolver :: SourceResolver 'MSSQL,
|
||
_cbpServerConfigCtx :: ServerConfigCtx
|
||
}
|
||
|
||
-- | The monad in which @'RebuildableSchemaCache' is being run
|
||
newtype CacheBuild a = CacheBuild (ReaderT CacheBuildParams (ExceptT QErr IO) a)
|
||
deriving
|
||
( Functor,
|
||
Applicative,
|
||
Monad,
|
||
MonadError QErr,
|
||
MonadReader CacheBuildParams,
|
||
MonadIO,
|
||
MonadBase IO,
|
||
MonadBaseControl IO,
|
||
MonadUnique
|
||
)
|
||
|
||
instance HasHttpManagerM CacheBuild where
|
||
askHttpManager = asks _cbpManager
|
||
|
||
instance HasServerConfigCtx CacheBuild where
|
||
askServerConfigCtx = asks _cbpServerConfigCtx
|
||
|
||
instance MonadResolveSource CacheBuild where
|
||
getPGSourceResolver = asks _cbpPGSourceResolver
|
||
getMSSQLSourceResolver = asks _cbpMSSQLSourceResolver
|
||
|
||
runCacheBuild ::
|
||
( MonadIO m,
|
||
MonadError QErr m
|
||
) =>
|
||
CacheBuildParams ->
|
||
CacheBuild a ->
|
||
m a
|
||
runCacheBuild params (CacheBuild m) = do
|
||
liftEitherM $ liftIO $ runExceptT (runReaderT m params)
|
||
|
||
runCacheBuildM ::
|
||
( MonadIO m,
|
||
MonadError QErr m,
|
||
HasHttpManagerM m,
|
||
HasServerConfigCtx m,
|
||
MonadResolveSource m
|
||
) =>
|
||
CacheBuild a ->
|
||
m a
|
||
runCacheBuildM m = do
|
||
params <-
|
||
CacheBuildParams
|
||
<$> askHttpManager
|
||
<*> getPGSourceResolver
|
||
<*> getMSSQLSourceResolver
|
||
<*> askServerConfigCtx
|
||
runCacheBuild params m
|
||
|
||
data RebuildableSchemaCache = RebuildableSchemaCache
|
||
{ lastBuiltSchemaCache :: SchemaCache,
|
||
_rscInvalidationMap :: InvalidationKeys,
|
||
_rscRebuild :: Inc.Rule (ReaderT BuildReason CacheBuild) (Metadata, InvalidationKeys) SchemaCache
|
||
}
|
||
|
||
bindErrorA ::
|
||
(ArrowChoice arr, ArrowKleisli m arr, ArrowError e arr, MonadError e m) =>
|
||
arr (m a) a
|
||
bindErrorA = liftEitherA <<< arrM \m -> (Right <$> m) `catchError` (pure . Left)
|
||
{-# INLINE bindErrorA #-}
|
||
|
||
withRecordDependencies ::
|
||
(ArrowWriter (Seq (Either im MetadataDependency)) arr) =>
|
||
WriterA (Seq SchemaDependency) arr (e, s) a ->
|
||
arr (e, (MetadataObject, (SchemaObjId, s))) a
|
||
withRecordDependencies f = proc (e, (metadataObject, (schemaObjectId, s))) -> do
|
||
(result, dependencies) <- runWriterA f -< (e, s)
|
||
recordDependencies -< (metadataObject, schemaObjectId, toList dependencies)
|
||
returnA -< result
|
||
{-# INLINEABLE withRecordDependencies #-}
|
||
|
||
noDuplicates ::
|
||
(MonadWriter (Seq (Either InconsistentMetadata md)) m) =>
|
||
(a -> MetadataObject) ->
|
||
[a] ->
|
||
m (Maybe a)
|
||
noDuplicates mkMetadataObject = \case
|
||
[] -> pure Nothing
|
||
[value] -> pure $ Just value
|
||
values@(value : _) -> do
|
||
let objectId = _moId $ mkMetadataObject value
|
||
definitions = map (_moDefinition . mkMetadataObject) values
|
||
tell $ Seq.singleton $ Left (DuplicateObjects objectId definitions)
|
||
return Nothing
|
||
|
||
-- | Processes a list of catalog metadata into a map of processed information, marking any duplicate
|
||
-- entries inconsistent.
|
||
buildInfoMap ::
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
ArrowWriter (Seq (Either InconsistentMetadata md)) arr,
|
||
Hashable k
|
||
) =>
|
||
(a -> k) ->
|
||
(a -> MetadataObject) ->
|
||
(e, a) `arr` Maybe b ->
|
||
(e, [a]) `arr` HashMap k b
|
||
buildInfoMap extractKey mkMetadataObject buildInfo = proc (e, infos) -> do
|
||
let groupedInfos = M.groupOn extractKey infos
|
||
infoMapMaybes <-
|
||
(|
|
||
Inc.keyed
|
||
( \_ duplicateInfos -> do
|
||
infoMaybe <- interpretWriter -< noDuplicates mkMetadataObject duplicateInfos
|
||
case infoMaybe of
|
||
Nothing -> returnA -< Nothing
|
||
Just info -> buildInfo -< (e, info)
|
||
)
|
||
|) groupedInfos
|
||
returnA -< catMaybes infoMapMaybes
|
||
{-# INLINEABLE buildInfoMap #-}
|
||
|
||
-- | Like 'buildInfo', but includes each processed info’s associated 'MetadataObject' in the result.
|
||
-- This is useful if the results will be further processed, and the 'MetadataObject' is still needed
|
||
-- to mark the object inconsistent.
|
||
buildInfoMapPreservingMetadata ::
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
ArrowWriter (Seq (Either InconsistentMetadata MetadataDependency)) arr,
|
||
Hashable k
|
||
) =>
|
||
(a -> k) ->
|
||
(a -> MetadataObject) ->
|
||
(e, a) `arr` Maybe b ->
|
||
(e, [a]) `arr` HashMap k (b, MetadataObject)
|
||
buildInfoMapPreservingMetadata extractKey mkMetadataObject buildInfo =
|
||
buildInfoMap extractKey mkMetadataObject buildInfoPreserving
|
||
where
|
||
buildInfoPreserving = proc (e, info) -> do
|
||
result <- buildInfo -< (e, info)
|
||
returnA -< result <&> (,mkMetadataObject info)
|
||
{-# INLINEABLE buildInfoMapPreservingMetadata #-}
|
||
|
||
addTableContext :: (Backend b) => TableName b -> Text -> Text
|
||
addTableContext tableName e = "in table " <> tableName <<> ": " <> e
|