mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-18 13:02:11 +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
179 lines
8.4 KiB
Haskell
179 lines
8.4 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
||
|
||
module Hasura.RemoteSchema.SchemaCache.Build
|
||
( buildRemoteSchemas,
|
||
addRemoteSchemaP2Setup,
|
||
)
|
||
where
|
||
|
||
import Control.Arrow.Extended
|
||
import Control.Arrow.Interpret
|
||
import Data.Aeson
|
||
import Data.ByteString.Lazy qualified as BL
|
||
import Data.Environment qualified as Env
|
||
import Data.HashMap.Strict.Extended qualified as M
|
||
import Data.Text.Extended
|
||
import Hasura.Base.Error
|
||
import Hasura.GraphQL.RemoteServer (fetchRemoteSchema)
|
||
import Hasura.Incremental qualified as Inc
|
||
import Hasura.Prelude
|
||
import Hasura.RQL.DDL.Schema.Cache.Common
|
||
import Hasura.RQL.DDL.Schema.Cache.Permission
|
||
import Hasura.RQL.Types.Metadata.Object
|
||
import Hasura.RQL.Types.Roles
|
||
import Hasura.RQL.Types.Roles.Internal (CheckPermission (..))
|
||
import Hasura.RQL.Types.SchemaCache
|
||
import Hasura.RQL.Types.SchemaCache.Build
|
||
import Hasura.RemoteSchema.Metadata
|
||
import Hasura.RemoteSchema.SchemaCache.Permission (resolveRoleBasedRemoteSchema)
|
||
import Hasura.RemoteSchema.SchemaCache.Types
|
||
import Hasura.Session
|
||
import Hasura.Tracing qualified as Tracing
|
||
import Network.HTTP.Client.Manager (HasHttpManagerM (..))
|
||
|
||
-- Resolves a user specified `RemoteSchemaMetadata` into information rich `RemoteSchemaCtx`
|
||
-- However, given the nature of remote relationships, we cannot fully 'resolve' them, so
|
||
-- we resolve of remote relationships as much as possible.
|
||
buildRemoteSchemas ::
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
ArrowWriter (Seq (Either InconsistentMetadata MetadataDependency)) arr,
|
||
Inc.ArrowCache m arr,
|
||
MonadIO m,
|
||
HasHttpManagerM m,
|
||
Eq remoteRelationshipDefinition,
|
||
ToJSON remoteRelationshipDefinition,
|
||
MonadError QErr m
|
||
) =>
|
||
Env.Environment ->
|
||
( (Inc.Dependency (HashMap RemoteSchemaName Inc.InvalidationKey), OrderedRoles),
|
||
[RemoteSchemaMetadataG remoteRelationshipDefinition]
|
||
)
|
||
`arr` HashMap RemoteSchemaName (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition, MetadataObject)
|
||
buildRemoteSchemas env =
|
||
buildInfoMapPreservingMetadata _rsmName mkRemoteSchemaMetadataObject buildRemoteSchema
|
||
where
|
||
-- We want to cache this call because it fetches the remote schema over
|
||
-- HTTP, and we don’t want to re-run that if the remote schema definition
|
||
-- hasn’t changed.
|
||
buildRemoteSchema = Inc.cache proc ((invalidationKeys, orderedRoles), remoteSchema@(RemoteSchemaMetadata name defn _comment permissions relationships)) -> do
|
||
Inc.dependOn -< Inc.selectKeyD name invalidationKeys
|
||
remoteSchemaContextParts <-
|
||
(|
|
||
withRecordInconsistency
|
||
( liftEitherA <<< bindA
|
||
-<
|
||
runExceptT $ noopTrace $ addRemoteSchemaP2Setup env name defn
|
||
)
|
||
|) (mkRemoteSchemaMetadataObject remoteSchema)
|
||
case remoteSchemaContextParts of
|
||
Nothing -> returnA -< Nothing
|
||
Just (introspection, rawIntrospection, remoteSchemaInfo) -> do
|
||
-- we then resolve permissions
|
||
resolvedPermissions <- buildRemoteSchemaPermissions -< ((name, introspection, orderedRoles), fmap (name,) permissions)
|
||
-- resolve remote relationships
|
||
let transformedRelationships = flip fmap relationships $ \RemoteSchemaTypeRelationships {..} -> fmap (PartiallyResolvedRemoteRelationship _rstrsName) _rstrsRelationships
|
||
let remoteSchemaContext =
|
||
RemoteSchemaCtx
|
||
{ _rscName = name,
|
||
_rscIntroOriginal = introspection,
|
||
_rscInfo = remoteSchemaInfo,
|
||
_rscRawIntrospectionResult = rawIntrospection,
|
||
_rscPermissions = resolvedPermissions,
|
||
_rscRemoteRelationships = transformedRelationships
|
||
}
|
||
returnA -< Just remoteSchemaContext
|
||
|
||
-- TODO continue propagating MonadTrace up calls so that we can get tracing
|
||
-- for remote schema introspection. This will require modifying CacheBuild.
|
||
noopTrace = Tracing.runTraceTWithReporter Tracing.noReporter "buildSchemaCacheRule"
|
||
|
||
mkRemoteSchemaMetadataObject remoteSchema =
|
||
MetadataObject (MORemoteSchema (_rsmName remoteSchema)) (toJSON remoteSchema)
|
||
|
||
-- | Resolves a RemoteSchemaPermission metadata object into a 'GraphQL schema'.
|
||
buildRemoteSchemaPermissions ::
|
||
( ArrowChoice arr,
|
||
Inc.ArrowDistribute arr,
|
||
ArrowWriter (Seq (Either InconsistentMetadata MetadataDependency)) arr,
|
||
Inc.ArrowCache m arr,
|
||
MonadError QErr m
|
||
) =>
|
||
-- this ridiculous duplication of [(RemoteSchemaName, RemoteSchemaPermissionMetadata)]
|
||
-- instead of just [RemoteSchemaName] is because buildInfoMap doesn't pass `e` to the
|
||
-- mkMetadataObject function. However, that change is very invasive.
|
||
((RemoteSchemaName, IntrospectionResult, OrderedRoles), [(RemoteSchemaName, RemoteSchemaPermissionMetadata)]) `arr` M.HashMap RoleName IntrospectionResult
|
||
buildRemoteSchemaPermissions = proc ((remoteSchemaName, originalIntrospection, orderedRoles), permissions) -> do
|
||
metadataPermissionsMap <- do
|
||
buildInfoMap (_rspmRole . snd) mkRemoteSchemaPermissionMetadataObject buildRemoteSchemaPermission
|
||
-<
|
||
(originalIntrospection, permissions)
|
||
-- convert to the intermediate form `CheckPermission` whose `Semigroup`
|
||
-- instance is used to combine permissions
|
||
let metadataCheckPermissionsMap = CPDefined <$> metadataPermissionsMap
|
||
allRolesUnresolvedPermissionsMap <-
|
||
bindA
|
||
-<
|
||
foldM
|
||
( \accumulatedRolePermMap (Role roleName (ParentRoles parentRoles)) -> do
|
||
rolePermission <- onNothing (M.lookup roleName accumulatedRolePermMap) $ do
|
||
parentRolePermissions <-
|
||
for (toList parentRoles) $ \role ->
|
||
onNothing (M.lookup role accumulatedRolePermMap) $
|
||
throw500 $
|
||
"remote schema permissions: bad ordering of roles, could not find the permission of role: " <>> role
|
||
let combinedPermission = sconcat <$> nonEmpty parentRolePermissions
|
||
pure $ fromMaybe CPUndefined combinedPermission
|
||
pure $ M.insert roleName rolePermission accumulatedRolePermMap
|
||
)
|
||
metadataCheckPermissionsMap
|
||
(_unOrderedRoles orderedRoles)
|
||
-- traverse through `allRolesUnresolvedPermissionsMap` to record any inconsistencies (if exists)
|
||
resolvedPermissions <-
|
||
interpretWriter
|
||
-< for (M.toList allRolesUnresolvedPermissionsMap) \(roleName, checkPermission) -> do
|
||
let inconsistentRoleEntity = InconsistentRemoteSchemaPermission remoteSchemaName
|
||
resolvedCheckPermission <- resolveCheckPermission checkPermission roleName inconsistentRoleEntity
|
||
return (roleName, resolvedCheckPermission)
|
||
returnA -< catMaybes $ M.fromList resolvedPermissions
|
||
where
|
||
buildRemoteSchemaPermission = proc (originalIntrospection, (remoteSchemaName, remoteSchemaPerm)) -> do
|
||
let RemoteSchemaPermissionMetadata roleName defn _ = remoteSchemaPerm
|
||
metadataObject = mkRemoteSchemaPermissionMetadataObject (remoteSchemaName, remoteSchemaPerm)
|
||
schemaObject = SORemoteSchemaPermission remoteSchemaName roleName
|
||
providedSchemaDoc = _rspdSchema defn
|
||
addPermContext err = "in remote schema permission for role " <> roleName <<> ": " <> err
|
||
(|
|
||
withRecordInconsistency
|
||
( (|
|
||
modifyErrA
|
||
( do
|
||
(resolvedSchemaIntrospection, dependencies) <-
|
||
liftEitherA <<< bindA
|
||
-<
|
||
runExceptT $ resolveRoleBasedRemoteSchema roleName remoteSchemaName originalIntrospection providedSchemaDoc
|
||
recordDependencies -< (metadataObject, schemaObject, dependencies)
|
||
returnA -< resolvedSchemaIntrospection
|
||
)
|
||
|) addPermContext
|
||
)
|
||
|) metadataObject
|
||
|
||
mkRemoteSchemaPermissionMetadataObject ::
|
||
(RemoteSchemaName, RemoteSchemaPermissionMetadata) ->
|
||
MetadataObject
|
||
mkRemoteSchemaPermissionMetadataObject (rsName, (RemoteSchemaPermissionMetadata roleName defn _)) =
|
||
let objectId = MORemoteSchemaPermissions rsName roleName
|
||
in MetadataObject objectId $ toJSON defn
|
||
|
||
addRemoteSchemaP2Setup ::
|
||
(QErrM m, MonadIO m, HasHttpManagerM m, Tracing.MonadTrace m) =>
|
||
Env.Environment ->
|
||
RemoteSchemaName ->
|
||
RemoteSchemaDef ->
|
||
m (IntrospectionResult, BL.ByteString, RemoteSchemaInfo)
|
||
addRemoteSchemaP2Setup env name def = do
|
||
httpMgr <- askHttpManager
|
||
rsi <- validateRemoteSchemaDef env def
|
||
fetchRemoteSchema env httpMgr name rsi
|