{-# LANGUAGE Arrows #-}

module Hasura.RemoteSchema.SchemaCache.Build
  ( buildRemoteSchemas,
    addRemoteSchemaP2Setup,
  )
where

import Control.Arrow.Extended
import Control.Arrow.Interpret
import Control.Monad.Trans.Control
import Data.Aeson
import Data.ByteString.Lazy qualified as BL
import Data.Environment qualified as Env
import Data.HashMap.Strict.Extended qualified as HashMap
import Data.Text qualified as T
import Data.Text.Extended
import Hasura.Base.Error
import Hasura.EncJSON (encJFromLBS)
import Hasura.GraphQL.RemoteServer
import Hasura.Incremental qualified as Inc
import Hasura.Logging
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.Services
import Hasura.Tracing qualified as Tracing

-- 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 CollectItem) arr,
    Inc.ArrowCache m arr,
    MonadIO m,
    MonadBaseControl IO m,
    Eq remoteRelationshipDefinition,
    ToJSON remoteRelationshipDefinition,
    MonadError QErr m,
    ProvidesNetwork m
  ) =>
  Logger Hasura ->
  Env.Environment ->
  ( (Inc.Dependency (HashMap RemoteSchemaName Inc.InvalidationKey), OrderedRoles, Maybe (HashMap RemoteSchemaName BL.ByteString)),
    [RemoteSchemaMetadataG remoteRelationshipDefinition]
  )
    `arr` HashMap RemoteSchemaName (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition, MetadataObject)
buildRemoteSchemas :: forall (arr :: * -> * -> *) (m :: * -> *)
       remoteRelationshipDefinition.
(ArrowChoice arr, ArrowDistribute arr,
 ArrowWriter (Seq CollectItem) arr, ArrowCache m arr, MonadIO m,
 MonadBaseControl IO m, Eq remoteRelationshipDefinition,
 ToJSON remoteRelationshipDefinition, MonadError QErr m,
 ProvidesNetwork m) =>
Logger Hasura
-> Environment
-> arr
     ((Dependency (HashMap RemoteSchemaName InvalidationKey),
       OrderedRoles, Maybe (HashMap RemoteSchemaName ByteString)),
      [RemoteSchemaMetadataG remoteRelationshipDefinition])
     (HashMap
        RemoteSchemaName
        (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition,
         MetadataObject))
buildRemoteSchemas Logger Hasura
logger Environment
env =
  (RemoteSchemaMetadataG remoteRelationshipDefinition
 -> RemoteSchemaName)
-> (RemoteSchemaMetadataG remoteRelationshipDefinition
    -> MetadataObject)
-> arr
     ((Dependency (HashMap RemoteSchemaName InvalidationKey),
       OrderedRoles, Maybe (HashMap RemoteSchemaName ByteString)),
      RemoteSchemaMetadataG remoteRelationshipDefinition)
     (Maybe
        (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition))
-> arr
     ((Dependency (HashMap RemoteSchemaName InvalidationKey),
       OrderedRoles, Maybe (HashMap RemoteSchemaName ByteString)),
      [RemoteSchemaMetadataG remoteRelationshipDefinition])
     (HashMap
        RemoteSchemaName
        (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition,
         MetadataObject))
forall (arr :: * -> * -> *) k a e b.
(ArrowChoice arr, ArrowDistribute arr,
 ArrowWriter (Seq CollectItem) arr, Hashable k) =>
(a -> k)
-> (a -> MetadataObject)
-> arr (e, a) (Maybe b)
-> arr (e, [a]) (HashMap k (b, MetadataObject))
buildInfoMapPreservingMetadata RemoteSchemaMetadataG remoteRelationshipDefinition
-> RemoteSchemaName
forall r. RemoteSchemaMetadataG r -> RemoteSchemaName
_rsmName RemoteSchemaMetadataG remoteRelationshipDefinition
-> MetadataObject
forall {r}. ToJSON r => RemoteSchemaMetadataG r -> MetadataObject
mkRemoteSchemaMetadataObject arr
  ((Dependency (HashMap RemoteSchemaName InvalidationKey),
    OrderedRoles, Maybe (HashMap RemoteSchemaName ByteString)),
   RemoteSchemaMetadataG remoteRelationshipDefinition)
  (Maybe
     (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition))
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 :: arr
  ((Dependency (HashMap RemoteSchemaName InvalidationKey),
    OrderedRoles, Maybe (HashMap RemoteSchemaName ByteString)),
   RemoteSchemaMetadataG remoteRelationshipDefinition)
  (Maybe
     (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition))
buildRemoteSchema = arr
  ((Dependency (HashMap RemoteSchemaName InvalidationKey),
    OrderedRoles, Maybe (HashMap RemoteSchemaName ByteString)),
   RemoteSchemaMetadataG remoteRelationshipDefinition)
  (Maybe
     (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition))
-> arr
     ((Dependency (HashMap RemoteSchemaName InvalidationKey),
       OrderedRoles, Maybe (HashMap RemoteSchemaName ByteString)),
      RemoteSchemaMetadataG remoteRelationshipDefinition)
     (Maybe
        (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition))
