graphql-engine/server/src-lib/Hasura/GraphQL/RemoteServer.hs

module Hasura.GraphQL.RemoteServer
  ( fetchRemoteSchema,
    IntrospectionResult,
    parseIntrospectionResult,
    execRemoteGQ,
    identityCustomizer,
    introspectionQuery,
    -- The following exports are needed for unit tests
    getCustomizer,
    validateSchemaCustomizationsDistinct,
    getSchemaIntrospection,
  )
where

import Control.Arrow.Extended (left)
import Control.Exception (try)
import Control.Exception.Safe (Exception (displayException), Typeable, impureThrow)
import Control.Lens (set, (^.))
import Data.Aeson ((.:), (.:?))
import Data.Aeson qualified as J
import Data.Aeson.Ordered qualified as JO
import Data.Aeson.Types qualified as J
import Data.ByteString.Lazy qualified as BL
import Data.Environment qualified as Env
import Data.FileEmbed (makeRelativeToProject)
import Data.HashMap.Strict.Extended qualified as Map
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.HashSet qualified as Set
import Data.List.Extended (duplicates)
import Data.Text qualified as T
import Data.Text.Extended (dquoteList, (<<>))
import Hasura.Base.Error
import Hasura.GraphQL.Context
import Hasura.GraphQL.Namespace (mkUnNamespacedRootFieldAlias)
import Hasura.GraphQL.Parser.Collect ()
import Hasura.GraphQL.Parser.Schema (Variable)
-- Needed for GHCi and HLS due to TH in cyclically dependent modules (see https://gitlab.haskell.org/ghc/ghc/-/issues/1012)
import Hasura.GraphQL.Schema.Remote (buildRemoteParser)
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.HTTP
import Hasura.Prelude
import Hasura.RQL.DDL.Headers (makeHeadersFromConf)
import Hasura.RQL.IR (RootField (RFRaw))
import Hasura.RQL.Types
import Hasura.Server.Utils
import Hasura.Session
import Hasura.Tracing qualified as Tracing
import Language.GraphQL.Draft.Parser qualified as G
import Language.GraphQL.Draft.Syntax qualified as G
import Language.Haskell.TH.Syntax qualified as TH
import Network.HTTP.Client.Transformable qualified as HTTP
import Network.URI (URI)
import Network.Wreq qualified as Wreq

introspectionQuery :: GQLReqOutgoing
introspectionQuery =
  $( do
       fp <- makeRelativeToProject "src-rsr/introspection.json"
       TH.qAddDependentFile fp
       eitherResult <- TH.runIO $ J.eitherDecodeFileStrict fp
       either fail TH.lift $ do
         r@GQLReq {..} <- eitherResult
         op <- left show $ getSingleOperation r
         pure GQLReq {_grQuery = op, ..}
   )

validateSchemaCustomizations ::
  forall m.
  MonadError QErr m =>
  RemoteSchemaCustomizer ->
  RemoteSchemaIntrospection ->
  m ()
validateSchemaCustomizations remoteSchemaCustomizer remoteSchemaIntrospection = do
  validateSchemaCustomizationsConsistent remoteSchemaCustomizer remoteSchemaIntrospection
  validateSchemaCustomizationsDistinct remoteSchemaCustomizer remoteSchemaIntrospection

validateSchemaCustomizationsConsistent ::
  forall m.
  MonadError QErr m =>
  RemoteSchemaCustomizer ->
  RemoteSchemaIntrospection ->
  m ()
validateSchemaCustomizationsConsistent remoteSchemaCustomizer (RemoteSchemaIntrospection typeDefinitions) = do
  traverse_ validateInterfaceFields typeDefinitions
  where
    customizeFieldName = remoteSchemaCustomizeFieldName remoteSchemaCustomizer

    validateInterfaceFields :: G.TypeDefinition [G.Name] a -> m ()
    validateInterfaceFields = \case
      G.TypeDefinitionInterface G.InterfaceTypeDefinition {..} ->
        for_ _itdPossibleTypes $ \typeName ->
          for_ _itdFieldsDefinition $ \G.FieldDefinition {..} -> do
            let interfaceCustomizedFieldName = runCustomizeRemoteFieldName customizeFieldName _itdName _fldName
                typeCustomizedFieldName = runCustomizeRemoteFieldName customizeFieldName typeName _fldName
            when (interfaceCustomizedFieldName /= typeCustomizedFieldName) $
              throwRemoteSchema $
                "Remote schema customization inconsistency: field name mapping for field "
                  <> _fldName
                  <<> " of interface "
                  <> _itdName
                  <<> " is inconsistent with mapping for type "
                  <> typeName
                  <<> ". Interface field name maps to "
                  <> interfaceCustomizedFieldName
                  <<> ". Type field name maps to "
                  <> typeCustomizedFieldName
                  <<> "."
      _ -> pure ()

validateSchemaCustomizationsDistinct ::
  forall m.
  MonadError QErr m =>
  RemoteSchemaCustomizer ->
  RemoteSchemaIntrospection ->
  m ()
validateSchemaCustomizationsDistinct remoteSchemaCustomizer (RemoteSchemaIntrospection typeDefinitions) = do
  validateTypeMappingsAreDistinct
  traverse_ validateFieldMappingsAreDistinct typeDefinitions
  where
    customizeTypeName = remoteSchemaCustomizeTypeName remoteSchemaCustomizer
    customizeFieldName = runCustomizeRemoteFieldName (remoteSchemaCustomizeFieldName remoteSchemaCustomizer)

    validateTypeMappingsAreDistinct :: m ()
    validateTypeMappingsAreDistinct = do
      let dups = duplicates $ runMkTypename customizeTypeName <$> Map.keys typeDefinitions
      unless (Set.null dups) $
        throwRemoteSchema $
          "Type name mappings are not distinct; the following types appear more than once: "
            <> dquoteList dups

    validateFieldMappingsAreDistinct :: G.TypeDefinition a b -> m ()
    validateFieldMappingsAreDistinct = \case
      G.TypeDefinitionInterface G.InterfaceTypeDefinition {..} -> do
        let dups = duplicates $ (customizeFieldName _itdName . G._fldName) <$> _itdFieldsDefinition
        unless (Set.null dups) $
          throwRemoteSchema $
            "Field name mappings for interface type " <> _itdName
              <<> " are not distinct; the following fields appear more than once: "
              <> dquoteList dups
      G.TypeDefinitionObject G.ObjectTypeDefinition {..} -> do
        let dups = duplicates $ (customizeFieldName _otdName . G._fldName) <$> _otdFieldsDefinition
        unless (Set.null dups) $
          throwRemoteSchema $
            "Field name mappings for object type " <> _otdName
              <<> " are not distinct; the following fields appear more than once: "
              <> dquoteList dups
      _ -> pure ()

parseIntrospectionResult :: J.Value -> Maybe IntrospectionResult
parseIntrospectionResult = fmap fromIntrospection . J.parseMaybe J.parseJSON

-- | Make an introspection query to the remote graphql server for the data we
-- need to present and stitch the remote schema. This powers add_remote_schema,
-- and also is called by schema cache rebuilding code in "Hasura.RQL.DDL.Schema.Cache".
fetchRemoteSchema ::
  forall m.
  (MonadIO m, MonadError QErr m, Tracing.MonadTrace m) =>
  Env.Environment ->
  HTTP.Manager ->
  RemoteSchemaName ->
  ValidatedRemoteSchemaDef ->
  m RemoteSchemaCtx
fetchRemoteSchema env manager _rscName rsDef@ValidatedRemoteSchemaDef {..} = do
  (_, _, _rscRawIntrospectionResult) <-
    execRemoteGQ env manager adminUserInfo [] rsDef introspectionQuery

  -- Parse the JSON into flat GraphQL type AST
  FromIntrospection _rscIntroOriginal <-
    J.eitherDecode _rscRawIntrospectionResult `onLeft` (throwRemoteSchema . T.pack)

  -- possibly transform type names from the remote schema, per the user's 'RemoteSchemaDef'
  let rsCustomizer = getCustomizer (addDefaultRoots _rscIntroOriginal) _vrsdCustomization

  validateSchemaCustomizations rsCustomizer (irDoc _rscIntroOriginal)

  let _rscInfo = RemoteSchemaInfo {..}

  -- At this point, we can't resolve remote relationships; we store an empty map.
  let _rscRemoteRelationships = mempty

  -- Check that the parsed GraphQL type info is valid by running the schema generation
  _rscParsed <- buildRemoteParser _rscIntroOriginal _rscInfo

  -- The 'rawIntrospectionResult' contains the 'Bytestring' response of
  -- the introspection result of the remote server. We store this in the
  -- 'RemoteSchemaCtx' because we can use this when the 'introspect_remote_schema'
  -- is called by simple encoding the result to JSON.
  return
    RemoteSchemaCtx
      { _rscPermissions = mempty,
        ..
      }
  where
    -- If there is no explicit mutation or subscription root type we need to check for
    -- objects type definitions with the default names "Mutation" and "Subscription".
    -- If found, we add the default roots explicitly to the IntrospectionResult.
    -- This simplifies the customization code.
    addDefaultRoots :: IntrospectionResult -> IntrospectionResult
    addDefaultRoots IntrospectionResult {..} =
      IntrospectionResult
        { irMutationRoot = getRootTypeName $$(G.litName "Mutation") irMutationRoot,
          irSubscriptionRoot = getRootTypeName $$(G.litName "Subscription") irSubscriptionRoot,
          ..
        }
      where
        getRootTypeName defaultName providedName =
          providedName <|> (defaultName <$ lookupObject irDoc defaultName)

-- | Parsing the introspection query result.  We use this newtype wrapper to
-- avoid orphan instances and parse JSON in the way that we need for GraphQL
-- introspection results.
newtype FromIntrospection a = FromIntrospection {fromIntrospection :: a}
  deriving (Show, Eq, Generic, Functor)

pErr :: (MonadFail m) => Text -> m a
pErr = fail . T.unpack

kindErr :: (MonadFail m) => Text -> Text -> m a
kindErr gKind eKind = pErr $ "Invalid `kind: " <> gKind <> "` in " <> eKind

instance J.FromJSON (FromIntrospection G.Description) where
  parseJSON = fmap (FromIntrospection . G.Description) . J.parseJSON

instance J.FromJSON (FromIntrospection G.ScalarTypeDefinition) where
  parseJSON = J.withObject "ScalarTypeDefinition" $ \o -> do
    kind <- o .: "kind"
    name <- o .: "name"
    desc <- o .:? "description"
    when (kind /= "SCALAR") $ kindErr kind "scalar"
    let desc' = fmap fromIntrospection desc
        r = G.ScalarTypeDefinition desc' name []
    return $ FromIntrospection r

instance J.FromJSON (FromIntrospection (G.ObjectTypeDefinition G.InputValueDefinition)) where
  parseJSON = J.withObject "ObjectTypeDefinition" $ \o -> do
    kind <- o .: "kind"
    name <- o .: "name"
    desc <- o .:? "description"
    fields <- o .:? "fields"
    interfaces :: Maybe [FromIntrospection (G.InterfaceTypeDefinition [G.Name] G.InputValueDefinition)] <- o .:? "interfaces"
    when (kind /= "OBJECT") $ kindErr kind "object"
    let implIfaces = map G._itdName $ maybe [] (fmap fromIntrospection) interfaces
        flds = maybe [] (fmap fromIntrospection) fields
        desc' = fmap fromIntrospection desc
        r = G.ObjectTypeDefinition desc' name implIfaces [] flds
    return $ FromIntrospection r

instance (J.FromJSON (FromIntrospection a)) => J.FromJSON (FromIntrospection (G.FieldDefinition a)) where
  parseJSON = J.withObject "FieldDefinition" $ \o -> do
    name <- o .: "name"
    desc <- o .:? "description"
    args <- o .: "args"
    _type <- o .: "type"
    let desc' = fmap fromIntrospection desc
        r =
          G.FieldDefinition
            desc'
            name
            (fmap fromIntrospection args)
            (fromIntrospection _type)
            []
    return $ FromIntrospection r

instance J.FromJSON (FromIntrospection G.GType) where
  parseJSON = J.withObject "GType" $ \o -> do
    kind <- o .: "kind"
    mName <- o .:? "name"
    mType <- o .:? "ofType"
    r <- case (kind, mName, mType) of
      ("NON_NULL", _, Just typ) -> return $ mkNotNull (fromIntrospection typ)
      ("NON_NULL", _, Nothing) -> pErr "NON_NULL should have `ofType`"
      ("LIST", _, Just typ) ->
        return $ G.TypeList (G.Nullability True) (fromIntrospection typ)
      ("LIST", _, Nothing) -> pErr "LIST should have `ofType`"
      (_, Just name, _) -> return $ G.TypeNamed (G.Nullability True) name
      _ -> pErr $ "kind: " <> kind <> " should have name"
    return $ FromIntrospection r
    where
      mkNotNull typ = case typ of
        G.TypeList _ ty -> G.TypeList (G.Nullability False) ty
        G.TypeNamed _ n -> G.TypeNamed (G.Nullability False) n

instance J.FromJSON (FromIntrospection G.InputValueDefinition) where
  parseJSON = J.withObject "InputValueDefinition" $ \o -> do
    name <- o .: "name"
    desc <- o .:? "description"
    _type <- o .: "type"
    defVal <- o .:? "defaultValue"
    let desc' = fmap fromIntrospection desc
    let defVal' = fmap fromIntrospection defVal
        r = G.InputValueDefinition desc' name (fromIntrospection _type) defVal' []
    return $ FromIntrospection r

instance J.FromJSON (FromIntrospection (G.Value Void)) where
  parseJSON = J.withText "Value Void" $ \t ->
    let parseValueConst = G.runParser G.value
     in FromIntrospection <$> onLeft (parseValueConst t) (fail . T.unpack)

instance J.FromJSON (FromIntrospection (G.InterfaceTypeDefinition [G.Name] G.InputValueDefinition)) where
  parseJSON = J.withObject "InterfaceTypeDefinition" $ \o -> do
    kind <- o .: "kind"
    name <- o .: "name"
    desc <- o .:? "description"
    fields <- o .:? "fields"
    possibleTypes :: Maybe [FromIntrospection (G.ObjectTypeDefinition G.InputValueDefinition)] <- o .:? "possibleTypes"
    let flds = maybe [] (fmap fromIntrospection) fields
        desc' = fmap fromIntrospection desc
        possTps = map G._otdName $ maybe [] (fmap fromIntrospection) possibleTypes
    when (kind /= "INTERFACE") $ kindErr kind "interface"
    -- TODO (non PDV) track which interfaces implement which other interfaces, after a
    -- GraphQL spec > Jun 2018 is released.
    let r = G.InterfaceTypeDefinition desc' name [] flds possTps
    return $ FromIntrospection r

instance J.FromJSON (FromIntrospection G.UnionTypeDefinition) where
  parseJSON = J.withObject "UnionTypeDefinition" $ \o -> do
    kind <- o .: "kind"
    name <- o .: "name"
    desc <- o .:? "description"
    possibleTypes :: [FromIntrospection (G.ObjectTypeDefinition G.InputValueDefinition)] <- o .: "possibleTypes"
    let possibleTypes' = map G._otdName $ fmap fromIntrospection possibleTypes
        desc' = fmap fromIntrospection desc
    when (kind /= "UNION") $ kindErr kind "union"
    let r = G.UnionTypeDefinition desc' name [] possibleTypes'
    return $ FromIntrospection r

instance J.FromJSON (FromIntrospection G.EnumTypeDefinition) where
  parseJSON = J.withObject "EnumTypeDefinition" $ \o -> do
    kind <- o .: "kind"
    name <- o .: "name"
    desc <- o .:? "description"
    vals <- o .: "enumValues"
    when (kind /= "ENUM") $ kindErr kind "enum"
    let desc' = fmap fromIntrospection desc
    let r = G.EnumTypeDefinition desc' name [] (fmap fromIntrospection vals)
    return $ FromIntrospection r

instance J.FromJSON (FromIntrospection G.EnumValueDefinition) where
  parseJSON = J.withObject "EnumValueDefinition" $ \o -> do
    name <- o .: "name"
    desc <- o .:? "description"
    let desc' = fmap fromIntrospection desc
    let r = G.EnumValueDefinition desc' name []
    return $ FromIntrospection r

instance J.FromJSON (FromIntrospection (G.InputObjectTypeDefinition G.InputValueDefinition)) where
  parseJSON = J.withObject "InputObjectTypeDefinition" $ \o -> do
    kind <- o .: "kind"
    name <- o .: "name"
    desc <- o .:? "description"
    mInputFields <- o .:? "inputFields"
    let inputFields = maybe [] (fmap fromIntrospection) mInputFields
    let desc' = fmap fromIntrospection desc
    when (kind /= "INPUT_OBJECT") $ kindErr kind "input_object"
    let r = G.InputObjectTypeDefinition desc' name [] inputFields
    return $ FromIntrospection r

instance J.FromJSON (FromIntrospection (G.TypeDefinition [G.Name] G.InputValueDefinition)) where
  parseJSON = J.withObject "TypeDefinition" $ \o -> do
    kind :: Text <- o .: "kind"
    r <- case kind of
      "SCALAR" ->
        G.TypeDefinitionScalar . fromIntrospection <$> J.parseJSON (J.Object o)
      "OBJECT" ->
        G.TypeDefinitionObject . fromIntrospection <$> J.parseJSON (J.Object o)
      "INTERFACE" ->
        G.TypeDefinitionInterface . fromIntrospection <$> J.parseJSON (J.Object o)
      "UNION" ->
        G.TypeDefinitionUnion . fromIntrospection <$> J.parseJSON (J.Object o)
      "ENUM" ->
        G.TypeDefinitionEnum . fromIntrospection <$> J.parseJSON (J.Object o)
      "INPUT_OBJECT" ->
        G.TypeDefinitionInputObject . fromIntrospection <$> J.parseJSON (J.Object o)
      _ -> pErr $ "unknown kind: " <> kind
    return $ FromIntrospection r

instance J.FromJSON (FromIntrospection IntrospectionResult) where
  parseJSON = J.withObject "SchemaDocument" $ \o -> do
    _data <- o .: "data"
    schema <- _data .: "__schema"
    -- the list of types
    types <- schema .: "types"
    -- query root
    queryType <- schema .: "queryType"
    queryRoot <- queryType .: "name"
    -- mutation root
    mMutationType <- schema .:? "mutationType"
    mutationRoot <- case mMutationType of
      Nothing -> return Nothing
      Just mutType -> do
        mutRoot <- mutType .: "name"
        return $ Just mutRoot
    -- subscription root
    mSubsType <- schema .:? "subscriptionType"
    subsRoot <- case mSubsType of
      Nothing -> return Nothing
      Just subsType -> do
        subRoot <- subsType .: "name"
        return $ Just subRoot
    let types' =
          (fmap . fmap . fmap)
            -- presets are only defined for non-admin roles,
            -- an admin will not have any presets
            -- defined and the admin will be the one,
            -- who'll be adding the remote schema,
            -- hence presets are set to `Nothing`
            (`RemoteSchemaInputValueDefinition` Nothing)
            types
        r =
          IntrospectionResult
            (RemoteSchemaIntrospection $ Map.fromListOn getTypeName $ fromIntrospection <$> types')
            queryRoot
            mutationRoot
            subsRoot
    return $ FromIntrospection r

objectWithoutNullValues :: [J.Pair] -> J.Value
objectWithoutNullValues = J.object . filter notNull
  where
    notNull (_, J.Null) = False
    notNull _ = True

toObjectTypeDefinition :: G.Name -> G.ObjectTypeDefinition G.InputValueDefinition
toObjectTypeDefinition name = G.ObjectTypeDefinition Nothing name [] [] []

execRemoteGQ ::
  ( MonadIO m,
    MonadError QErr m,
    Tracing.MonadTrace m
  ) =>
  Env.Environment ->
  HTTP.Manager ->
  UserInfo ->
  [HTTP.Header] ->
  ValidatedRemoteSchemaDef ->
  GQLReqOutgoing ->
  -- | Returns the response body and headers, along with the time taken for the
  -- HTTP request to complete
  m (DiffTime, [HTTP.Header], BL.ByteString)
execRemoteGQ env manager userInfo reqHdrs rsdef gqlReq@GQLReq {..} = do
  let gqlReqUnparsed = renderGQLReqOutgoing gqlReq

  when (G._todType _grQuery == G.OperationTypeSubscription) $
    throwRemoteSchema "subscription to remote server is not supported"
  confHdrs <- makeHeadersFromConf env hdrConf
  let clientHdrs = bool [] (mkClientHeadersForward reqHdrs) fwdClientHdrs
      -- filter out duplicate headers
      -- priority: conf headers > resolved userinfo vars > client headers
      hdrMaps =
        [ Map.fromList confHdrs,
          Map.fromList userInfoToHdrs,
          Map.fromList clientHdrs
        ]
      headers = Map.toList $ foldr Map.union Map.empty hdrMaps
      finalHeaders = addDefaultHeaders headers
  initReq <- onLeft (HTTP.mkRequestEither $ tshow url) (throwRemoteSchemaHttp url)
  let req =
        initReq & set HTTP.method "POST"
          & set HTTP.headers finalHeaders
          & set HTTP.body (Just $ J.encode gqlReqUnparsed)
          & set HTTP.timeout (HTTP.responseTimeoutMicro (timeout * 1000000))

  Tracing.tracedHttpRequest req \req' -> do
    (time, res) <- withElapsedTime $ liftIO $ try $ HTTP.performRequest req' manager
    resp <- onLeft res (throwRemoteSchemaHttp url)
    pure (time, mkSetCookieHeaders resp, resp ^. Wreq.responseBody)
  where
    ValidatedRemoteSchemaDef url hdrConf fwdClientHdrs timeout _mPrefix = rsdef

    userInfoToHdrs = sessionVariablesToHeaders $ _uiSession userInfo

identityCustomizer :: RemoteSchemaCustomizer
identityCustomizer = RemoteSchemaCustomizer Nothing mempty mempty

getCustomizer :: IntrospectionResult -> Maybe RemoteSchemaCustomization -> RemoteSchemaCustomizer
getCustomizer _ Nothing = identityCustomizer
getCustomizer IntrospectionResult {..} (Just RemoteSchemaCustomization {..}) = RemoteSchemaCustomizer {..}
  where
    rootTypeNames =
      if isNothing _rscRootFieldsNamespace
        then catMaybes [Just irQueryRoot, irMutationRoot, irSubscriptionRoot]
        else []
    -- root type names should not be prefixed or suffixed unless
    -- there is a custom root namespace field
    scalarTypeNames = [intScalar, floatScalar, stringScalar, boolScalar, idScalar]
    protectedTypeNames = scalarTypeNames ++ rootTypeNames
    nameFilter name = not $ "__" `T.isPrefixOf` G.unName name || name `elem` protectedTypeNames

    mkPrefixSuffixMap :: Maybe G.Name -> Maybe G.Name -> [G.Name] -> HashMap G.Name G.Name
    mkPrefixSuffixMap mPrefix mSuffix names = Map.fromList $ case (mPrefix, mSuffix) of
      (Nothing, Nothing) -> []
      (Just prefix, Nothing) -> map (\name -> (name, prefix <> name)) names
      (Nothing, Just suffix) -> map (\name -> (name, name <> suffix)) names
      (Just prefix, Just suffix) -> map (\name -> (name, prefix <> name <> suffix)) names

    RemoteSchemaIntrospection typeDefinitions = irDoc
    typesToRename = filter nameFilter $ Map.keys typeDefinitions
    typeRenameMap =
      case _rscTypeNames of
        Nothing -> Map.empty
        Just RemoteTypeCustomization {..} ->
          _rtcMapping <> mkPrefixSuffixMap _rtcPrefix _rtcSuffix typesToRename

    typeFieldMap :: HashMap G.Name [G.Name] -- typeName -> fieldNames
    typeFieldMap =
      Map.mapMaybe getFieldsNames typeDefinitions
      where
        getFieldsNames = \case
          G.TypeDefinitionObject G.ObjectTypeDefinition {..} -> Just $ G._fldName <$> _otdFieldsDefinition
          G.TypeDefinitionInterface G.InterfaceTypeDefinition {..} -> Just $ G._fldName <$> _itdFieldsDefinition
          _ -> Nothing

    mkFieldRenameMap RemoteFieldCustomization {..} fieldNames =
      _rfcMapping <> mkPrefixSuffixMap _rfcPrefix _rfcSuffix fieldNames

    fieldRenameMap =
      case _rscFieldNames of
        Nothing -> Map.empty
        Just fieldNameCustomizations ->
          let customizationMap = Map.fromList $ map (\rfc -> (_rfcParentType rfc, rfc)) fieldNameCustomizations
           in Map.intersectionWith mkFieldRenameMap customizationMap typeFieldMap

    _rscNamespaceFieldName = _rscRootFieldsNamespace
    _rscCustomizeTypeName = typeRenameMap
    _rscCustomizeFieldName = fieldRenameMap

throwRemoteSchema ::
  QErrM m =>
  Text ->
  m a
throwRemoteSchema = throw400 RemoteSchemaError

throwRemoteSchemaWithInternal ::
  (QErrM m, J.ToJSON a) =>
  Text ->
  a ->
  m b
throwRemoteSchemaWithInternal msg v =
  let err = err400 RemoteSchemaError msg
   in throwError err {qeInternal = Just $ ExtraInternal $ J.toJSON v}

throwRemoteSchemaHttp ::
  QErrM m =>
  URI ->
  HTTP.HttpException ->
  m a
throwRemoteSchemaHttp url =
  throwRemoteSchemaWithInternal (T.pack httpExceptMsg) . httpExceptToJSON
  where
    httpExceptMsg =
      "HTTP exception occurred while sending the request to " <> show url

-- Utility function for generating RemoteScemaIntrospection

newtype RemoteSchemaIntrospectionErr = RemoteSchemaIntrospectionErr
  { remoteSchemaIntrospectionErr :: String
  }
  deriving (Show, Typeable)

instance Exception RemoteSchemaIntrospectionErr where
  displayException (RemoteSchemaIntrospectionErr msg) = "RemoteSchemaIntrospectionErr: " <> show msg

errorE :: String -> c
errorE = impureThrow . RemoteSchemaIntrospectionErr

getSchemaIntrospection :: HashMap RoleName (RoleContext GQLContext) -> Maybe RemoteSchemaIntrospection
getSchemaIntrospection gqlContext = do
  RoleContext {..} <- Map.lookup adminRoleName gqlContext
  fieldMap <- either (const Nothing) Just $ gqlQueryParser _rctxDefault $ fmap (fmap nameToVariable) $ G._todSelectionSet $ _grQuery introspectionQuery
  RFRaw v <- OMap.lookup (mkUnNamespacedRootFieldAlias $$(G.litName "__schema")) fieldMap
  fmap irDoc $ parseIntrospectionResult $ J.object [("data", J.object [("__schema", JO.fromOrdered v)])]
  where
    -- TODO: Look for a way to convert Name to Variable (using some default types) or make the
    --       ParserFn general (i.e. type ParserFn a b =  G.SelectionSet G.NoFragments b -> ...)
    -- This value isn't used but we give it a type to be more clear about what is being ignored
    nameToVariable :: G.Name -> Variable
    nameToVariable n = errorE . T.unpack $ G.unName n <> " cannot be converted to Variable"