mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 20:41:49 +03:00
768 lines
36 KiB
Haskell
768 lines
36 KiB
Haskell
module Hasura.GraphQL.RemoteServer
|
|
( fetchRemoteSchema
|
|
, IntrospectionResult
|
|
, execRemoteGQ
|
|
, identityCustomizer
|
|
-- The following exports are needed for unit tests
|
|
, introspectionResultToJSON
|
|
, parseIntrospectionResult
|
|
, getCustomizers
|
|
, customizeIntrospectionResult
|
|
) where
|
|
|
|
import Hasura.Prelude
|
|
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.Aeson.Types as J
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.Environment as Env
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Data.HashSet as Set
|
|
import qualified Data.Text as T
|
|
import qualified Hasura.Tracing as Tracing
|
|
import qualified Language.GraphQL.Draft.Parser as G
|
|
import qualified Language.GraphQL.Draft.Syntax as G
|
|
import qualified Language.Haskell.TH.Syntax as TH
|
|
import qualified Network.HTTP.Client as HTTP
|
|
import qualified Network.HTTP.Types as N
|
|
import qualified Network.Wreq as Wreq
|
|
|
|
import Control.Arrow.Extended (left)
|
|
import Control.Exception (try)
|
|
import Control.Lens ((^.))
|
|
import Control.Monad.Unique
|
|
import Data.Aeson ((.:), (.:?), (.=))
|
|
import Data.FileEmbed (makeRelativeToProject)
|
|
import Data.List.Extended (duplicates)
|
|
import Data.Text.Extended (dquoteList, toTxt, (<<>))
|
|
import Data.Tuple (swap)
|
|
|
|
import qualified Hasura.GraphQL.Parser.Monad as P
|
|
|
|
import Hasura.Base.Error
|
|
import Hasura.GraphQL.Parser.Collect ()
|
|
-- 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, customizeType)
|
|
import Hasura.GraphQL.Transport.HTTP.Protocol
|
|
import Hasura.HTTP
|
|
import Hasura.RQL.DDL.Headers (makeHeadersFromConf)
|
|
import Hasura.RQL.Types
|
|
import Hasura.Server.Utils
|
|
import Hasura.Server.Version (HasVersion)
|
|
import Hasura.Session
|
|
|
|
|
|
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 typeDefinitions) = do
|
|
traverse_ validateInterfaceFields typeDefinitions
|
|
validateTypeMappingsAreDistinct
|
|
traverse_ validateFieldMappingsAreDistinct typeDefinitions
|
|
|
|
where
|
|
validateInterfaceFields :: G.TypeDefinition [G.Name] a -> m ()
|
|
validateInterfaceFields = \case
|
|
G.TypeDefinitionInterface G.InterfaceTypeDefinition{..} ->
|
|
for_ _itdPossibleTypes $ \typeName ->
|
|
for_ _itdFieldsDefinition $ \G.FieldDefinition{..} -> do
|
|
let interfaceCustomizedFieldName = _rscCustomizeFieldName _itdName _fldName
|
|
typeCustomizedFieldName = _rscCustomizeFieldName typeName _fldName
|
|
when (interfaceCustomizedFieldName /= typeCustomizedFieldName) $
|
|
throw400 RemoteSchemaError
|
|
$ "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 ()
|
|
|
|
validateTypeMappingsAreDistinct :: m ()
|
|
validateTypeMappingsAreDistinct = do
|
|
let dups = duplicates $ (_rscCustomizeTypeName . typeDefinitionName) <$> typeDefinitions
|
|
unless (Set.null dups) $
|
|
throw400 RemoteSchemaError $
|
|
"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 $ (_rscCustomizeFieldName _itdName . G._fldName) <$> _itdFieldsDefinition
|
|
unless (Set.null dups) $
|
|
throw400 RemoteSchemaError $
|
|
"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 $ (_rscCustomizeFieldName _otdName . G._fldName) <$> _otdFieldsDefinition
|
|
unless (Set.null dups) $
|
|
throw400 RemoteSchemaError $
|
|
"Field name mappings for object type " <> _otdName <<>
|
|
" are not distinct; the following fields appear more than once: " <>
|
|
dquoteList dups
|
|
_ -> pure ()
|
|
|
|
-- | 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
|
|
. (HasVersion, MonadIO m, MonadUnique m, MonadError QErr m, Tracing.MonadTrace m)
|
|
=> Env.Environment
|
|
-> HTTP.Manager
|
|
-> RemoteSchemaName
|
|
-> RemoteSchemaInfo
|
|
-> m RemoteSchemaCtx
|
|
fetchRemoteSchema env manager _rscName _rscInfo@RemoteSchemaInfo{..} = do
|
|
(_, _, rscRawIntrospectionResultDirty) <-
|
|
execRemoteGQ env manager adminUserInfo [] _rscInfo introspectionQuery
|
|
|
|
-- Parse the JSON into flat GraphQL type AST
|
|
FromIntrospection rscIntroDirty <-
|
|
J.eitherDecode rscRawIntrospectionResultDirty `onLeft` (throw400 RemoteSchemaError . T.pack)
|
|
|
|
-- possibly transform type names from the remote schema, per the user's 'RemoteSchemaDef'
|
|
let (customizer, decustomizer) = getCustomizers (addDefaultRoots rscIntroDirty) rsCustomization
|
|
|
|
validateSchemaCustomizations customizer (irDoc rscIntroDirty)
|
|
|
|
let _rscIntro = customizeIntrospectionResult customizer rscIntroDirty
|
|
_rscRawIntrospectionResult = J.encode $ FromIntrospection _rscIntro
|
|
|
|
let typeNameCustomizer = fmap (const $ _rscCustomizeTypeName customizer) $ _rscTypeNames =<< rsCustomization
|
|
|
|
-- Check that the parsed GraphQL type info is valid by running the schema generation
|
|
(piQuery, piMutation, piSubscription) <-
|
|
P.runSchemaT @m @(P.ParseT Identity) $ buildRemoteParser _rscIntro decustomizer _rscInfo typeNameCustomizer
|
|
|
|
-- 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, _rscParsed = ParsedIntrospection{..}, _rscCustomizer = decustomizer, _rscTypeNameCustomizer = typeNameCustomizer, ..}
|
|
|
|
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)
|
|
|
|
-- | Include a map from type name to kind. This allows us to pass
|
|
-- extra type information required to convert our schema
|
|
-- back into JSON.
|
|
data WithKinds a
|
|
= WithKinds !(HashMap G.Name Text) !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.ToJSON (FromIntrospection G.Description) where
|
|
toJSON = J.toJSON . G.unDescription . fromIntrospection
|
|
|
|
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.ToJSON (FromIntrospection G.ScalarTypeDefinition) where
|
|
toJSON (FromIntrospection G.ScalarTypeDefinition {..}) = objectWithoutNullValues
|
|
[ "kind" .= J.String "SCALAR"
|
|
, "name" .= _stdName
|
|
, "description" .= fmap FromIntrospection _stdDescription
|
|
]
|
|
|
|
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.ToJSON (WithKinds (G.ObjectTypeDefinition G.InputValueDefinition)) where
|
|
toJSON (WithKinds kinds G.ObjectTypeDefinition {..}) = objectWithoutNullValues
|
|
[ "kind" .= J.String "OBJECT"
|
|
, "name" .= _otdName
|
|
, "description" .= fmap FromIntrospection _otdDescription
|
|
, "fields" .= fmap (WithKinds kinds) _otdFieldsDefinition
|
|
, "interfaces" .= fmap (WithKinds kinds . toInterfaceTypeDefinition) _otdImplementsInterfaces
|
|
]
|
|
where
|
|
toInterfaceTypeDefinition :: G.Name -> G.InterfaceTypeDefinition [G.Name] G.InputValueDefinition
|
|
toInterfaceTypeDefinition name = G.InterfaceTypeDefinition Nothing name [] [] []
|
|
|
|
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.ToJSON (WithKinds a) => J.ToJSON (WithKinds (G.FieldDefinition a)) where
|
|
toJSON (WithKinds kinds G.FieldDefinition {..}) = objectWithoutNullValues
|
|
[ "name" .= _fldName
|
|
, "description" .= fmap FromIntrospection _fldDescription
|
|
, "args" .= fmap (WithKinds kinds) _fldArgumentsDefinition
|
|
, "type" .= WithKinds kinds _fldType
|
|
]
|
|
|
|
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.ToJSON (WithKinds G.GType) where
|
|
toJSON (WithKinds kinds gtype) = objectWithoutNullValues $ case gtype of
|
|
G.TypeNamed (G.Nullability True) name ->
|
|
[ "kind" .= Map.lookup name kinds
|
|
, "name" .= name
|
|
]
|
|
G.TypeNamed (G.Nullability False) name ->
|
|
[ "kind" .= J.String "NON_NULL"
|
|
, "ofType" .= WithKinds kinds (G.TypeNamed (G.Nullability True) name)
|
|
]
|
|
G.TypeList (G.Nullability True) ty ->
|
|
[ "kind" .= J.String "LIST"
|
|
, "ofType" .= WithKinds kinds ty
|
|
]
|
|
G.TypeList (G.Nullability False) ty ->
|
|
[ "kind" .= J.String "NON_NULL"
|
|
, "ofType" .= WithKinds kinds (G.TypeList (G.Nullability True) ty)
|
|
]
|
|
|
|
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.ToJSON (WithKinds G.InputValueDefinition) where
|
|
toJSON (WithKinds kinds G.InputValueDefinition {..}) = objectWithoutNullValues
|
|
[ "name" .= _ivdName
|
|
, "description" .= fmap FromIntrospection _ivdDescription
|
|
, "type" .= WithKinds kinds _ivdType
|
|
, "defaultValue" .= fmap FromIntrospection _ivdDefaultValue
|
|
]
|
|
|
|
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.ToJSON (FromIntrospection (G.Value Void)) where
|
|
toJSON = J.String . toTxt . fromIntrospection
|
|
|
|
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.ToJSON (WithKinds (G.InterfaceTypeDefinition [G.Name] G.InputValueDefinition)) where
|
|
toJSON (WithKinds kinds G.InterfaceTypeDefinition {..}) = objectWithoutNullValues
|
|
[ "kind" .= J.String "INTERFACE"
|
|
, "name" .= _itdName
|
|
, "description" .= fmap FromIntrospection _itdDescription
|
|
, "fields" .= fmap (WithKinds kinds) _itdFieldsDefinition
|
|
, "possibleTypes" .= fmap (WithKinds kinds . toObjectTypeDefinition) _itdPossibleTypes
|
|
]
|
|
|
|
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.ToJSON (WithKinds G.UnionTypeDefinition) where
|
|
toJSON (WithKinds kinds G.UnionTypeDefinition {..}) = objectWithoutNullValues
|
|
[ "kind" .= J.String "UNION"
|
|
, "name" .= _utdName
|
|
, "description" .= fmap FromIntrospection _utdDescription
|
|
, "possibleTypes" .= fmap (WithKinds kinds . toObjectTypeDefinition) _utdMemberTypes
|
|
]
|
|
|
|
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.ToJSON (FromIntrospection G.EnumTypeDefinition) where
|
|
toJSON (FromIntrospection G.EnumTypeDefinition {..}) = objectWithoutNullValues
|
|
[ "kind" .= J.String "ENUM"
|
|
, "name" .= _etdName
|
|
, "description" .= fmap FromIntrospection _etdDescription
|
|
, "enumValues" .= fmap FromIntrospection _etdValueDefinitions
|
|
]
|
|
|
|
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.ToJSON (FromIntrospection G.EnumValueDefinition) where
|
|
toJSON (FromIntrospection G.EnumValueDefinition {..}) = objectWithoutNullValues
|
|
[ "name" .= _evdName
|
|
, "description" .= fmap FromIntrospection _evdDescription
|
|
]
|
|
|
|
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.ToJSON (WithKinds (G.InputObjectTypeDefinition G.InputValueDefinition)) where
|
|
toJSON (WithKinds kinds G.InputObjectTypeDefinition {..}) = objectWithoutNullValues
|
|
[ "kind" .= J.String "INPUT_OBJECT"
|
|
, "name" .= _iotdName
|
|
, "description" .= fmap FromIntrospection _iotdDescription
|
|
, "inputFields" .= fmap (WithKinds kinds) _iotdValueDefinitions
|
|
]
|
|
|
|
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.ToJSON (WithKinds (G.TypeDefinition [G.Name] G.InputValueDefinition)) where
|
|
toJSON (WithKinds kinds typeDefinition) = case typeDefinition of
|
|
G.TypeDefinitionScalar scalarTypeDefinition -> J.toJSON $ FromIntrospection scalarTypeDefinition
|
|
G.TypeDefinitionObject objectTypeDefinition -> J.toJSON $ WithKinds kinds objectTypeDefinition
|
|
G.TypeDefinitionInterface interfaceTypeDefinition -> J.toJSON $ WithKinds kinds interfaceTypeDefinition
|
|
G.TypeDefinitionUnion unionTypeDefinition -> J.toJSON $ WithKinds kinds unionTypeDefinition
|
|
G.TypeDefinitionEnum enumTypeDefinition -> J.toJSON $ FromIntrospection enumTypeDefinition
|
|
G.TypeDefinitionInputObject inputObjectTypeDefinition -> J.toJSON $ WithKinds kinds inputObjectTypeDefinition
|
|
|
|
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 (fmap fromIntrospection types'))
|
|
queryRoot mutationRoot subsRoot
|
|
return $ FromIntrospection r
|
|
|
|
instance J.ToJSON (FromIntrospection IntrospectionResult) where
|
|
toJSON (FromIntrospection IntrospectionResult{..}) = objectWithoutNullValues ["data" .= _data]
|
|
where
|
|
_data = objectWithoutNullValues ["__schema" .= schema]
|
|
schema = objectWithoutNullValues
|
|
[ "types" .= fmap (WithKinds kinds . fmap _rsitdDefinition) types
|
|
, "queryType" .= queryType
|
|
, "mutationType" .= mutationType
|
|
, "subscriptionType" .= subscriptionType
|
|
]
|
|
RemoteSchemaIntrospection types = irDoc
|
|
kinds = Map.fromList $ types <&> \case
|
|
G.TypeDefinitionScalar G.ScalarTypeDefinition{..} -> (_stdName, "SCALAR")
|
|
G.TypeDefinitionObject G.ObjectTypeDefinition{..} -> (_otdName, "OBJECT")
|
|
G.TypeDefinitionInterface G.InterfaceTypeDefinition{..} -> (_itdName, "INTERFACE")
|
|
G.TypeDefinitionUnion G.UnionTypeDefinition{..} -> (_utdName, "UNION")
|
|
G.TypeDefinitionEnum G.EnumTypeDefinition{..} -> (_etdName, "ENUM")
|
|
G.TypeDefinitionInputObject G.InputObjectTypeDefinition{..} -> (_iotdName, "INPUT_OBJECT")
|
|
named :: G.Name -> J.Object
|
|
named = ("name" .=)
|
|
queryType = named irQueryRoot
|
|
mutationType = named <$> irMutationRoot
|
|
subscriptionType = named <$> irSubscriptionRoot
|
|
|
|
parseIntrospectionResult :: J.Value -> J.Parser IntrospectionResult
|
|
parseIntrospectionResult value = fromIntrospection <$> J.parseJSON value
|
|
|
|
introspectionResultToJSON :: IntrospectionResult -> J.Value
|
|
introspectionResultToJSON = J.toJSON . FromIntrospection
|
|
|
|
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
|
|
:: ( HasVersion
|
|
, MonadIO m
|
|
, MonadError QErr m
|
|
, Tracing.MonadTrace m
|
|
)
|
|
=> Env.Environment
|
|
-> HTTP.Manager
|
|
-> UserInfo
|
|
-> [N.Header]
|
|
-> RemoteSchemaInfo
|
|
-> GQLReqOutgoing
|
|
-> m (DiffTime, [N.Header], BL.ByteString)
|
|
-- ^ Returns the response body and headers, along with the time taken for the
|
|
-- HTTP request to complete
|
|
execRemoteGQ env manager userInfo reqHdrs rsi gqlReq@GQLReq{..} = do
|
|
let gqlReqUnparsed = renderGQLReqOutgoing gqlReq
|
|
|
|
when (G._todType _grQuery == G.OperationTypeSubscription) $
|
|
throw400 NotSupported "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
|
|
initReqE <- liftIO $ try $ HTTP.parseRequest (show url)
|
|
initReq <- onLeft initReqE httpThrow
|
|
let req = initReq
|
|
{ HTTP.method = "POST"
|
|
, HTTP.requestHeaders = finalHeaders
|
|
, HTTP.requestBody = HTTP.RequestBodyLBS (J.encode gqlReqUnparsed)
|
|
, HTTP.responseTimeout = HTTP.responseTimeoutMicro (timeout * 1000000)
|
|
}
|
|
Tracing.tracedHttpRequest req \req' -> do
|
|
(time, res) <- withElapsedTime $ liftIO $ try $ HTTP.httpLbs req' manager
|
|
resp <- onLeft res httpThrow
|
|
pure (time, mkSetCookieHeaders resp, resp ^. Wreq.responseBody)
|
|
where
|
|
RemoteSchemaInfo url hdrConf fwdClientHdrs timeout _mPrefix = rsi
|
|
httpThrow :: (MonadError QErr m) => HTTP.HttpException -> m a
|
|
httpThrow = \case
|
|
HTTP.HttpExceptionRequest _req content -> throw500 $ tshow content
|
|
HTTP.InvalidUrlException _url reason -> throw500 $ tshow reason
|
|
|
|
userInfoToHdrs = sessionVariablesToHeaders $ _uiSession userInfo
|
|
|
|
identityCustomizer :: RemoteSchemaCustomizer
|
|
identityCustomizer = RemoteSchemaCustomizer Nothing id $ const id
|
|
|
|
typeDefinitionName :: G.TypeDefinition a b -> G.Name
|
|
typeDefinitionName = \case
|
|
G.TypeDefinitionScalar G.ScalarTypeDefinition{..} -> _stdName
|
|
G.TypeDefinitionObject G.ObjectTypeDefinition{..} -> _otdName
|
|
G.TypeDefinitionInterface G.InterfaceTypeDefinition{..} -> _itdName
|
|
G.TypeDefinitionUnion G.UnionTypeDefinition{..} -> _utdName
|
|
G.TypeDefinitionEnum G.EnumTypeDefinition{..} -> _etdName
|
|
G.TypeDefinitionInputObject G.InputObjectTypeDefinition{..} -> _iotdName
|
|
|
|
getCustomizers :: IntrospectionResult -> Maybe RemoteSchemaCustomization -> (RemoteSchemaCustomizer, RemoteSchemaCustomizer)
|
|
getCustomizers _ Nothing = (identityCustomizer, identityCustomizer)
|
|
getCustomizers IntrospectionResult{..} (Just RemoteSchemaCustomization{..}) = (customizer, decustomizer)
|
|
where
|
|
mapMap f = Map.fromList . map f . Map.toList
|
|
invertMap = mapMap swap -- key collisions are checked for later in validateSchemaCustomizations
|
|
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 $ typeDefinitionName <$> 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.fromList $ typeDefinitions >>= \case
|
|
G.TypeDefinitionObject G.ObjectTypeDefinition{..} -> pure (_otdName, G._fldName <$> _otdFieldsDefinition)
|
|
G.TypeDefinitionInterface G.InterfaceTypeDefinition{..} -> pure (_itdName, G._fldName <$> _itdFieldsDefinition)
|
|
_ -> []
|
|
|
|
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
|
|
|
|
mapLookup :: (Eq a, Hashable a) => HashMap a a -> a -> a
|
|
mapLookup m a = fromMaybe a $ Map.lookup a m
|
|
|
|
mapMapLookup :: (Eq a, Hashable a, Eq b, Hashable b) => HashMap a (HashMap b b) -> a -> b -> b
|
|
mapMapLookup m a = maybe id mapLookup $ Map.lookup a m
|
|
|
|
|
|
customizer = RemoteSchemaCustomizer
|
|
{ _rscNamespaceFieldName = _rscRootFieldsNamespace
|
|
, _rscCustomizeTypeName = mapLookup typeRenameMap
|
|
, _rscCustomizeFieldName = mapMapLookup fieldRenameMap
|
|
}
|
|
decustomizer = RemoteSchemaCustomizer
|
|
{ _rscNamespaceFieldName = _rscRootFieldsNamespace
|
|
, _rscCustomizeTypeName = mapLookup $ invertMap typeRenameMap
|
|
, _rscCustomizeFieldName = mapMapLookup $ mapMap (mapLookup typeRenameMap *** invertMap) fieldRenameMap
|
|
}
|
|
|
|
customizeIntrospectionResult :: RemoteSchemaCustomizer -> IntrospectionResult -> IntrospectionResult
|
|
customizeIntrospectionResult RemoteSchemaCustomizer{..} IntrospectionResult{..} = IntrospectionResult
|
|
{ irDoc = customizeRemoteSchemaIntrospection irDoc
|
|
, irQueryRoot = customizedQueryRoot
|
|
, irMutationRoot = customizedMutationRoot
|
|
, irSubscriptionRoot = customizedSubscriptionRoot
|
|
}
|
|
where
|
|
|
|
-- Create customized root type names by appending "Query", "Mutation" or "Subscription" to the custom namespace field name
|
|
customizeRootTypeName suffix = maybe id (const . (<> suffix)) _rscNamespaceFieldName
|
|
customizedQueryRoot = customizeRootTypeName $$(G.litName "Query") irQueryRoot
|
|
customizedMutationRoot = customizeRootTypeName $$(G.litName "Mutation") <$> irMutationRoot
|
|
customizedSubscriptionRoot = customizeRootTypeName $$(G.litName "Subscription") <$> irSubscriptionRoot
|
|
|
|
-- Create object type definitions for each of the custom namespace root types.
|
|
-- Each object type has a single field where the field name is
|
|
-- the custom namespace and the type is the original root type.
|
|
namespaceRootTypeDefinitions = case _rscNamespaceFieldName of
|
|
Nothing -> []
|
|
Just namespaceFieldName ->
|
|
let mkNamespaceTypeDef originalRootTypeName customizedRootTypeName =
|
|
G.TypeDefinitionObject $ G.ObjectTypeDefinition (Just "custom namespace root type") customizedRootTypeName [] []
|
|
[G.FieldDefinition (Just "custom namespace field") namespaceFieldName []
|
|
(G.TypeNamed (G.Nullability True) $ _rscCustomizeTypeName originalRootTypeName) []]
|
|
in catMaybes
|
|
[ pure $ mkNamespaceTypeDef irQueryRoot customizedQueryRoot
|
|
, mkNamespaceTypeDef <$> irMutationRoot <*> customizedMutationRoot
|
|
, mkNamespaceTypeDef <$> irSubscriptionRoot <*> customizedSubscriptionRoot
|
|
]
|
|
|
|
customizeRemoteSchemaIntrospection :: RemoteSchemaIntrospection -> RemoteSchemaIntrospection
|
|
customizeRemoteSchemaIntrospection (RemoteSchemaIntrospection typeDefinition) =
|
|
RemoteSchemaIntrospection $ namespaceRootTypeDefinitions ++ fmap customizeTypeDefinition typeDefinition
|
|
|
|
customizeTypeDefinition :: G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition -> G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition
|
|
customizeTypeDefinition = \case
|
|
G.TypeDefinitionScalar scalarTypeDefinition -> G.TypeDefinitionScalar $ customizeScalarTypeDefinition scalarTypeDefinition
|
|
G.TypeDefinitionObject objectTypeDefinition -> G.TypeDefinitionObject $ customizeObjectTypeDefinition objectTypeDefinition
|
|
G.TypeDefinitionInterface interfaceTypeDefinition -> G.TypeDefinitionInterface $ customizeInterfaceTypeDefinition interfaceTypeDefinition
|
|
G.TypeDefinitionUnion unionTypeDefinition -> G.TypeDefinitionUnion $ customizeUnionTypeDefinition unionTypeDefinition
|
|
G.TypeDefinitionEnum enumTypeDefinition -> G.TypeDefinitionEnum $ customizeEnumTypeDefinition enumTypeDefinition
|
|
G.TypeDefinitionInputObject inputObjectTypeDefinition -> G.TypeDefinitionInputObject $ customizeInputObjectTypeDefinition inputObjectTypeDefinition
|
|
|
|
customizeScalarTypeDefinition :: G.ScalarTypeDefinition -> G.ScalarTypeDefinition
|
|
customizeScalarTypeDefinition G.ScalarTypeDefinition{..} =
|
|
G.ScalarTypeDefinition { _stdName = _rscCustomizeTypeName _stdName, ..}
|
|
|
|
customizeObjectTypeDefinition :: G.ObjectTypeDefinition RemoteSchemaInputValueDefinition -> G.ObjectTypeDefinition RemoteSchemaInputValueDefinition
|
|
customizeObjectTypeDefinition G.ObjectTypeDefinition{..} =
|
|
G.ObjectTypeDefinition
|
|
{ _otdName = _rscCustomizeTypeName _otdName
|
|
, _otdImplementsInterfaces = _rscCustomizeTypeName <$> _otdImplementsInterfaces
|
|
, _otdFieldsDefinition = customizeFieldDefinition (_rscCustomizeFieldName _otdName) <$> _otdFieldsDefinition
|
|
, ..
|
|
}
|
|
|
|
customizeFieldDefinition :: (G.Name -> G.Name) -> G.FieldDefinition RemoteSchemaInputValueDefinition -> G.FieldDefinition RemoteSchemaInputValueDefinition
|
|
customizeFieldDefinition customizeFieldName G.FieldDefinition{..} =
|
|
G.FieldDefinition
|
|
{ _fldName = customizeFieldName _fldName
|
|
, _fldType = customizeType _rscCustomizeTypeName _fldType
|
|
, _fldArgumentsDefinition = customizeRemoteSchemaInputValueDefinition <$> _fldArgumentsDefinition
|
|
, ..
|
|
}
|
|
|
|
customizeRemoteSchemaInputValueDefinition :: RemoteSchemaInputValueDefinition -> RemoteSchemaInputValueDefinition
|
|
customizeRemoteSchemaInputValueDefinition RemoteSchemaInputValueDefinition{..} =
|
|
RemoteSchemaInputValueDefinition
|
|
{ _rsitdDefinition = customizeInputValueDefinition _rsitdDefinition
|
|
, ..
|
|
}
|
|
|
|
customizeInputValueDefinition :: G.InputValueDefinition -> G.InputValueDefinition
|
|
customizeInputValueDefinition G.InputValueDefinition{..} =
|
|
G.InputValueDefinition
|
|
{ _ivdType = customizeType _rscCustomizeTypeName _ivdType
|
|
, ..
|
|
}
|
|
|
|
customizeInterfaceTypeDefinition :: G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition -> G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition
|
|
customizeInterfaceTypeDefinition G.InterfaceTypeDefinition{..} =
|
|
G.InterfaceTypeDefinition
|
|
{ _itdName = _rscCustomizeTypeName _itdName
|
|
, _itdFieldsDefinition = customizeFieldDefinition (_rscCustomizeFieldName _itdName) <$> _itdFieldsDefinition
|
|
, _itdPossibleTypes = _rscCustomizeTypeName <$> _itdPossibleTypes
|
|
, ..
|
|
}
|
|
|
|
customizeUnionTypeDefinition :: G.UnionTypeDefinition -> G.UnionTypeDefinition
|
|
customizeUnionTypeDefinition G.UnionTypeDefinition{..} =
|
|
G.UnionTypeDefinition
|
|
{ _utdName = _rscCustomizeTypeName _utdName
|
|
, _utdMemberTypes = _rscCustomizeTypeName <$> _utdMemberTypes
|
|
, ..
|
|
}
|
|
|
|
customizeEnumTypeDefinition :: G.EnumTypeDefinition -> G.EnumTypeDefinition
|
|
customizeEnumTypeDefinition G.EnumTypeDefinition{..} =
|
|
G.EnumTypeDefinition { _etdName = _rscCustomizeTypeName _etdName, ..}
|
|
|
|
customizeInputObjectTypeDefinition :: G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition -> G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition
|
|
customizeInputObjectTypeDefinition G.InputObjectTypeDefinition{..} =
|
|
G.InputObjectTypeDefinition
|
|
{ _iotdName = _rscCustomizeTypeName _iotdName
|
|
, ..
|
|
}
|