graphql-engine/server/src-lib/Hasura/GraphQL/RemoteServer.hs
Antoine Leblanc 5920134dcb Decouple Analyse and OpenAPI from remote schema introspection and internal execution details.
### Motivation

#2338 introduced a way to validate REST queries against the metadata after a change, to properly report any inconsistency that would emerge from a change in the underlying structure of our schema. However, the way this was done was quite complex and error-prone. Namely: we would use the generated schema parsers to statically execute an introspection query, similar to the one we use for remote schemas, then parse the resulting bytestring as it were coming from a remote schema.

This led to several issues: the code was using remote schema primitives, and was associated with remote schema code, despite being unrelated, which led to absurd situations like creating fake `Variable`s whose type was also their name. A lot of the code had to deal with the fact that we might fail to re-parse our own schema. Additionally, some of it was dead code, that for some reason GHC did not warn about? But more fundamentally, this architecture decision creates a dependency between unrelated pieces of the engine: modifying the internal processing of root fields or the introspection of remote schemas now risks impacting the unrelated `OpenAPI` feature.

### Description

This PR decouples that process from the remote schema introspection logic and from the execution engine by making `Analyse` and `OpenAPI` work on the generic `G.SchemaIntrospection` instead. To accomplish this, it:
- adds `GraphQL.Parser.Schema.Convert`, to convert from our "live" schema back to a flat `SchemaIntrospection`
- persists in the schema cache the `admin` introspection generated when building the schema, and uses it both for validation and for generating the `OpenAPI`.

### Known issues and limitations

This adds a bit of memory pressure to the engine, as we persist the entire schema in the schema cache. This might be acceptable in the short-term, but we have several potential ideas going forward should this be a problem:
- cache the result of `Analyze`: when it becomes possible to build the `OpenAPI` purely with the result of `Analyze` without any additional schema information, then we could cache that instead, reducing the footprint
- caching the `OpenAPI`: if it doesn't need to change every time the endpoint is queried, then it should be possible to cache the entire `OpenAPI` object instead of the schema
- cache a copy of the `FieldParsers` used to generate the schema: as those are persisted through the GraphQL `Context`, and are the only input required to generate the `Schema`, making them accessible in the schema cache would allow us to have the exact same feature with no additional memory cost, at the price of a slightly slower and more complicated process (need to rebuild the `Schema` every time we query the OpenAPI endpoint)
- cache nothing at all, and rebuild the admin schema from scratch every time.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3962
Co-authored-by: paritosh-08 <85472423+paritosh-08@users.noreply.github.com>
GitOrigin-RevId: a8b9808170b231fdf6787983b4a9ed286cde27e0
2022-03-22 07:37:49 +00:00

562 lines
23 KiB
Haskell

{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.RemoteServer
( fetchRemoteSchema,
execRemoteGQ,
)
where
import Control.Arrow.Extended (left)
import Control.Exception (try)
import Control.Lens (set, (^.))
import Data.Aeson ((.:), (.:?))
import Data.Aeson 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.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.Execute.Types
import Hasura.GraphQL.Parser.Monad (ParseT, runSchemaT)
import Hasura.GraphQL.Schema.Common (QueryContext (..))
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.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
-------------------------------------------------------------------------------
-- Core API
-- | 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)
-- At this point, we can't resolve remote relationships; we store an empty map.
let _rscRemoteRelationships = mempty
_rscInfo = RemoteSchemaInfo {..}
-- Check that the parsed GraphQL type info is valid by running the schema
-- generation. The result is discarded, as the local schema will be built
-- properly for each role at schema generation time, but this allows us to
-- quickly reject an invalid schema.
void $
runSchemaT $
flip runReaderT minimumValidContext $
buildRemoteParser @_ @_ @(ParseT Identity) _rscIntroOriginal _rscRemoteRelationships _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)
-- Minimum valid information required to run schema generation for
-- the remote schema.
minimumValidContext =
( adminRoleName :: RoleName,
mempty :: SourceCache,
mempty :: CustomizeRemoteFieldName,
mempty :: RemoteSchemaMap,
mempty :: MkTypename,
mempty :: MkRootFieldName,
QueryContext
{ -- doesn't apply to remote schemas
qcStringifyNum = LeaveNumbersAlone,
-- doesn't apply to remote schemas
qcDangerousBooleanCollapse = True,
-- we don't support remote schemas in Relay, but the check is
-- performed ahead of time, meaning that the value here is
-- irrelevant
qcQueryType = QueryHasura,
-- doesn't apply to remote schemas
qcFunctionPermsContext = FunctionPermissionsInferred,
-- we default to no permissions
qcRemoteSchemaPermsCtx = RemoteSchemaPermsDisabled,
-- doesn't apply to remote schemas
qcOptimizePermissionFilters = False
}
)
-- | Sends a GraphQL query to the given server.
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
-------------------------------------------------------------------------------
-- Validation
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 ()
-------------------------------------------------------------------------------
-- Introspection
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, ..}
)
-- | 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)
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
-------------------------------------------------------------------------------
-- Customization
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
------------------------------------------------------------------------------
-- Local error handling
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
throwRemoteSchema :: QErrM m => Text -> m a
throwRemoteSchema = throw400 RemoteSchemaError
throwRemoteSchemaHttp ::
QErrM m =>
URI ->
HTTP.HttpException ->
m a
throwRemoteSchemaHttp url exception =
throwError $
baseError
{ qeInternal = Just $ ExtraInternal $ httpExceptToJSON exception
}
where
baseError = err400 RemoteSchemaError httpExceptMsg
httpExceptMsg = "HTTP exception occurred while sending the request to " <> tshow url