forall a b. (Given Accesses => Eq a) => arr a b -> arr a b
forall (m :: * -> *) (arr :: * -> * -> *) a b.
(ArrowCache m arr, Given Accesses => Eq a) =>
arr a b -> arr a b
Inc.cache proc ((Dependency (HashMap RemoteSchemaName InvalidationKey)
invalidationKeys, OrderedRoles
orderedRoles, Maybe (HashMap RemoteSchemaName ByteString)
storedIntrospection), remoteSchema :: RemoteSchemaMetadataG remoteRelationshipDefinition
remoteSchema@(RemoteSchemaMetadata RemoteSchemaName
name RemoteSchemaDef
defn Maybe Text
_comment [RemoteSchemaPermissionMetadata]
permissions SchemaRemoteRelationships remoteRelationshipDefinition
relationships)) -> do
      arr (Dependency (Maybe InvalidationKey)) (Maybe InvalidationKey)
forall a. Eq a => arr (Dependency a) a
forall (m :: * -> *) (arr :: * -> * -> *) a.
(ArrowCache m arr, Eq a) =>
arr (Dependency a) a
Inc.dependOn -< RemoteSchemaName
-> Dependency (HashMap RemoteSchemaName InvalidationKey)
-> Dependency (Maybe InvalidationKey)
forall a k v.
(Select a, Selector a ~ ConstS k v) =>
k -> Dependency a -> Dependency v
Inc.selectKeyD RemoteSchemaName
name Dependency (HashMap RemoteSchemaName InvalidationKey)
invalidationKeys
      let metadataObj :: MetadataObject
metadataObj = RemoteSchemaMetadataG remoteRelationshipDefinition
-> MetadataObject
forall {r}. ToJSON r => RemoteSchemaMetadataG r -> MetadataObject
mkRemoteSchemaMetadataObject RemoteSchemaMetadataG remoteRelationshipDefinition
remoteSchema
      Either QErr (IntrospectionResult, ByteString, RemoteSchemaInfo)
upstreamResponse <- arr
  (m (Either
        QErr (IntrospectionResult, ByteString, RemoteSchemaInfo)))
  (Either QErr (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowKleisli m arr =>
arr (m a) a
bindA -< ExceptT QErr m (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> m (Either
        QErr (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (TraceT
  (ExceptT QErr m)
  (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> ExceptT
     QErr m (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall {m :: * -> *} {a}. TraceT m a -> m a
noopTrace (TraceT
   (ExceptT QErr m)
   (IntrospectionResult, ByteString, RemoteSchemaInfo)
 -> ExceptT
      QErr m (IntrospectionResult, ByteString, RemoteSchemaInfo))
-> TraceT
     (ExceptT QErr m)
     (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> ExceptT
     QErr m (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall a b. (a -> b) -> a -> b
$ Environment
-> RemoteSchemaDef
-> TraceT
     (ExceptT QErr m)
     (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall (m :: * -> *).
(QErrM m, MonadIO m, ProvidesNetwork m, MonadTrace m) =>
Environment
-> RemoteSchemaDef
-> m (IntrospectionResult, ByteString, RemoteSchemaInfo)
addRemoteSchemaP2Setup Environment
env RemoteSchemaDef
defn)
      Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo)
remoteSchemaContextParts <-
        case Either QErr (IntrospectionResult, ByteString, RemoteSchemaInfo)
upstreamResponse of
          Right upstream :: (IntrospectionResult, ByteString, RemoteSchemaInfo)
upstream@(IntrospectionResult
_, ByteString
byteString, RemoteSchemaInfo
_) -> do
            -- Collect upstream introspection response to persist in the storage
            arr (Seq CollectItem) ()
forall w (arr :: * -> * -> *). ArrowWriter w arr => arr w ()
tellA -< CollectItem -> Seq CollectItem
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoredIntrospectionItem -> CollectItem
CollectStoredIntrospection (StoredIntrospectionItem -> CollectItem)
-> StoredIntrospectionItem -> CollectItem
forall a b. (a -> b) -> a -> b
$ RemoteSchemaName -> EncJSON -> StoredIntrospectionItem
RemoteSchemaIntrospectionItem RemoteSchemaName
name (EncJSON -> StoredIntrospectionItem)
-> EncJSON -> StoredIntrospectionItem
forall a b. (a -> b) -> a -> b
$ ByteString -> EncJSON
encJFromLBS ByteString
byteString)
            arr
  (Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo))
  (Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall a. a -> Maybe a
Just (IntrospectionResult, ByteString, RemoteSchemaInfo)
upstream
          Left QErr
upstreamError -> do
            -- If upstream is not available, try to lookup from stored introspection
            case (RemoteSchemaName
-> HashMap RemoteSchemaName ByteString -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup RemoteSchemaName
name (HashMap RemoteSchemaName ByteString -> Maybe ByteString)
-> Maybe (HashMap RemoteSchemaName ByteString) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (HashMap RemoteSchemaName ByteString)
storedIntrospection) of
              Maybe ByteString
Nothing ->
                -- If no stored introspection exist, re-throw the upstream exception
                (| ErrorA
  QErr
  arr
  (a, ())
  (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> arr
     (a, (MetadataObject, ()))
     (Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall {a}.
ErrorA
  QErr
  arr
  (a, ())
  (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> arr
     (a, (MetadataObject, ()))
     (Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall (arr :: * -> * -> *) e s a.
(ArrowChoice arr, ArrowWriter (Seq CollectItem) arr) =>
ErrorA QErr arr (e, s) a -> arr (e, (MetadataObject, s)) (Maybe a)
withRecordInconsistency (ErrorA
  QErr arr QErr (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall a. ErrorA QErr arr QErr a
forall e (arr :: * -> * -> *) a. ArrowError e arr => arr e a
throwA -< QErr
upstreamError) |) MetadataObject
metadataObj
              Just ByteString
storedRawIntrospection -> do
                Either QErr (IntrospectionResult, ByteString, RemoteSchemaInfo)
processedIntrospection <-
                  arr
  (m (Either
        QErr (IntrospectionResult, ByteString, RemoteSchemaInfo)))
  (Either QErr (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowKleisli m arr =>
arr (m a) a
bindA
                    -< ExceptT QErr m (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> m (Either
        QErr (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
                      ValidatedRemoteSchemaDef
rsDef <- Environment
-> RemoteSchemaDef -> ExceptT QErr m ValidatedRemoteSchemaDef
forall (m :: * -> *).
MonadError QErr m =>
Environment -> RemoteSchemaDef -> m ValidatedRemoteSchemaDef
validateRemoteSchemaDef Environment
env RemoteSchemaDef
defn
                      (IntrospectionResult
ir, RemoteSchemaInfo
rsi) <- ByteString
-> ValidatedRemoteSchemaDef
-> ExceptT QErr m (IntrospectionResult, RemoteSchemaInfo)
forall (m :: * -> *).
(MonadIO m, MonadError QErr m) =>
ByteString
-> ValidatedRemoteSchemaDef
-> m (IntrospectionResult, RemoteSchemaInfo)
stitchRemoteSchema ByteString
storedRawIntrospection ValidatedRemoteSchemaDef
rsDef
                      (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> ExceptT
     QErr m (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall a. a -> ExceptT QErr m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntrospectionResult
ir, ByteString
storedRawIntrospection, RemoteSchemaInfo
rsi)
                case Either QErr (IntrospectionResult, ByteString, RemoteSchemaInfo)
processedIntrospection of
                  Right (IntrospectionResult, ByteString, RemoteSchemaInfo)
processed -> do
                    let inconsistencyMessage :: Text
inconsistencyMessage =
                          [Text] -> Text
T.unwords
                            [ Text
"remote schema " Text -> RemoteSchemaName -> Text
forall t. ToTxt t => Text -> t -> Text
<>> RemoteSchemaName
name,
                              Text
" is inconsistent because of stale remote schema introspection is used.",
                              Text
"The remote schema couldn't be reached for a fresh introspection",
                              Text
"because we got error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QErr -> Text
qeError QErr
upstreamError
                            ]
                    -- Still record inconsistency to notify the user obout the usage of stored stale data
                    arr ((Maybe Value, [MetadataObject]), Text) ()
forall (arr :: * -> * -> *) (f :: * -> *).
(ArrowWriter (Seq CollectItem) arr, Functor f, Foldable f) =>
arr ((Maybe Value, f MetadataObject), Text) ()
recordInconsistencies -< ((Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Maybe QErrExtra -> Value
forall a. ToJSON a => a -> Value
toJSON (QErr -> Maybe QErrExtra
qeInternal QErr
upstreamError), [MetadataObject
metadataObj]), Text
inconsistencyMessage)
                    arr (m ()) ()
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowKleisli m arr =>
arr (m a) a
bindA -< 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 (StoredIntrospectionLog -> m ()) -> StoredIntrospectionLog -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> QErr -> StoredIntrospectionLog
StoredIntrospectionLog (Text
"Using stored introspection for remote schema " Text -> RemoteSchemaName -> Text
forall t. ToTxt t => Text -> t -> Text
<>> RemoteSchemaName
name) QErr
upstreamError
                    arr
  (Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo))
  (Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall a. a -> Maybe a
Just (IntrospectionResult, ByteString, RemoteSchemaInfo)
processed
                  Left QErr
_processError ->
                    -- Unable to process stored introspection, give up and re-throw upstream exception
                    (| ErrorA
  QErr
  arr
  (a, ())
  (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> arr
     (a, (MetadataObject, ()))
     (Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall {a}.
ErrorA
  QErr
  arr
  (a, ())
  (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> arr
     (a, (MetadataObject, ()))
     (Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo))
forall (arr :: * -> * -> *) e s a.
(ArrowChoice arr, ArrowWriter (Seq CollectItem) arr) =>
ErrorA QErr arr (e, s) a -> arr (e, (MetadataObject, s)) (Maybe a)
withRecordInconsistency (ErrorA
  QErr arr QErr (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall a. ErrorA QErr arr QErr a
forall e (arr :: * -> * -> *) a. ArrowError e arr => arr e a
throwA -< QErr
upstreamError) |) MetadataObject
metadataObj
      case Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo)
remoteSchemaContextParts of
        Maybe (IntrospectionResult, ByteString, RemoteSchemaInfo)
Nothing -> arr
  (Maybe
     (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition))
  (Maybe
     (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Maybe
  (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition)
forall a. Maybe a
Nothing
        Just (IntrospectionResult
introspection, ByteString
rawIntrospection, RemoteSchemaInfo
remoteSchemaInfo) -> do
          -- we then resolve permissions
          HashMap RoleName IntrospectionResult
resolvedPermissions <- arr
  ((RemoteSchemaName, IntrospectionResult, OrderedRoles),
   [(RemoteSchemaName, RemoteSchemaPermissionMetadata)])
  (HashMap RoleName IntrospectionResult)
forall (arr :: * -> * -> *) (m :: * -> *).
(ArrowChoice arr, ArrowDistribute arr,
 ArrowWriter (Seq CollectItem) arr, ArrowKleisli m arr,
 MonadError QErr m) =>
arr
  ((RemoteSchemaName, IntrospectionResult, OrderedRoles),
   [(RemoteSchemaName, RemoteSchemaPermissionMetadata)])
  (HashMap RoleName IntrospectionResult)
buildRemoteSchemaPermissions -< ((RemoteSchemaName
name, IntrospectionResult
introspection, OrderedRoles
orderedRoles), (RemoteSchemaPermissionMetadata
 -> (RemoteSchemaName, RemoteSchemaPermissionMetadata))
-> [RemoteSchemaPermissionMetadata]
-> [(RemoteSchemaName, RemoteSchemaPermissionMetadata)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RemoteSchemaName
name,) [RemoteSchemaPermissionMetadata]
permissions)
          -- resolve remote relationships
          let transformedRelationships :: InsOrdHashMap
  Name
  (InsOrdHashMap
     RelName
     (PartiallyResolvedRemoteRelationship remoteRelationshipDefinition))
transformedRelationships = SchemaRemoteRelationships remoteRelationshipDefinition
relationships SchemaRemoteRelationships remoteRelationshipDefinition
-> (RemoteSchemaTypeRelationships remoteRelationshipDefinition
    -> InsOrdHashMap
         RelName
         (PartiallyResolvedRemoteRelationship remoteRelationshipDefinition))
-> InsOrdHashMap
     Name
     (InsOrdHashMap
        RelName
        (PartiallyResolvedRemoteRelationship remoteRelationshipDefinition))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \RemoteSchemaTypeRelationships {Name
RemoteRelationships remoteRelationshipDefinition
_rstrsName :: Name
_rstrsRelationships :: RemoteRelationships remoteRelationshipDefinition
_rstrsName :: forall r. RemoteSchemaTypeRelationships r -> Name
_rstrsRelationships :: forall r. RemoteSchemaTypeRelationships r -> RemoteRelationships r
..} -> Name
-> RemoteRelationshipG remoteRelationshipDefinition
-> PartiallyResolvedRemoteRelationship remoteRelationshipDefinition
forall remoteRelationshipDefinition.
Name
-> RemoteRelationshipG remoteRelationshipDefinition
-> PartiallyResolvedRemoteRelationship remoteRelationshipDefinition
PartiallyResolvedRemoteRelationship Name
_rstrsName (RemoteRelationshipG remoteRelationshipDefinition
 -> PartiallyResolvedRemoteRelationship
      remoteRelationshipDefinition)
-> RemoteRelationships remoteRelationshipDefinition
-> InsOrdHashMap
     RelName
     (PartiallyResolvedRemoteRelationship remoteRelationshipDefinition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RemoteRelationships remoteRelationshipDefinition
_rstrsRelationships
              remoteSchemaContext :: PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition
remoteSchemaContext =
                RemoteSchemaCtx
                  { _rscName :: RemoteSchemaName
_rscName = RemoteSchemaName
name,
                    _rscIntroOriginal :: IntrospectionResult
_rscIntroOriginal = IntrospectionResult
introspection,
                    _rscInfo :: RemoteSchemaInfo
_rscInfo = RemoteSchemaInfo
remoteSchemaInfo,
                    _rscRawIntrospectionResult :: ByteString
_rscRawIntrospectionResult = ByteString
rawIntrospection,
                    _rscPermissions :: HashMap RoleName IntrospectionResult
_rscPermissions = HashMap RoleName IntrospectionResult
resolvedPermissions,
                    _rscRemoteRelationships :: InsOrdHashMap
  Name
  (InsOrdHashMap
     RelName
     (PartiallyResolvedRemoteRelationship remoteRelationshipDefinition))
_rscRemoteRelationships = InsOrdHashMap
  Name
  (InsOrdHashMap
     RelName
     (PartiallyResolvedRemoteRelationship remoteRelationshipDefinition))
transformedRelationships
                  }
          arr
  (Maybe
     (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition))
  (Maybe
     (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition
-> Maybe
     (PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition)
forall a. a -> Maybe a
Just PartiallyResolvedRemoteSchemaCtxG remoteRelationshipDefinition
remoteSchemaContext

    -- TODO continue propagating MonadTrace up calls so that we can get tracing
    -- for remote schema introspection. This will require modifying CacheBuild.
    -- TODO(Antoine): do this when changing CacheBuild to be on top of the app's m.
    noopTrace :: TraceT m a -> m a
noopTrace = TraceT m a -> m a
forall {m :: * -> *} {a}. TraceT m a -> m a
Tracing.ignoreTraceT

    mkRemoteSchemaMetadataObject :: RemoteSchemaMetadataG r -> MetadataObject
mkRemoteSchemaMetadataObject RemoteSchemaMetadataG r
remoteSchema =
      MetadataObjId -> Value -> MetadataObject
MetadataObject (RemoteSchemaName -> MetadataObjId
MORemoteSchema (RemoteSchemaMetadataG r -> RemoteSchemaName
forall r. RemoteSchemaMetadataG r -> RemoteSchemaName
_rsmName RemoteSchemaMetadataG r
remoteSchema)) (RemoteSchemaMetadataG r -> Value
forall a. ToJSON a => a -> Value
toJSON RemoteSchemaMetadataG r
remoteSchema)

-- | Resolves a RemoteSchemaPermission metadata object into a 'GraphQL schema'.
buildRemoteSchemaPermissions ::
  ( ArrowChoice arr,
    Inc.ArrowDistribute arr,
    ArrowWriter (Seq CollectItem) arr,
    ArrowKleisli 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` HashMap.HashMap RoleName IntrospectionResult
buildRemoteSchemaPermissions :: forall (arr :: * -> * -> *) (m :: * -> *).
(ArrowChoice arr, ArrowDistribute arr,
 ArrowWriter (Seq CollectItem) arr, ArrowKleisli m arr,
 MonadError QErr m) =>
arr
  ((RemoteSchemaName, IntrospectionResult, OrderedRoles),
   [(RemoteSchemaName, RemoteSchemaPermissionMetadata)])
  (HashMap RoleName IntrospectionResult)
buildRemoteSchemaPermissions = proc ((RemoteSchemaName
remoteSchemaName, IntrospectionResult
originalIntrospection, OrderedRoles
orderedRoles), [(RemoteSchemaName, RemoteSchemaPermissionMetadata)]
permissions) -> do
  HashMap RoleName IntrospectionResult
metadataPermissionsMap <- do
    ((RemoteSchemaName, RemoteSchemaPermissionMetadata) -> RoleName)
-> ((RemoteSchemaName, RemoteSchemaPermissionMetadata)
    -> MetadataObject)
-> arr
     (IntrospectionResult,
      (RemoteSchemaName, RemoteSchemaPermissionMetadata))
     (Maybe IntrospectionResult)
-> arr
     (IntrospectionResult,
      [(RemoteSchemaName, RemoteSchemaPermissionMetadata)])
     (HashMap RoleName IntrospectionResult)
forall (arr :: * -> * -> *) k a e b.
(ArrowChoice arr, ArrowDistribute arr,
 ArrowWriter (Seq CollectItem) arr, Hashable k) =>
(a -> k)
-> (a -> MetadataObject)
-> arr (e, a) (Maybe b)
-> arr (e, [a]) (HashMap k b)
buildInfoMap (RemoteSchemaPermissionMetadata -> RoleName
_rspmRole (RemoteSchemaPermissionMetadata -> RoleName)
-> ((RemoteSchemaName, RemoteSchemaPermissionMetadata)
    -> RemoteSchemaPermissionMetadata)
-> (RemoteSchemaName, RemoteSchemaPermissionMetadata)
-> RoleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RemoteSchemaName, RemoteSchemaPermissionMetadata)
-> RemoteSchemaPermissionMetadata
forall a b. (a, b) -> b
snd) (RemoteSchemaName, RemoteSchemaPermissionMetadata)
-> MetadataObject
mkRemoteSchemaPermissionMetadataObject arr
  (IntrospectionResult,
   (RemoteSchemaName, RemoteSchemaPermissionMetadata))
  (Maybe IntrospectionResult)
buildRemoteSchemaPermission
      -<
        (IntrospectionResult
originalIntrospection, [(RemoteSchemaName, RemoteSchemaPermissionMetadata)]
permissions)
  -- convert to the intermediate form `CheckPermission` whose `Semigroup`
  -- instance is used to combine permissions
  let metadataCheckPermissionsMap :: HashMap RoleName (CheckPermission IntrospectionResult)
metadataCheckPermissionsMap = IntrospectionResult -> CheckPermission IntrospectionResult
forall permissionType.
permissionType -> CheckPermission permissionType
CPDefined (IntrospectionResult -> CheckPermission IntrospectionResult)
-> HashMap RoleName IntrospectionResult
-> HashMap RoleName (CheckPermission IntrospectionResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap RoleName IntrospectionResult
metadataPermissionsMap
  HashMap RoleName (CheckPermission IntrospectionResult)
allRolesUnresolvedPermissionsMap <-
    arr
  (m (HashMap RoleName (CheckPermission IntrospectionResult)))
  (HashMap RoleName (CheckPermission IntrospectionResult))
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowKleisli m arr =>
arr (m a) a
bindA
      -<
        (HashMap RoleName (CheckPermission IntrospectionResult)
 -> Role
 -> m (HashMap RoleName (CheckPermission IntrospectionResult)))
-> HashMap RoleName (CheckPermission IntrospectionResult)
-> [Role]
-> m (HashMap RoleName (CheckPermission IntrospectionResult))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
          ( \HashMap RoleName (CheckPermission IntrospectionResult)
accumulatedRolePermMap (Role RoleName
roleName (ParentRoles HashSet RoleName
parentRoles)) -> do
              CheckPermission IntrospectionResult
rolePermission <- Maybe (CheckPermission IntrospectionResult)
-> m (CheckPermission IntrospectionResult)
-> m (CheckPermission IntrospectionResult)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (RoleName
-> HashMap RoleName (CheckPermission IntrospectionResult)
-> Maybe (CheckPermission IntrospectionResult)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup RoleName
roleName HashMap RoleName (CheckPermission IntrospectionResult)
accumulatedRolePermMap) (m (CheckPermission IntrospectionResult)
 -> m (CheckPermission IntrospectionResult))
-> m (CheckPermission IntrospectionResult)
-> m (CheckPermission IntrospectionResult)
forall a b. (a -> b) -> a -> b
$ do
                [CheckPermission IntrospectionResult]
parentRolePermissions <-
                  [RoleName]
-> (RoleName -> m (CheckPermission IntrospectionResult))
-> m [CheckPermission IntrospectionResult]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (HashSet RoleName -> [RoleName]
forall a. HashSet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet RoleName
parentRoles) ((RoleName -> m (CheckPermission IntrospectionResult))
 -> m [CheckPermission IntrospectionResult])
-> (RoleName -> m (CheckPermission IntrospectionResult))
-> m [CheckPermission IntrospectionResult]
forall a b. (a -> b) -> a -> b
$ \RoleName
role ->
                    Maybe (CheckPermission IntrospectionResult)
-> m (CheckPermission IntrospectionResult)
-> m (CheckPermission IntrospectionResult)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (RoleName
-> HashMap RoleName (CheckPermission IntrospectionResult)
-> Maybe (CheckPermission IntrospectionResult)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup RoleName
role HashMap RoleName (CheckPermission IntrospectionResult)
accumulatedRolePermMap)
                      (m (CheckPermission IntrospectionResult)
 -> m (CheckPermission IntrospectionResult))
-> m (CheckPermission IntrospectionResult)
-> m (CheckPermission IntrospectionResult)
forall a b. (a -> b) -> a -> b
$ Text -> m (CheckPermission IntrospectionResult)
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500
                      (Text -> m (CheckPermission IntrospectionResult))
-> Text -> m (CheckPermission IntrospectionResult)
forall a b. (a -> b) -> a -> b
$ Text
"remote schema permissions: bad ordering of roles, could not find the permission of role: "
                      Text -> RoleName -> Text
forall t. ToTxt t => Text -> t -> Text
<>> RoleName
role
                let combinedPermission :: Maybe (CheckPermission IntrospectionResult)
combinedPermission = NonEmpty (CheckPermission IntrospectionResult)
-> CheckPermission IntrospectionResult
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty (CheckPermission IntrospectionResult)
 -> CheckPermission IntrospectionResult)
-> Maybe (NonEmpty (CheckPermission IntrospectionResult))
-> Maybe (CheckPermission IntrospectionResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CheckPermission IntrospectionResult]
-> Maybe (NonEmpty (CheckPermission IntrospectionResult))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [CheckPermission IntrospectionResult]
parentRolePermissions
                CheckPermission IntrospectionResult
-> m (CheckPermission IntrospectionResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckPermission IntrospectionResult
 -> m (CheckPermission IntrospectionResult))
-> CheckPermission IntrospectionResult
-> m (CheckPermission IntrospectionResult)
forall a b. (a -> b) -> a -> b
$ CheckPermission IntrospectionResult
-> Maybe (CheckPermission IntrospectionResult)
-> CheckPermission IntrospectionResult
forall a. a -> Maybe a -> a
fromMaybe CheckPermission IntrospectionResult
forall permissionType. CheckPermission permissionType
CPUndefined Maybe (CheckPermission IntrospectionResult)
combinedPermission
              HashMap RoleName (CheckPermission IntrospectionResult)
-> m (HashMap RoleName (CheckPermission IntrospectionResult))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap RoleName (CheckPermission IntrospectionResult)
 -> m (HashMap RoleName (CheckPermission IntrospectionResult)))
-> HashMap RoleName (CheckPermission IntrospectionResult)
-> m (HashMap RoleName (CheckPermission IntrospectionResult))
forall a b. (a -> b) -> a -> b
$ RoleName
-> CheckPermission IntrospectionResult
-> HashMap RoleName (CheckPermission IntrospectionResult)
-> HashMap RoleName (CheckPermission IntrospectionResult)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert RoleName
roleName CheckPermission IntrospectionResult
rolePermission HashMap RoleName (CheckPermission IntrospectionResult)
accumulatedRolePermMap
          )
          HashMap RoleName (CheckPermission IntrospectionResult)
metadataCheckPermissionsMap
          (OrderedRoles -> [Role]
_unOrderedRoles OrderedRoles
orderedRoles)
  -- traverse through `allRolesUnresolvedPermissionsMap` to record any inconsistencies (if exists)
  [(RoleName, Maybe IntrospectionResult)]
resolvedPermissions <-
    arr
  (Writer (Seq CollectItem) [(RoleName, Maybe IntrospectionResult)])
  [(RoleName, Maybe IntrospectionResult)]
forall w (arr :: * -> * -> *) a.
ArrowWriter w arr =>
arr (Writer w a) a
interpretWriter
      -< [(RoleName, CheckPermission IntrospectionResult)]
-> ((RoleName, CheckPermission IntrospectionResult)
    -> WriterT
         (Seq CollectItem) Identity (RoleName, Maybe IntrospectionResult))
-> Writer (Seq CollectItem) [(RoleName, Maybe IntrospectionResult)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (HashMap RoleName (CheckPermission IntrospectionResult)
-> [(RoleName, CheckPermission IntrospectionResult)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap RoleName (CheckPermission IntrospectionResult)
allRolesUnresolvedPermissionsMap) \(RoleName
roleName, CheckPermission IntrospectionResult
checkPermission) -> do
        let inconsistentRoleEntity :: InconsistentRoleEntity
inconsistentRoleEntity = RemoteSchemaName -> InconsistentRoleEntity
InconsistentRemoteSchemaPermission RemoteSchemaName
remoteSchemaName
        Maybe IntrospectionResult
resolvedCheckPermission <- CheckPermission IntrospectionResult
-> RoleName
-> InconsistentRoleEntity
-> WriterT (Seq CollectItem) Identity (Maybe IntrospectionResult)
forall (m :: * -> *) p.
MonadWriter (Seq CollectItem) m =>
CheckPermission p
-> RoleName -> InconsistentRoleEntity -> m (Maybe p)
resolveCheckPermission CheckPermission IntrospectionResult
checkPermission RoleName
roleName InconsistentRoleEntity
inconsistentRoleEntity
        (RoleName, Maybe IntrospectionResult)
-> WriterT
     (Seq CollectItem) Identity (RoleName, Maybe IntrospectionResult)
forall a. a -> WriterT (Seq CollectItem) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (RoleName
roleName, Maybe IntrospectionResult
resolvedCheckPermission)
  arr
  (HashMap RoleName IntrospectionResult)
  (HashMap RoleName IntrospectionResult)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< HashMap RoleName (Maybe IntrospectionResult)
-> HashMap RoleName IntrospectionResult
forall a. HashMap RoleName (Maybe a) -> HashMap RoleName a
forall (f :: * -> *) a. Filterable f => f (Maybe a) -> f a
catMaybes (HashMap RoleName (Maybe IntrospectionResult)
 -> HashMap RoleName IntrospectionResult)
-> HashMap RoleName (Maybe IntrospectionResult)
-> HashMap RoleName IntrospectionResult
forall a b. (a -> b) -> a -> b
$ [(RoleName, Maybe IntrospectionResult)]
-> HashMap RoleName (Maybe IntrospectionResult)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(RoleName, Maybe IntrospectionResult)]
resolvedPermissions
  where
    buildRemoteSchemaPermission :: arr
  (IntrospectionResult,
   (RemoteSchemaName, RemoteSchemaPermissionMetadata))
  (Maybe IntrospectionResult)
buildRemoteSchemaPermission = proc (IntrospectionResult
originalIntrospection, (RemoteSchemaName
remoteSchemaName, RemoteSchemaPermissionMetadata
remoteSchemaPerm)) -> do
      let RemoteSchemaPermissionMetadata RoleName
roleName RemoteSchemaPermissionDefinition
defn Maybe Text
_ = RemoteSchemaPermissionMetadata
remoteSchemaPerm
          metadataObject :: MetadataObject
metadataObject = (RemoteSchemaName, RemoteSchemaPermissionMetadata)
-> MetadataObject
mkRemoteSchemaPermissionMetadataObject (RemoteSchemaName
remoteSchemaName, RemoteSchemaPermissionMetadata
remoteSchemaPerm)
          schemaObject :: SchemaObjId
schemaObject = RemoteSchemaName -> RoleName -> SchemaObjId
SORemoteSchemaPermission RemoteSchemaName
remoteSchemaName RoleName
roleName
          providedSchemaDoc :: SchemaDocument
providedSchemaDoc = RemoteSchemaPermissionDefinition -> SchemaDocument
_rspdSchema RemoteSchemaPermissionDefinition
defn
          addPermContext :: Text -> Text
addPermContext Text
err = Text
"in remote schema permission for role " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RoleName
roleName RoleName -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
      (|
        ErrorA QErr arr (a, ()) IntrospectionResult
-> arr (a, (MetadataObject, ())) (Maybe IntrospectionResult)
forall {a}.
ErrorA QErr arr (a, ()) IntrospectionResult
-> arr (a, (MetadataObject, ())) (Maybe IntrospectionResult)
forall (arr :: * -> * -> *) e s a.
(ArrowChoice arr, ArrowWriter (Seq CollectItem) arr) =>
ErrorA QErr arr (e, s) a -> arr (e, (MetadataObject, s)) (Maybe a)
withRecordInconsistency
          ( do
              (IntrospectionResult
resolvedSchemaIntrospection, SchemaDependency
dependency) <-
                ErrorA
  QErr
  arr
  (ExceptT QErr m (IntrospectionResult, SchemaDependency))
  (IntrospectionResult, SchemaDependency)
forall (arr :: * -> * -> *) (m :: * -> *) e a.
(ArrowChoice arr, ArrowKleisli m arr, ArrowError e arr) =>
arr (ExceptT e m a) a
bindErrorA
                  -<
                    (Text -> Text)
-> ExceptT QErr m (IntrospectionResult, SchemaDependency)
-> ExceptT QErr m (IntrospectionResult, SchemaDependency)
forall (m :: * -> *) a. QErrM m => (Text -> Text) -> m a -> m a
modifyErr Text -> Text
addPermContext (ExceptT QErr m (IntrospectionResult, SchemaDependency)
 -> ExceptT QErr m (IntrospectionResult, SchemaDependency))
-> ExceptT QErr m (IntrospectionResult, SchemaDependency)
-> ExceptT QErr m (IntrospectionResult, SchemaDependency)
forall a b. (a -> b) -> a -> b
$ RoleName
-> RemoteSchemaName
-> IntrospectionResult
-> SchemaDocument
-> ExceptT QErr m (IntrospectionResult, SchemaDependency)
forall (m :: * -> *).
MonadError QErr m =>
RoleName
-> RemoteSchemaName
-> IntrospectionResult
-> SchemaDocument
-> m (IntrospectionResult, SchemaDependency)
resolveRoleBasedRemoteSchema RoleName
roleName RemoteSchemaName
remoteSchemaName IntrospectionResult
originalIntrospection SchemaDocument
providedSchemaDoc
              ErrorA
  QErr arr (MetadataObject, SchemaObjId, Seq SchemaDependency) ()
forall (arr :: * -> * -> *).
ArrowWriter (Seq CollectItem) arr =>
arr (MetadataObject, SchemaObjId, Seq SchemaDependency) ()
recordDependencies -< (MetadataObject
metadataObject, SchemaObjId
schemaObject, SchemaDependency -> Seq SchemaDependency
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SchemaDependency
dependency)
              ErrorA QErr arr IntrospectionResult IntrospectionResult
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< IntrospectionResult
resolvedSchemaIntrospection
          )
        |)
        MetadataObject
metadataObject

    mkRemoteSchemaPermissionMetadataObject ::
      (RemoteSchemaName, RemoteSchemaPermissionMetadata) ->
      MetadataObject
    mkRemoteSchemaPermissionMetadataObject :: (RemoteSchemaName, RemoteSchemaPermissionMetadata)
-> MetadataObject
mkRemoteSchemaPermissionMetadataObject (RemoteSchemaName
rsName, (RemoteSchemaPermissionMetadata RoleName
roleName RemoteSchemaPermissionDefinition
defn Maybe Text
_)) =
      let objectId :: MetadataObjId
objectId = RemoteSchemaName -> RoleName -> MetadataObjId
MORemoteSchemaPermissions RemoteSchemaName
rsName RoleName
roleName
       in MetadataObjId -> Value -> MetadataObject
MetadataObject MetadataObjId
objectId (Value -> MetadataObject) -> Value -> MetadataObject
forall a b. (a -> b) -> a -> b
$ RemoteSchemaPermissionDefinition -> Value
forall a. ToJSON a => a -> Value
toJSON RemoteSchemaPermissionDefinition
defn

addRemoteSchemaP2Setup ::
  (QErrM m, MonadIO m, ProvidesNetwork m, Tracing.MonadTrace m) =>
  Env.Environment ->
  RemoteSchemaDef ->
  m (IntrospectionResult, BL.ByteString, RemoteSchemaInfo)
addRemoteSchemaP2Setup :: forall (m :: * -> *).
(QErrM m, MonadIO m, ProvidesNetwork m, MonadTrace m) =>
Environment
-> RemoteSchemaDef
-> m (IntrospectionResult, ByteString, RemoteSchemaInfo)
addRemoteSchemaP2Setup Environment
env RemoteSchemaDef
def = do
  ValidatedRemoteSchemaDef
rsi <- Environment -> RemoteSchemaDef -> m ValidatedRemoteSchemaDef
forall (m :: * -> *).
MonadError QErr m =>
Environment -> RemoteSchemaDef -> m ValidatedRemoteSchemaDef
validateRemoteSchemaDef Environment
env RemoteSchemaDef
def
  Environment
-> ValidatedRemoteSchemaDef
-> m (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadTrace m, ProvidesNetwork m) =>
Environment
-> ValidatedRemoteSchemaDef
-> m (IntrospectionResult, ByteString, RemoteSchemaInfo)
fetchRemoteSchema Environment
env ValidatedRemoteSchemaDef
rsi