-- |
-- = Remote Schema Permissions Validation
--
-- This module parses the GraphQL IDL (Schema Document) that's provided by
-- the user for configuring permissions for remote schemas to a schema
-- introspection object, which is then used to construct the remote schema for
-- the particular role.
--
-- This module does two things essentially:
--
-- 1. Checks if the given schema document is a subset of the upstream remote
--    schema document. This is done by checking if all the objects, interfaces,
--    unions, enums, scalars and input objects provided in the schema document
--    exist in the upstream remote schema too. We validate the fields, directives
--    and arguments too, wherever applicable.
-- 2. Parse the `preset` directives (if any) on input object fields or argument fields.
--    A `preset` directive is used to specify any preset argument on a field, it can be
--    either a static value or session variable value. There is some validation done
--    on preset directives. For example:
--    - Preset directives can only be specified at
--      `ARGUMENT_DEFINITION` or `INPUT_FIELD_DEFINITION`
--    - A field expecting object cannot have a scalar/enum preset directive and vice versa.
--
--    If a preset directive value is a session variable (like `x-hasura-*`), then it's
--    considered to be a session variable value. In the case, the user wants to treat the
--    session variable value literally, they can add the `static` key to the preset directive
--    to indicate that the value provided should be considered literally. For example:
--
--    `user(id: Int @preset(value: "x-hasura-user-id", static: true))
--
--    In this case `x-hasura-user-id` will be considered literally.
--
-- For validation, we use the `MonadValidate` monad transformer to collect as many errors
-- as possible and then report all those errors at one go to the user.
module Hasura.RemoteSchema.SchemaCache.Permission
  ( resolveRoleBasedRemoteSchema,
  )
where

import Control.Monad.Validate
import Data.HashMap.Strict.Extended qualified as HashMap
import Data.HashSet qualified as S
import Data.List.Extended (duplicates, getDifference)
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Data.Text.Extended
import Hasura.Base.Error
import Hasura.GraphQL.Parser.Name qualified as GName
import Hasura.Name qualified as Name
import Hasura.Prelude
import Hasura.RQL.Types.Metadata.Instances ()
import Hasura.RQL.Types.Roles (RoleName, adminRoleName)
import Hasura.RQL.Types.SchemaCache
import Hasura.RemoteSchema.Metadata (RemoteSchemaName)
import Hasura.RemoteSchema.SchemaCache.Types
import Hasura.Server.Utils (englishList, isSessionVariable)
import Hasura.Session (mkSessionVariable)
import Language.GraphQL.Draft.Syntax qualified as G

data FieldDefinitionType
  = ObjectField
  | InterfaceField
  | EnumField
  deriving (Int -> FieldDefinitionType -> ShowS
[FieldDefinitionType] -> ShowS
FieldDefinitionType -> String
(Int -> FieldDefinitionType -> ShowS)
-> (FieldDefinitionType -> String)
-> ([FieldDefinitionType] -> ShowS)
-> Show FieldDefinitionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldDefinitionType -> ShowS
showsPrec :: Int -> FieldDefinitionType -> ShowS
$cshow :: FieldDefinitionType -> String
show :: FieldDefinitionType -> String
$cshowList :: [FieldDefinitionType] -> ShowS
showList :: [FieldDefinitionType] -> ShowS
Show, FieldDefinitionType -> FieldDefinitionType -> Bool
(FieldDefinitionType -> FieldDefinitionType -> Bool)
-> (FieldDefinitionType -> FieldDefinitionType -> Bool)
-> Eq FieldDefinitionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldDefinitionType -> FieldDefinitionType -> Bool
== :: FieldDefinitionType -> FieldDefinitionType -> Bool
$c/= :: FieldDefinitionType -> FieldDefinitionType -> Bool
/= :: FieldDefinitionType -> FieldDefinitionType -> Bool
Eq)

instance ToTxt FieldDefinitionType where
  toTxt :: FieldDefinitionType -> Text
toTxt = \case
    FieldDefinitionType
ObjectField -> Text
"Object"
    FieldDefinitionType
InterfaceField -> Text
"Interface"
    FieldDefinitionType
EnumField -> Text
"Enum"

data ArgumentDefinitionType
  = InputObjectArgument
  | DirectiveArgument
  deriving (Int -> ArgumentDefinitionType -> ShowS
[ArgumentDefinitionType] -> ShowS
ArgumentDefinitionType -> String
(Int -> ArgumentDefinitionType -> ShowS)
-> (ArgumentDefinitionType -> String)
-> ([ArgumentDefinitionType] -> ShowS)
-> Show ArgumentDefinitionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArgumentDefinitionType -> ShowS
showsPrec :: Int -> ArgumentDefinitionType -> ShowS
$cshow :: ArgumentDefinitionType -> String
show :: ArgumentDefinitionType -> String
$cshowList :: [ArgumentDefinitionType] -> ShowS
showList :: [ArgumentDefinitionType] -> ShowS
Show, ArgumentDefinitionType -> ArgumentDefinitionType -> Bool
(ArgumentDefinitionType -> ArgumentDefinitionType -> Bool)
-> (ArgumentDefinitionType -> ArgumentDefinitionType -> Bool)
-> Eq ArgumentDefinitionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArgumentDefinitionType -> ArgumentDefinitionType -> Bool
== :: ArgumentDefinitionType -> ArgumentDefinitionType -> Bool
$c/= :: ArgumentDefinitionType -> ArgumentDefinitionType -> Bool
/= :: ArgumentDefinitionType -> ArgumentDefinitionType -> Bool
Eq)

instance ToTxt ArgumentDefinitionType where
  toTxt :: ArgumentDefinitionType -> Text
toTxt = \case
    ArgumentDefinitionType
InputObjectArgument -> Text
"Input object"
    ArgumentDefinitionType
DirectiveArgument -> Text
"Directive"

data PresetInputTypeInfo
  = PresetScalar G.Name
  | PresetEnum G.Name [G.EnumValue]
  | PresetInputObject [G.InputValueDefinition]
  deriving (Int -> PresetInputTypeInfo -> ShowS
[PresetInputTypeInfo] -> ShowS
PresetInputTypeInfo -> String
(Int -> PresetInputTypeInfo -> ShowS)
-> (PresetInputTypeInfo -> String)
-> ([PresetInputTypeInfo] -> ShowS)
-> Show PresetInputTypeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PresetInputTypeInfo -> ShowS
showsPrec :: Int -> PresetInputTypeInfo -> ShowS
$cshow :: PresetInputTypeInfo -> String
show :: PresetInputTypeInfo -> String
$cshowList :: [PresetInputTypeInfo] -> ShowS
showList :: [PresetInputTypeInfo] -> ShowS
Show, PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
(PresetInputTypeInfo -> PresetInputTypeInfo -> Bool)
-> (PresetInputTypeInfo -> PresetInputTypeInfo -> Bool)
-> Eq PresetInputTypeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
== :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
$c/= :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
/= :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
Eq, (forall x. PresetInputTypeInfo -> Rep PresetInputTypeInfo x)
-> (forall x. Rep PresetInputTypeInfo x -> PresetInputTypeInfo)
-> Generic PresetInputTypeInfo
forall x. Rep PresetInputTypeInfo x -> PresetInputTypeInfo
forall x. PresetInputTypeInfo -> Rep PresetInputTypeInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PresetInputTypeInfo -> Rep PresetInputTypeInfo x
from :: forall x. PresetInputTypeInfo -> Rep PresetInputTypeInfo x
$cto :: forall x. Rep PresetInputTypeInfo x -> PresetInputTypeInfo
to :: forall x. Rep PresetInputTypeInfo x -> PresetInputTypeInfo
Generic, Eq PresetInputTypeInfo
Eq PresetInputTypeInfo
-> (PresetInputTypeInfo -> PresetInputTypeInfo -> Ordering)
-> (PresetInputTypeInfo -> PresetInputTypeInfo -> Bool)
-> (PresetInputTypeInfo -> PresetInputTypeInfo -> Bool)
-> (PresetInputTypeInfo -> PresetInputTypeInfo -> Bool)
-> (PresetInputTypeInfo -> PresetInputTypeInfo -> Bool)
-> (PresetInputTypeInfo
    -> PresetInputTypeInfo -> PresetInputTypeInfo)
-> (PresetInputTypeInfo
    -> PresetInputTypeInfo -> PresetInputTypeInfo)
-> Ord PresetInputTypeInfo
PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
PresetInputTypeInfo -> PresetInputTypeInfo -> Ordering
PresetInputTypeInfo -> PresetInputTypeInfo -> PresetInputTypeInfo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PresetInputTypeInfo -> PresetInputTypeInfo -> Ordering
compare :: PresetInputTypeInfo -> PresetInputTypeInfo -> Ordering
$c< :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
< :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
$c<= :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
<= :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
$c> :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
> :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
$c>= :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
>= :: PresetInputTypeInfo -> PresetInputTypeInfo -> Bool
$cmax :: PresetInputTypeInfo -> PresetInputTypeInfo -> PresetInputTypeInfo
max :: PresetInputTypeInfo -> PresetInputTypeInfo -> PresetInputTypeInfo
$cmin :: PresetInputTypeInfo -> PresetInputTypeInfo -> PresetInputTypeInfo
min :: PresetInputTypeInfo -> PresetInputTypeInfo -> PresetInputTypeInfo
Ord)

data GraphQLType
  = Enum
  | InputObject
  | Object
  | Interface
  | Union
  | Scalar
  | Directive
  | Field FieldDefinitionType
  | Argument ArgumentDefinitionType
  deriving (Int -> GraphQLType -> ShowS
[GraphQLType] -> ShowS
GraphQLType -> String
(Int -> GraphQLType -> ShowS)
-> (GraphQLType -> String)
-> ([GraphQLType] -> ShowS)
-> Show GraphQLType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GraphQLType -> ShowS
showsPrec :: Int -> GraphQLType -> ShowS
$cshow :: GraphQLType -> String
show :: GraphQLType -> String
$cshowList :: [GraphQLType] -> ShowS
showList :: [GraphQLType] -> ShowS
Show, GraphQLType -> GraphQLType -> Bool
(GraphQLType -> GraphQLType -> Bool)
-> (GraphQLType -> GraphQLType -> Bool) -> Eq GraphQLType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GraphQLType -> GraphQLType -> Bool
== :: GraphQLType -> GraphQLType -> Bool
$c/= :: GraphQLType -> GraphQLType -> Bool
/= :: GraphQLType -> GraphQLType -> Bool
Eq)

instance ToTxt GraphQLType where
  toTxt :: GraphQLType -> Text
toTxt = \case
    GraphQLType
Enum -> Text
"Enum"
    GraphQLType
InputObject -> Text
"Input object"
    GraphQLType
Object -> Text
"Object"
    GraphQLType
Interface -> Text
"Interface"
    GraphQLType
Union -> Text
"Union"
    GraphQLType
Scalar -> Text
"Scalar"
    GraphQLType
Directive -> Text
"Directive"
    Field FieldDefinitionType
ObjectField -> Text
"Object field"
    Field FieldDefinitionType
InterfaceField -> Text
"Interface field"
    Field FieldDefinitionType
EnumField -> Text
"Enum field"
    Argument ArgumentDefinitionType
InputObjectArgument -> Text
"Input object argument"
    Argument ArgumentDefinitionType
DirectiveArgument -> Text
"Directive Argument"

data RoleBasedSchemaValidationError
  = -- | error to indicate that a type provided by the user
    -- differs from the corresponding type defined in the upstream
    -- remote schema
    NonMatchingType G.Name GraphQLType G.GType G.GType
  | -- | error to indicate when a type definition doesn't exist
    -- in the upstream remote schema
    TypeDoesNotExist GraphQLType G.Name
  | -- | error to indicate when the default value of an argument
    -- differs from the default value of the corresponding argument
    NonMatchingDefaultValue G.Name G.Name (Maybe (G.Value Void)) (Maybe (G.Value Void))
  | -- | error to indicate when a given input argument doesn't exist
    -- in the corresponding upstream input object
    NonExistingInputArgument G.Name G.Name
  | MissingNonNullableArguments G.Name (NonEmpty G.Name)
  | -- | error to indicate when a given directive argument
    -- doesn't exist in the corresponding upstream directive
    NonExistingDirectiveArgument G.Name GraphQLType G.Name (NonEmpty G.Name)
  | -- | error to indicate when a given field doesn't exist in a field type (Object/Interface)
    NonExistingField (FieldDefinitionType, G.Name) G.Name
  | -- | error to indicate when member types of an Union don't exist in the
    -- corresponding upstream union
    NonExistingUnionMemberTypes G.Name (NE.NonEmpty G.Name)
  | -- | error to indicate when an object is trying to implement an interface
    -- which exists in the schema document but the interface doesn't exist
    -- in the upstream remote.
    CustomInterfacesNotAllowed G.Name (NE.NonEmpty G.Name)
  | -- | error to indicate when object implements interfaces that don't exist
    ObjectImplementsNonExistingInterfaces G.Name (NE.NonEmpty G.Name)
  | -- | error to indicate enum values in an enum do not exist in the
    -- corresponding upstream enum
    NonExistingEnumValues G.Name (NE.NonEmpty G.Name)
  | -- | error to indicate when the user provided schema contains more than
    -- one schema definition
    MultipleSchemaDefinitionsFound
  | -- | error to indicate when the schema definition doesn't contain the
    -- query root.
    MissingQueryRoot
  | DuplicateTypeNames (NE.NonEmpty G.Name)
  | DuplicateDirectives (GraphQLType, G.Name) (NE.NonEmpty G.Name)
  | DuplicateFields (FieldDefinitionType, G.Name) (NE.NonEmpty G.Name)
  | DuplicateArguments G.Name (NE.NonEmpty G.Name)
  | DuplicateEnumValues G.Name (NE.NonEmpty G.Name)
  | InvalidPresetDirectiveLocation
  | MultiplePresetDirectives (GraphQLType, G.Name)
  | NoPresetArgumentFound
  | InvalidPresetArgument G.Name
  | ExpectedInputTypeButGotOutputType G.Name
  | EnumValueNotFound G.Name G.Name
  | ExpectedEnumValue G.Name (G.Value Void)
  | KeyDoesNotExistInInputObject G.Name G.Name
  | ExpectedInputObject G.Name (G.Value Void)
  | ExpectedScalarValue G.Name (G.Value Void)
  | DisallowSessionVarForListType G.Name
  | InvalidStaticValue
  | -- | Error to indicate we're comparing non corresponding
    --   type definitions. Ideally, this error will never occur
    --   unless there's a programming error
    UnexpectedNonMatchingNames G.Name G.Name GraphQLType
  deriving (Int -> RoleBasedSchemaValidationError -> ShowS
[RoleBasedSchemaValidationError] -> ShowS
RoleBasedSchemaValidationError -> String
(Int -> RoleBasedSchemaValidationError -> ShowS)
-> (RoleBasedSchemaValidationError -> String)
-> ([RoleBasedSchemaValidationError] -> ShowS)
-> Show RoleBasedSchemaValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RoleBasedSchemaValidationError -> ShowS
showsPrec :: Int -> RoleBasedSchemaValidationError -> ShowS
$cshow :: RoleBasedSchemaValidationError -> String
show :: RoleBasedSchemaValidationError -> String
$cshowList :: [RoleBasedSchemaValidationError] -> ShowS
showList :: [RoleBasedSchemaValidationError] -> ShowS
Show, RoleBasedSchemaValidationError
-> RoleBasedSchemaValidationError -> Bool
(RoleBasedSchemaValidationError
 -> RoleBasedSchemaValidationError -> Bool)
-> (RoleBasedSchemaValidationError
    -> RoleBasedSchemaValidationError -> Bool)
-> Eq RoleBasedSchemaValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RoleBasedSchemaValidationError
-> RoleBasedSchemaValidationError -> Bool
== :: RoleBasedSchemaValidationError
-> RoleBasedSchemaValidationError -> Bool
$c/= :: RoleBasedSchemaValidationError
-> RoleBasedSchemaValidationError -> Bool
/= :: RoleBasedSchemaValidationError
-> RoleBasedSchemaValidationError -> Bool
Eq)

{-
NOTE: Unused. Should we remove?

convertTypeDef :: G.TypeDefinition [G.Name] a -> G.TypeDefinition () a
convertTypeDef (G.TypeDefinitionInterface (G.InterfaceTypeDefinition desc name dirs flds _)) =
  G.TypeDefinitionInterface $ G.InterfaceTypeDefinition desc name dirs flds ()
convertTypeDef (G.TypeDefinitionScalar s) = G.TypeDefinitionScalar s
convertTypeDef (G.TypeDefinitionInputObject inpObj) = G.TypeDefinitionInputObject inpObj
convertTypeDef (G.TypeDefinitionEnum s) = G.TypeDefinitionEnum s
convertTypeDef (G.TypeDefinitionUnion s) = G.TypeDefinitionUnion s
convertTypeDef (G.TypeDefinitionObject s) = G.TypeDefinitionObject s
-}

{- Note [Remote Schema Argument Presets]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Remote schema argument presets are a way to inject values from static values or
from session variables during execution. Presets can be set using the `preset`
directive, the preset directive is defined in the following manner:

```
scalar PresetValue

directive @preset(
  value: PresetValue
) on INPUT_FIELD_DEFINITION | ARGUMENT_DEFINITION
```

When a preset directive is defined on an input type, the input type is removed
from the schema and the value is injected by the graphql-engine during the
execution.

There are two types of preset:

1. Static preset
----------------

Static preset is used to preset a static GraphQL value which will be injected
during the execution of the query. Static presets can be specified on all types
of input types i.e scalars, enums and input objects and lists of these types.
The preset value (if specified) will be validated against the type it's provided.
For example:

```
users(user_id: Int @preset(value: {user_id: 1}))
```

The above example will throw an error because the preset is attempting to preset
an input object value for a scalar (Int) type.

2. Session variable preset
--------------------------

Session variable preset is used to inject value from a session variable into the
graphql query during the execution. If the `value` argument of the preset directive
is in the format of the session variable i.e. `x-hasura-*` it will be treated as a
session variable preset. During the execution of a query, which has a session variable
preset set, the session variable's will be looked up and the value will be constructed
into a GraphQL variable. Check out `resolveRemoteVariable` for more details about how
the session variable presets get resolved.

At the time of writing this note, session variable presets can **only** be specified at
named types and only for scalar and enum types. This is done because currently there's
no good way to specify array or object values through session variables.
-}

{- Note [Remote Schema Permissions Architecture]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The Remote schema permissions feature is designed in the following way:

1. An user can configure remote schema permissions for a particular role using
   the `add_remote_schema_permissions` API, note that this API will only work
   when remote schema permissions are enabled while starting the graphql-engine,
   which can be done either by the setting the server flag
   `--enable-remote-schema-permissions` or the env variable
   `HASURA_GRAPHQL_ENABLE_REMOTE_SCHEMA_PERMISSIONS` to `true`. Check the module
   documentation of `Hasura.RQL.DDL.RemoteSchema.Permission` (this module) for
   more details about how the `add_remote_schema_permissions` API works.
2. The given schema document is parsed into an `IntrospectionResult` object,
3. The schema is built with the `IntrospectionResult` parsed in #2 for the said role.
   Check out the documentation in `argumentsParser` to know more about how the presets
   are handled.
4. For a remote schema query, the schema will return a `RemoteField` which
   contains unresolved session variables, the `RemoteField` is resolved using the
   `resolveRemoteField` function. The `resolveRemoteVariable` function contains more
   details about how the `RemoteVariable` is resolved.
5. After resolving the remote field, the remote server is queried with the resolved
   remote field.
-}

showRoleBasedSchemaValidationError :: RoleBasedSchemaValidationError -> Text
showRoleBasedSchemaValidationError :: RoleBasedSchemaValidationError -> Text
showRoleBasedSchemaValidationError = \case
  NonMatchingType Name
fldName GraphQLType
fldType GType
expectedType GType
providedType ->
    Text
"expected type of "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
forall t. ToTxt t => t -> Text
dquote Name
fldName
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"("
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GraphQLType -> Text
forall t. ToTxt t => t -> Text
dquote GraphQLType
fldType
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to be "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (GType -> Text
G.showGT GType
expectedType)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but received "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (GType -> Text
G.showGT GType
providedType)
  TypeDoesNotExist GraphQLType
graphQLType Name
typeName ->
    GraphQLType
graphQLType GraphQLType -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
typeName Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" does not exist in the upstream remote schema"
  NonMatchingDefaultValue Name
inpObjName Name
inpValName Maybe (Value Void)
expectedVal Maybe (Value Void)
providedVal ->
    Text
"expected default value of input value: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
inpValName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
"of input object "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
inpObjName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" to be "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe (Value Void) -> Text
defaultValueToText Maybe (Value Void)
expectedVal
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but received "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe (Value Void) -> Text
defaultValueToText Maybe (Value Void)
providedVal
  NonExistingInputArgument Name
inpObjName Name
inpArgName ->
    Text
"input argument " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
inpArgName Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" does not exist in the input object:" Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
inpObjName
  MissingNonNullableArguments Name
fieldName NonEmpty Name
nonNullableArgs ->
    Text
"field: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
fieldName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" expects the following non nullable arguments to "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"be present: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
nonNullableArgs)
  NonExistingDirectiveArgument Name
parentName GraphQLType
parentType Name
directiveName NonEmpty Name
nonExistingArgs ->
    Text
"the following directive argument(s) defined in the directive: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
directiveName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" defined with the type name: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
parentName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" of type "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GraphQLType
parentType
      GraphQLType -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" do not exist in the corresponding upstream directive: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
nonExistingArgs)
  NonExistingField (FieldDefinitionType
fldDefnType, Name
parentTypeName) Name
providedName ->
    Text
"field "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
providedName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" does not exist in the "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldDefinitionType
fldDefnType
      FieldDefinitionType -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
": "
      Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
parentTypeName
  NonExistingUnionMemberTypes Name
unionName NonEmpty Name
nonExistingMembers ->
    Text
"union "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
unionName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" contains members which do not exist in the members"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" of the remote schema union :"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
nonExistingMembers)
  CustomInterfacesNotAllowed Name
objName NonEmpty Name
customInterfaces ->
    Text
"custom interfaces are not supported. "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Object"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
objName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" implements the following custom interfaces: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
customInterfaces)
  ObjectImplementsNonExistingInterfaces Name
objName NonEmpty Name
nonExistentInterfaces ->
    Text
"object "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
objName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" is trying to implement the following interfaces"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" that do not exist in the corresponding upstream remote object: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
nonExistentInterfaces)
  NonExistingEnumValues Name
enumName NonEmpty Name
nonExistentEnumVals ->
    Text
"enum "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
enumName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" contains the following enum values that do not exist "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"in the corresponding upstream remote enum: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
nonExistentEnumVals)
  RoleBasedSchemaValidationError
MissingQueryRoot -> Text
"query root does not exist in the schema definition"
  RoleBasedSchemaValidationError
MultipleSchemaDefinitionsFound -> Text
"multiple schema definitions found"
  DuplicateTypeNames NonEmpty Name
typeNames ->
    Text
"duplicate type names found: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
typeNames)
  DuplicateDirectives (GraphQLType
parentType, Name
parentName) NonEmpty Name
directiveNames ->
    Text
"duplicate directives: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
directiveNames)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"found in the "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GraphQLType
parentType
      GraphQLType -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" "
      Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
parentName
  DuplicateFields (FieldDefinitionType
parentType, Name
parentName) NonEmpty Name
fieldNames ->
    Text
"duplicate fields: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
fieldNames)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"found in the "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldDefinitionType
parentType
      FieldDefinitionType -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" "
      Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
parentName
  DuplicateArguments Name
fieldName NonEmpty Name
args ->
    Text
"duplicate arguments: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
args)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"found in the field: "
      Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
fieldName
  DuplicateEnumValues Name
enumName NonEmpty Name
enumValues ->
    Text
"duplicate enum values: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" ((Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Text
forall t. ToTxt t => t -> Text
dquote NonEmpty Name
enumValues)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" found in the "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
enumName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" enum"
  RoleBasedSchemaValidationError
InvalidPresetDirectiveLocation ->
    Text
"Preset directives can be defined only on INPUT_FIELD_DEFINITION or ARGUMENT_DEFINITION"
  MultiplePresetDirectives (GraphQLType
parentType, Name
parentName) ->
    Text
"found multiple preset directives at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GraphQLType
parentType GraphQLType -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" " Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
parentName
  RoleBasedSchemaValidationError
NoPresetArgumentFound -> Text
"no arguments found in the preset directive"
  InvalidPresetArgument Name
argName ->
    Text
"preset argument \"value\" not found at " Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
argName
  ExpectedInputTypeButGotOutputType Name
typeName -> Text
"expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
typeName Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" to be an input type, but it's an output type"
  EnumValueNotFound Name
enumName Name
enumValue -> Name
enumValue Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" not found in the enum: " Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
enumName
  ExpectedEnumValue Name
typeName Value Void
presetValue ->
    Text
"expected preset value "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value Void
presetValue
      Value Void -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" of type "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
typeName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" to be an enum value"
  ExpectedScalarValue Name
typeName Value Void
presetValue ->
    Text
"expected preset value "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value Void
presetValue
      Value Void -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" of type "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
typeName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" to be a scalar value"
  ExpectedInputObject Name
typeName Value Void
presetValue ->
    Text
"expected preset value "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value Void
presetValue
      Value Void -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" of type "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
typeName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" to be an input object value"
  KeyDoesNotExistInInputObject Name
key' Name
inpObjTypeName ->
    Name
key' Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" does not exist in the input object " Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
inpObjTypeName
  DisallowSessionVarForListType Name
name ->
    Text
"illegal preset value at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
name Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
". Session arguments can only be set for singleton values"
  RoleBasedSchemaValidationError
InvalidStaticValue ->
    Text
"expected preset static value to be a Boolean value"
  UnexpectedNonMatchingNames Name
providedName Name
upstreamName GraphQLType
gType ->
    Text
"unexpected: trying to compare "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GraphQLType
gType
      GraphQLType -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" with name "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
providedName
      Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" with "
      Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
upstreamName
  where
    defaultValueToText :: Maybe (Value Void) -> Text
defaultValueToText = \case
      Just Value Void
defaultValue -> Value Void -> Text
forall t. ToTxt t => t -> Text
toTxt Value Void
defaultValue
      Maybe (Value Void)
Nothing -> Text
""

{-
NOTE: Unused. Should we remove?

presetValueScalar :: G.ScalarTypeDefinition
presetValueScalar = G.ScalarTypeDefinition Nothing G._PresetValue mempty

presetDirectiveDefn :: G.DirectiveDefinition G.InputValueDefinition
presetDirectiveDefn =
  G.DirectiveDefinition Nothing G._preset [directiveArg] directiveLocations
  where
    gType = G.TypeNamed (G.Nullability False) $ G._stdName presetValueScalar

    directiveLocations = map G.DLTypeSystem [G.TSDLARGUMENT_DEFINITION, G.TSDLINPUT_FIELD_DEFINITION]

    directiveArg = G.InputValueDefinition Nothing G._value gType Nothing mempty

presetDirectiveName :: G.Name
presetDirectiveName = G._preset
-}

lookupInputType ::
  G.SchemaDocument ->
  G.Name ->
  Maybe PresetInputTypeInfo
lookupInputType :: SchemaDocument -> Name -> Maybe PresetInputTypeInfo
lookupInputType (G.SchemaDocument [TypeSystemDefinition]
types) Name
name = [TypeSystemDefinition] -> Maybe PresetInputTypeInfo
go [TypeSystemDefinition]
types
  where
    go :: [G.TypeSystemDefinition] -> Maybe PresetInputTypeInfo
    go :: [TypeSystemDefinition] -> Maybe PresetInputTypeInfo
go (TypeSystemDefinition
tp : [TypeSystemDefinition]
tps) =
      case TypeSystemDefinition
tp of
        G.TypeSystemDefinitionSchema SchemaDefinition
_ -> [TypeSystemDefinition] -> Maybe PresetInputTypeInfo
go [TypeSystemDefinition]
tps
        G.TypeSystemDefinitionType TypeDefinition () InputValueDefinition
typeDef ->
          case TypeDefinition () InputValueDefinition
typeDef of
            G.TypeDefinitionScalar (G.ScalarTypeDefinition Maybe Description
_ Name
scalarName [Directive Void]
_) ->
              if
                | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
scalarName -> PresetInputTypeInfo -> Maybe PresetInputTypeInfo
forall a. a -> Maybe a
Just (PresetInputTypeInfo -> Maybe PresetInputTypeInfo)
-> PresetInputTypeInfo -> Maybe PresetInputTypeInfo
forall a b. (a -> b) -> a -> b
$ Name -> PresetInputTypeInfo
PresetScalar Name
scalarName
                | Bool
otherwise -> [TypeSystemDefinition] -> Maybe PresetInputTypeInfo
go [TypeSystemDefinition]
tps
            G.TypeDefinitionEnum (G.EnumTypeDefinition Maybe Description
_ Name
enumName [Directive Void]
_ [EnumValueDefinition]
vals) ->
              if
                | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
enumName -> PresetInputTypeInfo -> Maybe PresetInputTypeInfo
forall a. a -> Maybe a
Just (PresetInputTypeInfo -> Maybe PresetInputTypeInfo)
-> PresetInputTypeInfo -> Maybe PresetInputTypeInfo
forall a b. (a -> b) -> a -> b
$ Name -> [EnumValue] -> PresetInputTypeInfo
PresetEnum Name
enumName ([EnumValue] -> PresetInputTypeInfo)
-> [EnumValue] -> PresetInputTypeInfo
forall a b. (a -> b) -> a -> b
$ (EnumValueDefinition -> EnumValue)
-> [EnumValueDefinition] -> [EnumValue]
forall a b. (a -> b) -> [a] -> [b]
map EnumValueDefinition -> EnumValue
G._evdName [EnumValueDefinition]
vals
                | Bool
otherwise -> [TypeSystemDefinition] -> Maybe PresetInputTypeInfo
go [TypeSystemDefinition]
tps
            G.TypeDefinitionInputObject (G.InputObjectTypeDefinition Maybe Description
_ Name
inpObjName [Directive Void]
_ [InputValueDefinition]
vals) ->
              if
                | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
inpObjName -> PresetInputTypeInfo -> Maybe PresetInputTypeInfo
forall a. a -> Maybe a
Just (PresetInputTypeInfo -> Maybe PresetInputTypeInfo)
-> PresetInputTypeInfo -> Maybe PresetInputTypeInfo
forall a b. (a -> b) -> a -> b
$ [InputValueDefinition] -> PresetInputTypeInfo
PresetInputObject [InputValueDefinition]
vals
                | Bool
otherwise -> [TypeSystemDefinition] -> Maybe PresetInputTypeInfo
go [TypeSystemDefinition]
tps
            TypeDefinition () InputValueDefinition
_ -> [TypeSystemDefinition] -> Maybe PresetInputTypeInfo
go [TypeSystemDefinition]
tps
    go [] = Maybe PresetInputTypeInfo
forall a. Maybe a
Nothing

-- | `parsePresetValue` constructs a GraphQL value when an input value definition
--    contains a preset with it. This function checks if the given preset value
--    is a legal value to the field that's specified it. For example: A scalar input
--    value cannot contain an input object value. When the preset value is a session
--    variable, we treat it as a session variable whose value will be resolved while
--    the query is executed. In the case of session variables preset, we make the GraphQL
--    value as a Variable value and during the execution we resolve all these
--    "session variable" variable(s) and then query the remote server.
parsePresetValue ::
  forall m.
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  G.GType ->
  G.Name ->
  Bool ->
  G.Value Void ->
  m (G.Value RemoteSchemaVariable)
parsePresetValue :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
parsePresetValue GType
gType Name
varName Bool
isStatic Value Void
value = do
  SchemaDocument
schemaDoc <- m SchemaDocument
forall r (m :: * -> *). MonadReader r m => m r
ask
  case GType
gType of
    G.TypeNamed Nullability
_ Name
typeName ->
      case (SchemaDocument -> Name -> Maybe PresetInputTypeInfo
lookupInputType SchemaDocument
schemaDoc Name
typeName) of
        Maybe PresetInputTypeInfo
Nothing -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> RoleBasedSchemaValidationError
ExpectedInputTypeButGotOutputType Name
typeName
        Just (PresetScalar Name
scalarTypeName) ->
          case Value Void
value of
            G.VEnum EnumValue
_ -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Value Void -> RoleBasedSchemaValidationError
ExpectedScalarValue Name
typeName Value Void
value
            G.VString Text
t ->
              case (Text -> Bool
isSessionVariable Text
t Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
isStatic)) of
                Bool
True ->
                  Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    (Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable))
-> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RemoteSchemaVariable -> Value RemoteSchemaVariable
forall var. var -> Value var
G.VVariable
                    (RemoteSchemaVariable -> Value RemoteSchemaVariable)
-> RemoteSchemaVariable -> Value RemoteSchemaVariable
forall a b. (a -> b) -> a -> b
$ SessionVariable
-> Name -> SessionArgumentPresetInfo -> RemoteSchemaVariable
SessionPresetVariable (Text -> SessionVariable
mkSessionVariable Text
t) Name
scalarTypeName
                    (SessionArgumentPresetInfo -> RemoteSchemaVariable)
-> SessionArgumentPresetInfo -> RemoteSchemaVariable
forall a b. (a -> b) -> a -> b
$ SessionArgumentPresetInfo
SessionArgumentPresetScalar
                Bool
False -> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable))
-> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ Text -> Value RemoteSchemaVariable
forall var. Text -> Value var
G.VString Text
t
            G.VList [Value Void]
_ -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Value Void -> RoleBasedSchemaValidationError
ExpectedScalarValue Name
typeName Value Void
value
            G.VObject HashMap Name (Value Void)
_ -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Value Void -> RoleBasedSchemaValidationError
ExpectedScalarValue Name
typeName Value Void
value
            Value Void
v -> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable))
-> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ Value Void -> Value RemoteSchemaVariable
forall var. Value Void -> Value var
G.literal Value Void
v
        Just (PresetEnum Name
enumTypeName [EnumValue]
enumVals) ->
          case Value Void
value of
            enumVal :: Value Void
enumVal@(G.VEnum EnumValue
e) ->
              case EnumValue
e EnumValue -> [EnumValue] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EnumValue]
enumVals of
                Bool
True -> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable))
-> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ Value Void -> Value RemoteSchemaVariable
forall var. Value Void -> Value var
G.literal Value Void
enumVal
                Bool
False -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RoleBasedSchemaValidationError
EnumValueNotFound Name
typeName (Name -> RoleBasedSchemaValidationError)
-> Name -> RoleBasedSchemaValidationError
forall a b. (a -> b) -> a -> b
$ EnumValue -> Name
G.unEnumValue EnumValue
e
            G.VString Text
t ->
              case Text -> Bool
isSessionVariable Text
t of
                Bool
True ->
                  Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    (Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable))
-> Value RemoteSchemaVariable -> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RemoteSchemaVariable -> Value RemoteSchemaVariable
forall var. var -> Value var
G.VVariable
                    (RemoteSchemaVariable -> Value RemoteSchemaVariable)
-> RemoteSchemaVariable -> Value RemoteSchemaVariable
forall a b. (a -> b) -> a -> b
$ SessionVariable
-> Name -> SessionArgumentPresetInfo -> RemoteSchemaVariable
SessionPresetVariable (Text -> SessionVariable
mkSessionVariable Text
t) Name
enumTypeName
                    (SessionArgumentPresetInfo -> RemoteSchemaVariable)
-> SessionArgumentPresetInfo -> RemoteSchemaVariable
forall a b. (a -> b) -> a -> b
$ HashSet EnumValue -> SessionArgumentPresetInfo
SessionArgumentPresetEnum
                    (HashSet EnumValue -> SessionArgumentPresetInfo)
-> HashSet EnumValue -> SessionArgumentPresetInfo
forall a b. (a -> b) -> a -> b
$ [EnumValue] -> HashSet EnumValue
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [EnumValue]
enumVals
                Bool
False -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Value Void -> RoleBasedSchemaValidationError
ExpectedEnumValue Name
typeName Value Void
value
            Value Void
_ -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Value Void -> RoleBasedSchemaValidationError
ExpectedEnumValue Name
typeName Value Void
value
        Just (PresetInputObject [InputValueDefinition]
inputValueDefinitions) ->
          let inpValsMap :: HashMap Name InputValueDefinition
inpValsMap = (InputValueDefinition -> Name)
-> [InputValueDefinition] -> HashMap Name InputValueDefinition
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL InputValueDefinition -> Name
G._ivdName [InputValueDefinition]
inputValueDefinitions
              parseInputObjectField :: Name -> Value Void -> m (Value RemoteSchemaVariable)
parseInputObjectField Name
k Value Void
val = do
                InputValueDefinition
inpVal <- Maybe InputValueDefinition
-> m InputValueDefinition -> m InputValueDefinition
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (Name
-> HashMap Name InputValueDefinition -> Maybe InputValueDefinition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
k HashMap Name InputValueDefinition
inpValsMap) ([RoleBasedSchemaValidationError] -> m InputValueDefinition
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m InputValueDefinition)
-> [RoleBasedSchemaValidationError] -> m InputValueDefinition
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RoleBasedSchemaValidationError
KeyDoesNotExistInInputObject Name
k Name
typeName)
                GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
parsePresetValue (InputValueDefinition -> GType
G._ivdType InputValueDefinition
inpVal) Name
k Bool
isStatic Value Void
val
           in case Value Void
value of
                G.VObject HashMap Name (Value Void)
obj ->
                  HashMap Name (Value RemoteSchemaVariable)
-> Value RemoteSchemaVariable
forall var. HashMap Name (Value var) -> Value var
G.VObject (HashMap Name (Value RemoteSchemaVariable)
 -> Value RemoteSchemaVariable)
-> m (HashMap Name (Value RemoteSchemaVariable))
-> m (Value RemoteSchemaVariable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Value Void -> m (Value RemoteSchemaVariable))
-> HashMap Name (Value Void)
-> m (HashMap Name (Value RemoteSchemaVariable))
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HashMap.traverseWithKey Name -> Value Void -> m (Value RemoteSchemaVariable)
parseInputObjectField HashMap Name (Value Void)
obj
                Value Void
_ -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Value Void -> RoleBasedSchemaValidationError
ExpectedInputObject Name
typeName Value Void
value
    G.TypeList Nullability
_ GType
gType' ->
      case Value Void
value of
        G.VList [Value Void]
lst -> [Value RemoteSchemaVariable] -> Value RemoteSchemaVariable
forall var. [Value var] -> Value var
G.VList ([Value RemoteSchemaVariable] -> Value RemoteSchemaVariable)
-> m [Value RemoteSchemaVariable] -> m (Value RemoteSchemaVariable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value Void -> m (Value RemoteSchemaVariable))
-> [Value Void] -> m [Value RemoteSchemaVariable]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
parsePresetValue GType
gType' Name
varName Bool
isStatic) [Value Void]
lst
        -- The below is valid because singleton GraphQL values can be "upgraded"
        -- to array types. For ex: An `Int` value can be provided as input to
        -- a type `[Int]` or `[[Int]]`
        s' :: Value Void
s'@(G.VString Text
s) ->
          case Text -> Bool
isSessionVariable Text
s of
            Bool
True -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> RoleBasedSchemaValidationError
DisallowSessionVarForListType Name
varName
            Bool
False -> GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
parsePresetValue GType
gType' Name
varName Bool
isStatic Value Void
s'
        Value Void
v -> GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
parsePresetValue GType
gType' Name
varName Bool
isStatic Value Void
v

parsePresetDirective ::
  forall m.
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  G.GType ->
  G.Name ->
  G.Directive Void ->
  m (G.Value RemoteSchemaVariable)
parsePresetDirective :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
GType -> Name -> Directive Void -> m (Value RemoteSchemaVariable)
parsePresetDirective GType
gType Name
parentArgName (G.Directive Name
_name HashMap Name (Value Void)
args) = do
  if
    | HashMap Name (Value Void) -> Bool
forall k v. HashMap k v -> Bool
HashMap.null HashMap Name (Value Void)
args -> [RoleBasedSchemaValidationError] -> m (Value RemoteSchemaVariable)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Value RemoteSchemaVariable))
-> [RoleBasedSchemaValidationError]
-> m (Value RemoteSchemaVariable)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError
NoPresetArgumentFound
    | Bool
otherwise -> do
        Value Void
val <-
          Maybe (Value Void) -> m (Value Void) -> m (Value Void)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (Name -> HashMap Name (Value Void) -> Maybe (Value Void)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
Name._value HashMap Name (Value Void)
args)
            (m (Value Void) -> m (Value Void))
-> m (Value Void) -> m (Value Void)
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m (Value Void)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute
            ([RoleBasedSchemaValidationError] -> m (Value Void))
-> [RoleBasedSchemaValidationError] -> m (Value Void)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> RoleBasedSchemaValidationError
InvalidPresetArgument Name
parentArgName
        Bool
isStatic <-
          case (Name -> HashMap Name (Value Void) -> Maybe (Value Void)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
Name._static HashMap Name (Value Void)
args) of
            Maybe (Value Void)
Nothing -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            (Just (G.VBoolean Bool
b)) -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
            Maybe (Value Void)
_ -> [RoleBasedSchemaValidationError] -> m Bool
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m Bool)
-> [RoleBasedSchemaValidationError] -> m Bool
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError
InvalidStaticValue
        GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
GType
-> Name -> Bool -> Value Void -> m (Value RemoteSchemaVariable)
parsePresetValue GType
gType Name
parentArgName Bool
isStatic Value Void
val

-- | validateDirective checks if the arguments of a given directive
--   is a subset of the corresponding upstream directive arguments
--   *NOTE*: This function assumes that the `providedDirective` and the
--   `upstreamDirective` have the same name.
validateDirective ::
  (MonadValidate [RoleBasedSchemaValidationError] m) =>
  -- | provided directive
  G.Directive a ->
  -- | upstream directive
  G.Directive a ->
  -- | parent type and name
  (GraphQLType, G.Name) ->
  m ()
validateDirective :: forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
Directive a -> Directive a -> (GraphQLType, Name) -> m ()
validateDirective Directive a
providedDirective Directive a
upstreamDirective (GraphQLType
parentType, Name
parentTypeName) = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
providedName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
upstreamName)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> GraphQLType -> RoleBasedSchemaValidationError
UnexpectedNonMatchingNames Name
providedName Name
upstreamName GraphQLType
Directive
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> [Name] -> Maybe (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ HashMap Name (Value a) -> [Name]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap Name (Value a)
argsDiff) ((NonEmpty Name -> m ()) -> m ())
-> (NonEmpty Name -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
argNames ->
    [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
      ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name
-> GraphQLType
-> Name
-> NonEmpty Name
-> RoleBasedSchemaValidationError
NonExistingDirectiveArgument Name
parentTypeName GraphQLType
parentType Name
providedName NonEmpty Name
argNames
  where
    argsDiff :: HashMap Name (Value a)
argsDiff = HashMap Name (Value a)
-> HashMap Name (Value a) -> HashMap Name (Value a)
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HashMap.difference HashMap Name (Value a)
providedDirectiveArgs HashMap Name (Value a)
upstreamDirectiveArgs

    G.Directive Name
providedName HashMap Name (Value a)
providedDirectiveArgs = Directive a
providedDirective
    G.Directive Name
upstreamName HashMap Name (Value a)
upstreamDirectiveArgs = Directive a
upstreamDirective

-- | validateDirectives checks if the `providedDirectives`
--   are a subset of `upstreamDirectives` and then validate
--   each of the directives by calling the `validateDirective`
validateDirectives ::
  (MonadValidate [RoleBasedSchemaValidationError] m) =>
  [G.Directive a] ->
  [G.Directive a] ->
  G.TypeSystemDirectiveLocation ->
  (GraphQLType, G.Name) ->
  m (Maybe (G.Directive a))
validateDirectives :: forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
[Directive a]
-> [Directive a]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive a))
validateDirectives [Directive a]
providedDirectives [Directive a]
upstreamDirectives TypeSystemDirectiveLocation
directiveLocation (GraphQLType, Name)
parentType = do
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> [Name] -> Maybe (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList (HashSet Name -> [Name]) -> HashSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> HashSet Name
forall a. Hashable a => [a] -> HashSet a
duplicates ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ (Directive a -> Name) -> [Directive a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Directive a -> Name
forall var. Directive var -> Name
G._dName [Directive a]
nonPresetDirectives) ((NonEmpty Name -> m Any) -> m ())
-> (NonEmpty Name -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
dups -> do
    [RoleBasedSchemaValidationError] -> m Any
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m Any)
-> [RoleBasedSchemaValidationError] -> m Any
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ (GraphQLType, Name)
-> NonEmpty Name -> RoleBasedSchemaValidationError
DuplicateDirectives (GraphQLType, Name)
parentType NonEmpty Name
dups
  [Directive a] -> (Directive a -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Directive a]
nonPresetDirectives ((Directive a -> m ()) -> m ()) -> (Directive a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Directive a
dir -> do
    let directiveName :: Name
directiveName = Directive a -> Name
forall var. Directive var -> Name
G._dName Directive a
dir
    Directive a
upstreamDir <-
      Maybe (Directive a) -> m (Directive a) -> m (Directive a)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (Name -> HashMap Name (Directive a) -> Maybe (Directive a)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
directiveName HashMap Name (Directive a)
upstreamDirectivesMap)
        (m (Directive a) -> m (Directive a))
-> m (Directive a) -> m (Directive a)
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m (Directive a)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute
        ([RoleBasedSchemaValidationError] -> m (Directive a))
-> [RoleBasedSchemaValidationError] -> m (Directive a)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ GraphQLType -> Name -> RoleBasedSchemaValidationError
TypeDoesNotExist GraphQLType
Directive Name
directiveName
    Directive a -> Directive a -> (GraphQLType, Name) -> m ()
forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
Directive a -> Directive a -> (GraphQLType, Name) -> m ()
validateDirective Directive a
dir Directive a
upstreamDir (GraphQLType, Name)
parentType
  case [Directive a]
presetDirectives of
    [] -> Maybe (Directive a) -> m (Maybe (Directive a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Directive a)
forall a. Maybe a
Nothing
    [Directive a
presetDirective] -> do
      case TypeSystemDirectiveLocation
directiveLocation of
        TypeSystemDirectiveLocation
G.TSDLINPUT_FIELD_DEFINITION -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        TypeSystemDirectiveLocation
G.TSDLARGUMENT_DEFINITION -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        TypeSystemDirectiveLocation
_ -> [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError
InvalidPresetDirectiveLocation
      Maybe (Directive a) -> m (Maybe (Directive a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Directive a) -> m (Maybe (Directive a)))
-> Maybe (Directive a) -> m (Maybe (Directive a))
forall a b. (a -> b) -> a -> b
$ Directive a -> Maybe (Directive a)
forall a. a -> Maybe a
Just Directive a
presetDirective
    [Directive a]
_ ->
      [RoleBasedSchemaValidationError] -> m (Maybe (Directive a))
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m (Maybe (Directive a)))
-> [RoleBasedSchemaValidationError] -> m (Maybe (Directive a))
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ (GraphQLType, Name) -> RoleBasedSchemaValidationError
MultiplePresetDirectives (GraphQLType, Name)
parentType
  where
    upstreamDirectivesMap :: HashMap Name (Directive a)
upstreamDirectivesMap = (Directive a -> Name)
-> [Directive a] -> HashMap Name (Directive a)
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL Directive a -> Name
forall var. Directive var -> Name
G._dName [Directive a]
upstreamDirectives

    presetFilterFn :: Directive var -> Bool
presetFilterFn = (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
Name._preset) (Name -> Bool) -> (Directive var -> Name) -> Directive var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directive var -> Name
forall var. Directive var -> Name
G._dName

    presetDirectives :: [Directive a]
presetDirectives = (Directive a -> Bool) -> [Directive a] -> [Directive a]
forall a. (a -> Bool) -> [a] -> [a]
filter Directive a -> Bool
forall {var}. Directive var -> Bool
presetFilterFn [Directive a]
providedDirectives

    nonPresetDirectives :: [Directive a]
nonPresetDirectives = (Directive a -> Bool) -> [Directive a] -> [Directive a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Directive a -> Bool) -> Directive a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directive a -> Bool
forall {var}. Directive var -> Bool
presetFilterFn) [Directive a]
providedDirectives

-- |  `validateEnumTypeDefinition` checks the validity of an enum definition
-- provided by the user against the corresponding upstream enum.
-- The function does the following things:
-- 1. Validates the directives (if any)
-- 2. For each enum provided, check if the enum values are a subset of
--    the enum values of the corresponding upstream enum
-- *NOTE*: This function assumes that the `providedEnum` and the `upstreamEnum`
-- have the same name.
validateEnumTypeDefinition ::
  (MonadValidate [RoleBasedSchemaValidationError] m) =>
  -- | provided enum type definition
  G.EnumTypeDefinition ->
  -- | upstream enum type definition
  G.EnumTypeDefinition ->
  m G.EnumTypeDefinition
validateEnumTypeDefinition :: forall (m :: * -> *).
MonadValidate [RoleBasedSchemaValidationError] m =>
EnumTypeDefinition -> EnumTypeDefinition -> m EnumTypeDefinition
validateEnumTypeDefinition EnumTypeDefinition
providedEnum EnumTypeDefinition
upstreamEnum = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
providedName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
upstreamName)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> GraphQLType -> RoleBasedSchemaValidationError
UnexpectedNonMatchingNames Name
providedName Name
upstreamName GraphQLType
Enum
  m (Maybe (Directive Void)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Directive Void)) -> m ())
-> m (Maybe (Directive Void)) -> m ()
forall a b. (a -> b) -> a -> b
$ [Directive Void]
-> [Directive Void]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive Void))
forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
[Directive a]
-> [Directive a]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive a))
validateDirectives [Directive Void]
providedDirectives [Directive Void]
upstreamDirectives TypeSystemDirectiveLocation
G.TSDLENUM ((GraphQLType, Name) -> m (Maybe (Directive Void)))
-> (GraphQLType, Name) -> m (Maybe (Directive Void))
forall a b. (a -> b) -> a -> b
$ (GraphQLType
Enum, Name
providedName)
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> [Name] -> Maybe (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList (HashSet Name -> [Name]) -> HashSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> HashSet Name
forall a. Hashable a => [a] -> HashSet a
duplicates [Name]
providedEnumValNames) ((NonEmpty Name -> m Any) -> m ())
-> (NonEmpty Name -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
dups -> do
    [RoleBasedSchemaValidationError] -> m Any
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m Any)
-> [RoleBasedSchemaValidationError] -> m Any
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty Name -> RoleBasedSchemaValidationError
DuplicateEnumValues Name
providedName NonEmpty Name
dups
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> [Name] -> Maybe (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList HashSet Name
fieldsDifference) ((NonEmpty Name -> m ()) -> m ())
-> (NonEmpty Name -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
nonExistingEnumVals ->
    [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty Name -> RoleBasedSchemaValidationError
NonExistingEnumValues Name
providedName NonEmpty Name
nonExistingEnumVals
  EnumTypeDefinition -> m EnumTypeDefinition
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumTypeDefinition
providedEnum
  where
    G.EnumTypeDefinition Maybe Description
_ Name
providedName [Directive Void]
providedDirectives [EnumValueDefinition]
providedValueDefns = EnumTypeDefinition
providedEnum

    G.EnumTypeDefinition Maybe Description
_ Name
upstreamName [Directive Void]
upstreamDirectives [EnumValueDefinition]
upstreamValueDefns = EnumTypeDefinition
upstreamEnum

    providedEnumValNames :: [Name]
providedEnumValNames = (EnumValueDefinition -> Name) -> [EnumValueDefinition] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (EnumValue -> Name
G.unEnumValue (EnumValue -> Name)
-> (EnumValueDefinition -> EnumValue)
-> EnumValueDefinition
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumValueDefinition -> EnumValue
G._evdName) ([EnumValueDefinition] -> [Name])
-> [EnumValueDefinition] -> [Name]
forall a b. (a -> b) -> a -> b
$ [EnumValueDefinition]
providedValueDefns

    upstreamEnumValNames :: [Name]
upstreamEnumValNames = (EnumValueDefinition -> Name) -> [EnumValueDefinition] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (EnumValue -> Name
G.unEnumValue (EnumValue -> Name)
-> (EnumValueDefinition -> EnumValue)
-> EnumValueDefinition
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumValueDefinition -> EnumValue
G._evdName) ([EnumValueDefinition] -> [Name])
-> [EnumValueDefinition] -> [Name]
forall a b. (a -> b) -> a -> b
$ [EnumValueDefinition]
upstreamValueDefns

    fieldsDifference :: HashSet Name
fieldsDifference = [Name] -> [Name] -> HashSet Name
forall a. Hashable a => [a] -> [a] -> HashSet a
getDifference [Name]
providedEnumValNames [Name]
upstreamEnumValNames

-- | `validateInputValueDefinition` validates a given input value definition
--   , against the corresponding upstream input value definition. Two things
--   are validated to do the same, the type and the default value of the
--   input value definitions should be equal.
validateInputValueDefinition ::
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  G.InputValueDefinition ->
  G.InputValueDefinition ->
  G.Name ->
  m RemoteSchemaInputValueDefinition
validateInputValueDefinition :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
InputValueDefinition
-> InputValueDefinition
-> Name
-> m RemoteSchemaInputValueDefinition
validateInputValueDefinition InputValueDefinition
providedDefn InputValueDefinition
upstreamDefn Name
inputObjectName = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
providedName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
upstreamName)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> GraphQLType -> RoleBasedSchemaValidationError
UnexpectedNonMatchingNames Name
providedName Name
upstreamName (ArgumentDefinitionType -> GraphQLType
Argument ArgumentDefinitionType
InputObjectArgument)
  Maybe (Directive Void)
presetDirective <-
    [Directive Void]
-> [Directive Void]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive Void))
forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
[Directive a]
-> [Directive a]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive a))
validateDirectives [Directive Void]
providedDirectives [Directive Void]
upstreamDirectives TypeSystemDirectiveLocation
G.TSDLINPUT_FIELD_DEFINITION
      ((GraphQLType, Name) -> m (Maybe (Directive Void)))
-> (GraphQLType, Name) -> m (Maybe (Directive Void))
forall a b. (a -> b) -> a -> b
$ (ArgumentDefinitionType -> GraphQLType
Argument ArgumentDefinitionType
InputObjectArgument, Name
inputObjectName)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GType
providedType GType -> GType -> Bool
forall a. Eq a => a -> a -> Bool
/= GType
upstreamType)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name
-> GraphQLType -> GType -> GType -> RoleBasedSchemaValidationError
NonMatchingType Name
providedName (ArgumentDefinitionType -> GraphQLType
Argument ArgumentDefinitionType
InputObjectArgument) GType
upstreamType GType
providedType
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Value Void)
providedDefaultValue Maybe (Value Void) -> Maybe (Value Void) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (Value Void)
upstreamDefaultValue)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name
-> Name
-> Maybe (Value Void)
-> Maybe (Value Void)
-> RoleBasedSchemaValidationError
NonMatchingDefaultValue
      Name
inputObjectName
      Name
providedName
      Maybe (Value Void)
upstreamDefaultValue
      Maybe (Value Void)
providedDefaultValue
  Maybe (Value RemoteSchemaVariable)
presetArguments <- Maybe (Directive Void)
-> (Directive Void -> m (Value RemoteSchemaVariable))
-> m (Maybe (Value RemoteSchemaVariable))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (Directive Void)
presetDirective ((Directive Void -> m (Value RemoteSchemaVariable))
 -> m (Maybe (Value RemoteSchemaVariable)))
-> (Directive Void -> m (Value RemoteSchemaVariable))
-> m (Maybe (Value RemoteSchemaVariable))
forall a b. (a -> b) -> a -> b
$ GType -> Name -> Directive Void -> m (Value RemoteSchemaVariable)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
GType -> Name -> Directive Void -> m (Value RemoteSchemaVariable)
parsePresetDirective GType
providedType Name
providedName
  RemoteSchemaInputValueDefinition
-> m RemoteSchemaInputValueDefinition
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteSchemaInputValueDefinition
 -> m RemoteSchemaInputValueDefinition)
-> RemoteSchemaInputValueDefinition
-> m RemoteSchemaInputValueDefinition
forall a b. (a -> b) -> a -> b
$ InputValueDefinition
-> Maybe (Value RemoteSchemaVariable)
-> RemoteSchemaInputValueDefinition
RemoteSchemaInputValueDefinition InputValueDefinition
providedDefn Maybe (Value RemoteSchemaVariable)
presetArguments
  where
    G.InputValueDefinition Maybe Description
_ Name
providedName GType
providedType Maybe (Value Void)
providedDefaultValue [Directive Void]
providedDirectives = InputValueDefinition
providedDefn
    G.InputValueDefinition Maybe Description
_ Name
upstreamName GType
upstreamType Maybe (Value Void)
upstreamDefaultValue [Directive Void]
upstreamDirectives = InputValueDefinition
upstreamDefn

-- | `validateArguments` validates the provided arguments against the corresponding
--    upstream remote schema arguments.
validateArguments ::
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  (G.ArgumentsDefinition G.InputValueDefinition) ->
  (G.ArgumentsDefinition RemoteSchemaInputValueDefinition) ->
  G.Name ->
  m [RemoteSchemaInputValueDefinition]
validateArguments :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
[InputValueDefinition]
-> ArgumentsDefinition RemoteSchemaInputValueDefinition
-> Name
-> m (ArgumentsDefinition RemoteSchemaInputValueDefinition)
validateArguments [InputValueDefinition]
providedArgs ArgumentsDefinition RemoteSchemaInputValueDefinition
upstreamArgs Name
parentTypeName = do
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> [Name] -> Maybe (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList (HashSet Name -> [Name]) -> HashSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> HashSet Name
forall a. Hashable a => [a] -> HashSet a
duplicates ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ (InputValueDefinition -> Name) -> [InputValueDefinition] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map InputValueDefinition -> Name
G._ivdName [InputValueDefinition]
providedArgs) ((NonEmpty Name -> m Any) -> m ())
-> (NonEmpty Name -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
dups -> do
    [RoleBasedSchemaValidationError] -> m Any
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m Any)
-> [RoleBasedSchemaValidationError] -> m Any
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty Name -> RoleBasedSchemaValidationError
DuplicateArguments Name
parentTypeName NonEmpty Name
dups
  let argsDiff :: HashSet Name
argsDiff = [Name] -> [Name] -> HashSet Name
forall a. Hashable a => [a] -> [a] -> HashSet a
getDifference [Name]
nonNullableUpstreamArgs [Name]
nonNullableProvidedArgs
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> [Name] -> Maybe (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList HashSet Name
argsDiff) ((NonEmpty Name -> m Any) -> m ())
-> (NonEmpty Name -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
nonNullableArgs -> do
    [RoleBasedSchemaValidationError] -> m Any
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m Any)
-> [RoleBasedSchemaValidationError] -> m Any
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty Name -> RoleBasedSchemaValidationError
MissingNonNullableArguments Name
parentTypeName NonEmpty Name
nonNullableArgs
  [InputValueDefinition]
-> (InputValueDefinition -> m RemoteSchemaInputValueDefinition)
-> m (ArgumentsDefinition RemoteSchemaInputValueDefinition)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [InputValueDefinition]
providedArgs ((InputValueDefinition -> m RemoteSchemaInputValueDefinition)
 -> m (ArgumentsDefinition RemoteSchemaInputValueDefinition))
-> (InputValueDefinition -> m RemoteSchemaInputValueDefinition)
-> m (ArgumentsDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ \providedArg :: InputValueDefinition
providedArg@(G.InputValueDefinition Maybe Description
_ Name
name GType
_ Maybe (Value Void)
_ [Directive Void]
_) -> do
    InputValueDefinition
upstreamArg <-
      Maybe InputValueDefinition
-> m InputValueDefinition -> m InputValueDefinition
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (Name
-> HashMap Name InputValueDefinition -> Maybe InputValueDefinition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
name HashMap Name InputValueDefinition
upstreamArgsMap)
        (m InputValueDefinition -> m InputValueDefinition)
-> m InputValueDefinition -> m InputValueDefinition
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m InputValueDefinition
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute
        ([RoleBasedSchemaValidationError] -> m InputValueDefinition)
-> [RoleBasedSchemaValidationError] -> m InputValueDefinition
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RoleBasedSchemaValidationError
NonExistingInputArgument Name
parentTypeName Name
name
    InputValueDefinition
-> InputValueDefinition
-> Name
-> m RemoteSchemaInputValueDefinition
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
InputValueDefinition
-> InputValueDefinition
-> Name
-> m RemoteSchemaInputValueDefinition
validateInputValueDefinition InputValueDefinition
providedArg InputValueDefinition
upstreamArg Name
parentTypeName
  where
    upstreamArgsMap :: HashMap Name InputValueDefinition
upstreamArgsMap = (InputValueDefinition -> Name)
-> [InputValueDefinition] -> HashMap Name InputValueDefinition
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL InputValueDefinition -> Name
G._ivdName ([InputValueDefinition] -> HashMap Name InputValueDefinition)
-> [InputValueDefinition] -> HashMap Name InputValueDefinition
forall a b. (a -> b) -> a -> b
$ (RemoteSchemaInputValueDefinition -> InputValueDefinition)
-> ArgumentsDefinition RemoteSchemaInputValueDefinition
-> [InputValueDefinition]
forall a b. (a -> b) -> [a] -> [b]
map RemoteSchemaInputValueDefinition -> InputValueDefinition
_rsitdDefinition ArgumentsDefinition RemoteSchemaInputValueDefinition
upstreamArgs

    nonNullableUpstreamArgs :: [Name]
nonNullableUpstreamArgs = (InputValueDefinition -> Name) -> [InputValueDefinition] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map InputValueDefinition -> Name
G._ivdName ([InputValueDefinition] -> [Name])
-> [InputValueDefinition] -> [Name]
forall a b. (a -> b) -> a -> b
$ (InputValueDefinition -> Bool)
-> [InputValueDefinition] -> [InputValueDefinition]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (InputValueDefinition -> Bool) -> InputValueDefinition -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GType -> Bool
G.isNullable (GType -> Bool)
-> (InputValueDefinition -> GType) -> InputValueDefinition -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputValueDefinition -> GType
G._ivdType) ([InputValueDefinition] -> [InputValueDefinition])
-> [InputValueDefinition] -> [InputValueDefinition]
forall a b. (a -> b) -> a -> b
$ (RemoteSchemaInputValueDefinition -> InputValueDefinition)
-> ArgumentsDefinition RemoteSchemaInputValueDefinition
-> [InputValueDefinition]
forall a b. (a -> b) -> [a] -> [b]
map RemoteSchemaInputValueDefinition -> InputValueDefinition
_rsitdDefinition ArgumentsDefinition RemoteSchemaInputValueDefinition
upstreamArgs

    nonNullableProvidedArgs :: [Name]
nonNullableProvidedArgs = (InputValueDefinition -> Name) -> [InputValueDefinition] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map InputValueDefinition -> Name
G._ivdName ([InputValueDefinition] -> [Name])
-> [InputValueDefinition] -> [Name]
forall a b. (a -> b) -> a -> b
$ (InputValueDefinition -> Bool)
-> [InputValueDefinition] -> [InputValueDefinition]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (InputValueDefinition -> Bool) -> InputValueDefinition -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GType -> Bool
G.isNullable (GType -> Bool)
-> (InputValueDefinition -> GType) -> InputValueDefinition -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputValueDefinition -> GType
G._ivdType) [InputValueDefinition]
providedArgs

validateInputObjectTypeDefinition ::
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  G.InputObjectTypeDefinition G.InputValueDefinition ->
  G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition ->
  m (G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
validateInputObjectTypeDefinition :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
InputObjectTypeDefinition InputValueDefinition
-> InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
validateInputObjectTypeDefinition InputObjectTypeDefinition InputValueDefinition
providedInputObj InputObjectTypeDefinition RemoteSchemaInputValueDefinition
upstreamInputObj = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
providedName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
upstreamName)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> GraphQLType -> RoleBasedSchemaValidationError
UnexpectedNonMatchingNames Name
providedName Name
upstreamName GraphQLType
InputObject
  m (Maybe (Directive Void)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Directive Void)) -> m ())
-> m (Maybe (Directive Void)) -> m ()
forall a b. (a -> b) -> a -> b
$ [Directive Void]
-> [Directive Void]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive Void))
forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
[Directive a]
-> [Directive a]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive a))
validateDirectives [Directive Void]
providedDirectives [Directive Void]
upstreamDirectives TypeSystemDirectiveLocation
G.TSDLINPUT_OBJECT ((GraphQLType, Name) -> m (Maybe (Directive Void)))
-> (GraphQLType, Name) -> m (Maybe (Directive Void))
forall a b. (a -> b) -> a -> b
$ (GraphQLType
InputObject, Name
providedName)
  ArgumentsDefinition RemoteSchemaInputValueDefinition
args <- [InputValueDefinition]
-> ArgumentsDefinition RemoteSchemaInputValueDefinition
-> Name
-> m (ArgumentsDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
[InputValueDefinition]
-> ArgumentsDefinition RemoteSchemaInputValueDefinition
-> Name
-> m (ArgumentsDefinition RemoteSchemaInputValueDefinition)
validateArguments [InputValueDefinition]
providedArgs ArgumentsDefinition RemoteSchemaInputValueDefinition
upstreamArgs (Name -> m (ArgumentsDefinition RemoteSchemaInputValueDefinition))
-> Name -> m (ArgumentsDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ Name
providedName
  InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InputObjectTypeDefinition RemoteSchemaInputValueDefinition
 -> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition))
-> InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ InputObjectTypeDefinition InputValueDefinition
providedInputObj {_iotdValueDefinitions :: ArgumentsDefinition RemoteSchemaInputValueDefinition
G._iotdValueDefinitions = ArgumentsDefinition RemoteSchemaInputValueDefinition
args}
  where
    G.InputObjectTypeDefinition Maybe Description
_ Name
providedName [Directive Void]
providedDirectives [InputValueDefinition]
providedArgs = InputObjectTypeDefinition InputValueDefinition
providedInputObj

    G.InputObjectTypeDefinition Maybe Description
_ Name
upstreamName [Directive Void]
upstreamDirectives ArgumentsDefinition RemoteSchemaInputValueDefinition
upstreamArgs = InputObjectTypeDefinition RemoteSchemaInputValueDefinition
upstreamInputObj

validateFieldDefinition ::
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  (G.FieldDefinition G.InputValueDefinition) ->
  (G.FieldDefinition RemoteSchemaInputValueDefinition) ->
  (FieldDefinitionType, G.Name) ->
  m (G.FieldDefinition RemoteSchemaInputValueDefinition)
validateFieldDefinition :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
FieldDefinition InputValueDefinition
-> FieldDefinition RemoteSchemaInputValueDefinition
-> (FieldDefinitionType, Name)
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
validateFieldDefinition FieldDefinition InputValueDefinition
providedFieldDefinition FieldDefinition RemoteSchemaInputValueDefinition
upstreamFieldDefinition (FieldDefinitionType
parentType, Name
parentTypeName) = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
providedName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
upstreamName)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> GraphQLType -> RoleBasedSchemaValidationError
UnexpectedNonMatchingNames Name
providedName Name
upstreamName (FieldDefinitionType -> GraphQLType
Field FieldDefinitionType
parentType)
  m (Maybe (Directive Void)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Directive Void)) -> m ())
-> m (Maybe (Directive Void)) -> m ()
forall a b. (a -> b) -> a -> b
$ [Directive Void]
-> [Directive Void]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive Void))
forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
[Directive a]
-> [Directive a]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive a))
validateDirectives [Directive Void]
providedDirectives [Directive Void]
upstreamDirectives TypeSystemDirectiveLocation
G.TSDLFIELD_DEFINITION ((GraphQLType, Name) -> m (Maybe (Directive Void)))
-> (GraphQLType, Name) -> m (Maybe (Directive Void))
forall a b. (a -> b) -> a -> b
$ (FieldDefinitionType -> GraphQLType
Field FieldDefinitionType
parentType, Name
parentTypeName)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GType
providedType GType -> GType -> Bool
forall a. Eq a => a -> a -> Bool
/= GType
upstreamType)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name
-> GraphQLType -> GType -> GType -> RoleBasedSchemaValidationError
NonMatchingType Name
providedName (FieldDefinitionType -> GraphQLType
Field FieldDefinitionType
parentType) GType
upstreamType GType
providedType
  ArgumentsDefinition RemoteSchemaInputValueDefinition
args <- [InputValueDefinition]
-> ArgumentsDefinition RemoteSchemaInputValueDefinition
-> Name
-> m (ArgumentsDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
[InputValueDefinition]
-> ArgumentsDefinition RemoteSchemaInputValueDefinition
-> Name
-> m (ArgumentsDefinition RemoteSchemaInputValueDefinition)
validateArguments [InputValueDefinition]
providedArgs ArgumentsDefinition RemoteSchemaInputValueDefinition
upstreamArgs (Name -> m (ArgumentsDefinition RemoteSchemaInputValueDefinition))
-> Name -> m (ArgumentsDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ Name
providedName
  FieldDefinition RemoteSchemaInputValueDefinition
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldDefinition RemoteSchemaInputValueDefinition
 -> m (FieldDefinition RemoteSchemaInputValueDefinition))
-> FieldDefinition RemoteSchemaInputValueDefinition
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ FieldDefinition InputValueDefinition
providedFieldDefinition {_fldArgumentsDefinition :: ArgumentsDefinition RemoteSchemaInputValueDefinition
G._fldArgumentsDefinition = ArgumentsDefinition RemoteSchemaInputValueDefinition
args}
  where
    G.FieldDefinition Maybe Description
_ Name
providedName [InputValueDefinition]
providedArgs GType
providedType [Directive Void]
providedDirectives = FieldDefinition InputValueDefinition
providedFieldDefinition

    G.FieldDefinition Maybe Description
_ Name
upstreamName ArgumentsDefinition RemoteSchemaInputValueDefinition
upstreamArgs GType
upstreamType [Directive Void]
upstreamDirectives = FieldDefinition RemoteSchemaInputValueDefinition
upstreamFieldDefinition

validateFieldDefinitions ::
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  [(G.FieldDefinition G.InputValueDefinition)] ->
  [(G.FieldDefinition RemoteSchemaInputValueDefinition)] ->
  -- | parent type and name
  (FieldDefinitionType, G.Name) ->
  m [(G.FieldDefinition RemoteSchemaInputValueDefinition)]
validateFieldDefinitions :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
[FieldDefinition InputValueDefinition]
-> [FieldDefinition RemoteSchemaInputValueDefinition]
-> (FieldDefinitionType, Name)
-> m [FieldDefinition RemoteSchemaInputValueDefinition]
validateFieldDefinitions [FieldDefinition InputValueDefinition]
providedFldDefnitions [FieldDefinition RemoteSchemaInputValueDefinition]
upstreamFldDefinitions (FieldDefinitionType, Name)
parentType = do
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> [Name] -> Maybe (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList (HashSet Name -> [Name]) -> HashSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> HashSet Name
forall a. Hashable a => [a] -> HashSet a
duplicates ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ (FieldDefinition InputValueDefinition -> Name)
-> [FieldDefinition InputValueDefinition] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldDefinition InputValueDefinition -> Name
forall inputType. FieldDefinition inputType -> Name
G._fldName [FieldDefinition InputValueDefinition]
providedFldDefnitions) ((NonEmpty Name -> m Any) -> m ())
-> (NonEmpty Name -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
dups -> do
    [RoleBasedSchemaValidationError] -> m Any
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m Any)
-> [RoleBasedSchemaValidationError] -> m Any
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ (FieldDefinitionType, Name)
-> NonEmpty Name -> RoleBasedSchemaValidationError
DuplicateFields (FieldDefinitionType, Name)
parentType NonEmpty Name
dups
  [FieldDefinition InputValueDefinition]
-> (FieldDefinition InputValueDefinition
    -> m (FieldDefinition RemoteSchemaInputValueDefinition))
-> m [FieldDefinition RemoteSchemaInputValueDefinition]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [FieldDefinition InputValueDefinition]
providedFldDefnitions ((FieldDefinition InputValueDefinition
  -> m (FieldDefinition RemoteSchemaInputValueDefinition))
 -> m [FieldDefinition RemoteSchemaInputValueDefinition])
-> (FieldDefinition InputValueDefinition
    -> m (FieldDefinition RemoteSchemaInputValueDefinition))
-> m [FieldDefinition RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ \fldDefn :: FieldDefinition InputValueDefinition
fldDefn@(G.FieldDefinition Maybe Description
_ Name
name [InputValueDefinition]
_ GType
_ [Directive Void]
_) -> do
    FieldDefinition RemoteSchemaInputValueDefinition
upstreamFldDefn <-
      Maybe (FieldDefinition RemoteSchemaInputValueDefinition)
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (Name
-> HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition)
-> Maybe (FieldDefinition RemoteSchemaInputValueDefinition)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
name HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition)
upstreamFldDefinitionsMap)
        (m (FieldDefinition RemoteSchemaInputValueDefinition)
 -> m (FieldDefinition RemoteSchemaInputValueDefinition))
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError]
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute
        ([RoleBasedSchemaValidationError]
 -> m (FieldDefinition RemoteSchemaInputValueDefinition))
-> [RoleBasedSchemaValidationError]
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ (FieldDefinitionType, Name)
-> Name -> RoleBasedSchemaValidationError
NonExistingField (FieldDefinitionType, Name)
parentType Name
name
    FieldDefinition InputValueDefinition
-> FieldDefinition RemoteSchemaInputValueDefinition
-> (FieldDefinitionType, Name)
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
FieldDefinition InputValueDefinition
-> FieldDefinition RemoteSchemaInputValueDefinition
-> (FieldDefinitionType, Name)
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
validateFieldDefinition FieldDefinition InputValueDefinition
fldDefn FieldDefinition RemoteSchemaInputValueDefinition
upstreamFldDefn (FieldDefinitionType, Name)
parentType
  where
    upstreamFldDefinitionsMap :: HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition)
upstreamFldDefinitionsMap = (FieldDefinition RemoteSchemaInputValueDefinition -> Name)
-> [FieldDefinition RemoteSchemaInputValueDefinition]
-> HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition)
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL FieldDefinition RemoteSchemaInputValueDefinition -> Name
forall inputType. FieldDefinition inputType -> Name
G._fldName [FieldDefinition RemoteSchemaInputValueDefinition]
upstreamFldDefinitions

validateInterfaceDefinition ::
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  G.InterfaceTypeDefinition () G.InputValueDefinition ->
  G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition ->
  m (G.InterfaceTypeDefinition () RemoteSchemaInputValueDefinition)
validateInterfaceDefinition :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
InterfaceTypeDefinition () InputValueDefinition
-> InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
-> m (InterfaceTypeDefinition () RemoteSchemaInputValueDefinition)
validateInterfaceDefinition InterfaceTypeDefinition () InputValueDefinition
providedInterfaceDefn InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
upstreamInterfaceDefn = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
providedName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
upstreamName)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> GraphQLType -> RoleBasedSchemaValidationError
UnexpectedNonMatchingNames Name
providedName Name
upstreamName GraphQLType
Interface
  m (Maybe (Directive Void)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Directive Void)) -> m ())
-> m (Maybe (Directive Void)) -> m ()
forall a b. (a -> b) -> a -> b
$ [Directive Void]
-> [Directive Void]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive Void))
forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
[Directive a]
-> [Directive a]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive a))
validateDirectives [Directive Void]
providedDirectives [Directive Void]
upstreamDirectives TypeSystemDirectiveLocation
G.TSDLINTERFACE ((GraphQLType, Name) -> m (Maybe (Directive Void)))
-> (GraphQLType, Name) -> m (Maybe (Directive Void))
forall a b. (a -> b) -> a -> b
$ (GraphQLType
Interface, Name
providedName)
  [FieldDefinition RemoteSchemaInputValueDefinition]
fieldDefinitions <- [FieldDefinition InputValueDefinition]
-> [FieldDefinition RemoteSchemaInputValueDefinition]
-> (FieldDefinitionType, Name)
-> m [FieldDefinition RemoteSchemaInputValueDefinition]
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
[FieldDefinition InputValueDefinition]
-> [FieldDefinition RemoteSchemaInputValueDefinition]
-> (FieldDefinitionType, Name)
-> m [FieldDefinition RemoteSchemaInputValueDefinition]
validateFieldDefinitions [FieldDefinition InputValueDefinition]
providedFieldDefns [FieldDefinition RemoteSchemaInputValueDefinition]
upstreamFieldDefns ((FieldDefinitionType, Name)
 -> m [FieldDefinition RemoteSchemaInputValueDefinition])
-> (FieldDefinitionType, Name)
-> m [FieldDefinition RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ (FieldDefinitionType
InterfaceField, Name
providedName)
  InterfaceTypeDefinition () RemoteSchemaInputValueDefinition
-> m (InterfaceTypeDefinition () RemoteSchemaInputValueDefinition)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterfaceTypeDefinition () RemoteSchemaInputValueDefinition
 -> m (InterfaceTypeDefinition () RemoteSchemaInputValueDefinition))
-> InterfaceTypeDefinition () RemoteSchemaInputValueDefinition
-> m (InterfaceTypeDefinition () RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ InterfaceTypeDefinition () InputValueDefinition
providedInterfaceDefn {_itdFieldsDefinition :: [FieldDefinition RemoteSchemaInputValueDefinition]
G._itdFieldsDefinition = [FieldDefinition RemoteSchemaInputValueDefinition]
fieldDefinitions}
  where
    G.InterfaceTypeDefinition Maybe Description
_ Name
providedName [Directive Void]
providedDirectives [FieldDefinition InputValueDefinition]
providedFieldDefns ()
_ = InterfaceTypeDefinition () InputValueDefinition
providedInterfaceDefn

    G.InterfaceTypeDefinition Maybe Description
_ Name
upstreamName [Directive Void]
upstreamDirectives [FieldDefinition RemoteSchemaInputValueDefinition]
upstreamFieldDefns [Name]
_ = InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
upstreamInterfaceDefn

validateScalarDefinition ::
  (MonadValidate [RoleBasedSchemaValidationError] m) =>
  G.ScalarTypeDefinition ->
  G.ScalarTypeDefinition ->
  m G.ScalarTypeDefinition
validateScalarDefinition :: forall (m :: * -> *).
MonadValidate [RoleBasedSchemaValidationError] m =>
ScalarTypeDefinition
-> ScalarTypeDefinition -> m ScalarTypeDefinition
validateScalarDefinition ScalarTypeDefinition
providedScalar ScalarTypeDefinition
upstreamScalar = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
providedName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
upstreamName)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> GraphQLType -> RoleBasedSchemaValidationError
UnexpectedNonMatchingNames Name
providedName Name
upstreamName GraphQLType
Scalar
  m (Maybe (Directive Void)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Directive Void)) -> m ())
-> m (Maybe (Directive Void)) -> m ()
forall a b. (a -> b) -> a -> b
$ [Directive Void]
-> [Directive Void]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive Void))
forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
[Directive a]
-> [Directive a]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive a))
validateDirectives [Directive Void]
providedDirectives [Directive Void]
upstreamDirectives TypeSystemDirectiveLocation
G.TSDLSCALAR ((GraphQLType, Name) -> m (Maybe (Directive Void)))
-> (GraphQLType, Name) -> m (Maybe (Directive Void))
forall a b. (a -> b) -> a -> b
$ (GraphQLType
Scalar, Name
providedName)
  ScalarTypeDefinition -> m ScalarTypeDefinition
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScalarTypeDefinition
providedScalar
  where
    G.ScalarTypeDefinition Maybe Description
_ Name
providedName [Directive Void]
providedDirectives = ScalarTypeDefinition
providedScalar

    G.ScalarTypeDefinition Maybe Description
_ Name
upstreamName [Directive Void]
upstreamDirectives = ScalarTypeDefinition
upstreamScalar

validateUnionDefinition ::
  (MonadValidate [RoleBasedSchemaValidationError] m) =>
  G.UnionTypeDefinition ->
  G.UnionTypeDefinition ->
  m G.UnionTypeDefinition
validateUnionDefinition :: forall (m :: * -> *).
MonadValidate [RoleBasedSchemaValidationError] m =>
UnionTypeDefinition -> UnionTypeDefinition -> m UnionTypeDefinition
validateUnionDefinition UnionTypeDefinition
providedUnion UnionTypeDefinition
upstreamUnion = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
providedName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
upstreamName)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> GraphQLType -> RoleBasedSchemaValidationError
UnexpectedNonMatchingNames Name
providedName Name
upstreamName GraphQLType
Union
  m (Maybe (Directive Void)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Directive Void)) -> m ())
-> m (Maybe (Directive Void)) -> m ()
forall a b. (a -> b) -> a -> b
$ [Directive Void]
-> [Directive Void]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive Void))
forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
[Directive a]
-> [Directive a]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive a))
validateDirectives [Directive Void]
providedDirectives [Directive Void]
upstreamDirectives TypeSystemDirectiveLocation
G.TSDLUNION ((GraphQLType, Name) -> m (Maybe (Directive Void)))
-> (GraphQLType, Name) -> m (Maybe (Directive Void))
forall a b. (a -> b) -> a -> b
$ (GraphQLType
Union, Name
providedName)
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> [Name] -> Maybe (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList HashSet Name
memberTypesDiff) ((NonEmpty Name -> m Any) -> m ())
-> (NonEmpty Name -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
nonExistingMembers ->
    [RoleBasedSchemaValidationError] -> m Any
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m Any)
-> [RoleBasedSchemaValidationError] -> m Any
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty Name -> RoleBasedSchemaValidationError
NonExistingUnionMemberTypes Name
providedName NonEmpty Name
nonExistingMembers
  UnionTypeDefinition -> m UnionTypeDefinition
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnionTypeDefinition
providedUnion
  where
    G.UnionTypeDefinition Maybe Description
_ Name
providedName [Directive Void]
providedDirectives [Name]
providedMemberTypes = UnionTypeDefinition
providedUnion

    G.UnionTypeDefinition Maybe Description
_ Name
upstreamName [Directive Void]
upstreamDirectives [Name]
upstreamMemberTypes = UnionTypeDefinition
upstreamUnion

    memberTypesDiff :: HashSet Name
memberTypesDiff = [Name] -> [Name] -> HashSet Name
forall a. Hashable a => [a] -> [a] -> HashSet a
getDifference [Name]
providedMemberTypes [Name]
upstreamMemberTypes

validateObjectDefinition ::
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  G.ObjectTypeDefinition G.InputValueDefinition ->
  G.ObjectTypeDefinition RemoteSchemaInputValueDefinition ->
  -- | Interfaces declared by in the role-based schema
  S.HashSet G.Name ->
  m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)
validateObjectDefinition :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
ObjectTypeDefinition InputValueDefinition
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> HashSet Name
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
validateObjectDefinition ObjectTypeDefinition InputValueDefinition
providedObj ObjectTypeDefinition RemoteSchemaInputValueDefinition
upstreamObj HashSet Name
interfacesDeclared = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
providedName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
upstreamName)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute
    ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> GraphQLType -> RoleBasedSchemaValidationError
UnexpectedNonMatchingNames Name
providedName Name
upstreamName GraphQLType
Object
  m (Maybe (Directive Void)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Directive Void)) -> m ())
-> m (Maybe (Directive Void)) -> m ()
forall a b. (a -> b) -> a -> b
$ [Directive Void]
-> [Directive Void]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive Void))
forall (m :: * -> *) a.
MonadValidate [RoleBasedSchemaValidationError] m =>
[Directive a]
-> [Directive a]
-> TypeSystemDirectiveLocation
-> (GraphQLType, Name)
-> m (Maybe (Directive a))
validateDirectives [Directive Void]
providedDirectives [Directive Void]
upstreamDirectives TypeSystemDirectiveLocation
G.TSDLOBJECT ((GraphQLType, Name) -> m (Maybe (Directive Void)))
-> (GraphQLType, Name) -> m (Maybe (Directive Void))
forall a b. (a -> b) -> a -> b
$ (GraphQLType
Object, Name
providedName)
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> [Name] -> Maybe (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList HashSet Name
customInterfaces) ((NonEmpty Name -> m ()) -> m ())
-> (NonEmpty Name -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
ifaces ->
    [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty Name -> RoleBasedSchemaValidationError
CustomInterfacesNotAllowed Name
providedName NonEmpty Name
ifaces
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Name]
nonExistingInterfaces) ((NonEmpty Name -> m ()) -> m ())
-> (NonEmpty Name -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
ifaces ->
    [RoleBasedSchemaValidationError] -> m ()
forall e (m :: * -> *). MonadValidate e m => e -> m ()
dispute ([RoleBasedSchemaValidationError] -> m ())
-> [RoleBasedSchemaValidationError] -> m ()
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty Name -> RoleBasedSchemaValidationError
ObjectImplementsNonExistingInterfaces Name
providedName NonEmpty Name
ifaces
  [FieldDefinition RemoteSchemaInputValueDefinition]
fieldDefinitions <-
    [FieldDefinition InputValueDefinition]
-> [FieldDefinition RemoteSchemaInputValueDefinition]
-> (FieldDefinitionType, Name)
-> m [FieldDefinition RemoteSchemaInputValueDefinition]
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
[FieldDefinition InputValueDefinition]
-> [FieldDefinition RemoteSchemaInputValueDefinition]
-> (FieldDefinitionType, Name)
-> m [FieldDefinition RemoteSchemaInputValueDefinition]
validateFieldDefinitions [FieldDefinition InputValueDefinition]
providedFldDefnitions [FieldDefinition RemoteSchemaInputValueDefinition]
upstreamFldDefnitions ((FieldDefinitionType, Name)
 -> m [FieldDefinition RemoteSchemaInputValueDefinition])
-> (FieldDefinitionType, Name)
-> m [FieldDefinition RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ (FieldDefinitionType
ObjectField, Name
providedName)
  ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectTypeDefinition RemoteSchemaInputValueDefinition
 -> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ ObjectTypeDefinition InputValueDefinition
providedObj {_otdFieldsDefinition :: [FieldDefinition RemoteSchemaInputValueDefinition]
G._otdFieldsDefinition = [FieldDefinition RemoteSchemaInputValueDefinition]
fieldDefinitions}
  where
    G.ObjectTypeDefinition
      Maybe Description
_
      Name
providedName
      [Name]
providedIfaces
      [Directive Void]
providedDirectives
      [FieldDefinition InputValueDefinition]
providedFldDefnitions = ObjectTypeDefinition InputValueDefinition
providedObj

    G.ObjectTypeDefinition
      Maybe Description
_
      Name
upstreamName
      [Name]
upstreamIfaces
      [Directive Void]
upstreamDirectives
      [FieldDefinition RemoteSchemaInputValueDefinition]
upstreamFldDefnitions = ObjectTypeDefinition RemoteSchemaInputValueDefinition
upstreamObj

    interfacesDiff :: HashSet Name
interfacesDiff = [Name] -> [Name] -> HashSet Name
forall a. Hashable a => [a] -> [a] -> HashSet a
getDifference [Name]
providedIfaces [Name]
upstreamIfaces

    providedIfacesSet :: HashSet Name
providedIfacesSet = [Name] -> HashSet Name
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Name]
providedIfaces

    customInterfaces :: HashSet Name
customInterfaces = HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.intersection HashSet Name
interfacesDiff HashSet Name
interfacesDeclared

    nonExistingInterfaces :: [Name]
nonExistingInterfaces = HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList (HashSet Name -> [Name]) -> HashSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.difference HashSet Name
interfacesDiff HashSet Name
providedIfacesSet

-- | helper function to validate the schema definitions mentioned in the schema
-- document.
validateSchemaDefinitions ::
  (MonadValidate [RoleBasedSchemaValidationError] m) =>
  [G.SchemaDefinition] ->
  m (Maybe G.Name, Maybe G.Name, Maybe G.Name)
validateSchemaDefinitions :: forall (m :: * -> *).
MonadValidate [RoleBasedSchemaValidationError] m =>
[SchemaDefinition] -> m (Maybe Name, Maybe Name, Maybe Name)
validateSchemaDefinitions [] = (Maybe Name, Maybe Name, Maybe Name)
-> m (Maybe Name, Maybe Name, Maybe Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe Name, Maybe Name, Maybe Name)
 -> m (Maybe Name, Maybe Name, Maybe Name))
-> (Maybe Name, Maybe Name, Maybe Name)
-> m (Maybe Name, Maybe Name, Maybe Name)
forall a b. (a -> b) -> a -> b
$ (Maybe Name
forall a. Maybe a
Nothing, Maybe Name
forall a. Maybe a
Nothing, Maybe Name
forall a. Maybe a
Nothing)
validateSchemaDefinitions [SchemaDefinition
schemaDefn] = do
  let G.SchemaDefinition Maybe [Directive Void]
_ [RootOperationTypeDefinition]
rootOpsTypes = SchemaDefinition
schemaDefn
      rootOpsTypesMap :: HashMap OperationType RootOperationTypeDefinition
rootOpsTypesMap = (RootOperationTypeDefinition -> OperationType)
-> [RootOperationTypeDefinition]
-> HashMap OperationType RootOperationTypeDefinition
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL RootOperationTypeDefinition -> OperationType
G._rotdOperationType [RootOperationTypeDefinition]
rootOpsTypes
      mQueryRootName :: Maybe Name
mQueryRootName = RootOperationTypeDefinition -> Name
G._rotdOperationTypeType (RootOperationTypeDefinition -> Name)
-> Maybe RootOperationTypeDefinition -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OperationType
-> HashMap OperationType RootOperationTypeDefinition
-> Maybe RootOperationTypeDefinition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup OperationType
G.OperationTypeQuery HashMap OperationType RootOperationTypeDefinition
rootOpsTypesMap
      mMutationRootName :: Maybe Name
mMutationRootName = RootOperationTypeDefinition -> Name
G._rotdOperationTypeType (RootOperationTypeDefinition -> Name)
-> Maybe RootOperationTypeDefinition -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OperationType
-> HashMap OperationType RootOperationTypeDefinition
-> Maybe RootOperationTypeDefinition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup OperationType
G.OperationTypeMutation HashMap OperationType RootOperationTypeDefinition
rootOpsTypesMap
      mSubscriptionRootName :: Maybe Name
mSubscriptionRootName = RootOperationTypeDefinition -> Name
G._rotdOperationTypeType (RootOperationTypeDefinition -> Name)
-> Maybe RootOperationTypeDefinition -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OperationType
-> HashMap OperationType RootOperationTypeDefinition
-> Maybe RootOperationTypeDefinition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup OperationType
G.OperationTypeSubscription HashMap OperationType RootOperationTypeDefinition
rootOpsTypesMap
  (Maybe Name, Maybe Name, Maybe Name)
-> m (Maybe Name, Maybe Name, Maybe Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Name
mQueryRootName, Maybe Name
mMutationRootName, Maybe Name
mSubscriptionRootName)
validateSchemaDefinitions [SchemaDefinition]
_ = [RoleBasedSchemaValidationError]
-> m (Maybe Name, Maybe Name, Maybe Name)
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError]
 -> m (Maybe Name, Maybe Name, Maybe Name))
-> [RoleBasedSchemaValidationError]
-> m (Maybe Name, Maybe Name, Maybe Name)
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError
MultipleSchemaDefinitionsFound

-- | Construction of the `possibleTypes` map for interfaces, while parsing the
-- user provided Schema document, it doesn't include the `possibleTypes`, so
-- constructing here, manually.
createPossibleTypesMap :: [(G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)] -> HashMap G.Name [G.Name]
createPossibleTypesMap :: [ObjectTypeDefinition RemoteSchemaInputValueDefinition]
-> HashMap Name [Name]
createPossibleTypesMap [ObjectTypeDefinition RemoteSchemaInputValueDefinition]
objectDefinitions = do
  ([Name] -> [Name] -> [Name])
-> [(Name, [Name])] -> HashMap Name [Name]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
(<>) ([(Name, [Name])] -> HashMap Name [Name])
-> [(Name, [Name])] -> HashMap Name [Name]
forall a b. (a -> b) -> a -> b
$ do
    ObjectTypeDefinition RemoteSchemaInputValueDefinition
objectDefinition <- [ObjectTypeDefinition RemoteSchemaInputValueDefinition]
objectDefinitions
    let objectName :: Name
objectName = ObjectTypeDefinition RemoteSchemaInputValueDefinition -> Name
forall inputType. ObjectTypeDefinition inputType -> Name
G._otdName ObjectTypeDefinition RemoteSchemaInputValueDefinition
objectDefinition
    Name
interface <- ObjectTypeDefinition RemoteSchemaInputValueDefinition -> [Name]
forall inputType. ObjectTypeDefinition inputType -> [Name]
G._otdImplementsInterfaces ObjectTypeDefinition RemoteSchemaInputValueDefinition
objectDefinition
    (Name, [Name]) -> [(Name, [Name])]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
interface, [Name
objectName])

partitionTypeSystemDefinitions ::
  [G.TypeSystemDefinition] ->
  ([G.SchemaDefinition], [G.TypeDefinition () G.InputValueDefinition])
partitionTypeSystemDefinitions :: [TypeSystemDefinition]
-> ([SchemaDefinition], [TypeDefinition () InputValueDefinition])
partitionTypeSystemDefinitions = (TypeSystemDefinition
 -> ([SchemaDefinition], [TypeDefinition () InputValueDefinition])
 -> ([SchemaDefinition], [TypeDefinition () InputValueDefinition]))
-> ([SchemaDefinition], [TypeDefinition () InputValueDefinition])
-> [TypeSystemDefinition]
-> ([SchemaDefinition], [TypeDefinition () InputValueDefinition])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeSystemDefinition
-> ([SchemaDefinition], [TypeDefinition () InputValueDefinition])
-> ([SchemaDefinition], [TypeDefinition () InputValueDefinition])
f ([], [])
  where
    f :: TypeSystemDefinition
-> ([SchemaDefinition], [TypeDefinition () InputValueDefinition])
-> ([SchemaDefinition], [TypeDefinition () InputValueDefinition])
f TypeSystemDefinition
d ([SchemaDefinition]
schemaDefinitions, [TypeDefinition () InputValueDefinition]
typeDefinitions) = case TypeSystemDefinition
d of
      G.TypeSystemDefinitionSchema SchemaDefinition
schemaDefinition -> ((SchemaDefinition
schemaDefinition SchemaDefinition -> [SchemaDefinition] -> [SchemaDefinition]
forall a. a -> [a] -> [a]
: [SchemaDefinition]
schemaDefinitions), [TypeDefinition () InputValueDefinition]
typeDefinitions)
      G.TypeSystemDefinitionType TypeDefinition () InputValueDefinition
typeDefinition -> ([SchemaDefinition]
schemaDefinitions, (TypeDefinition () InputValueDefinition
typeDefinition TypeDefinition () InputValueDefinition
-> [TypeDefinition () InputValueDefinition]
-> [TypeDefinition () InputValueDefinition]
forall a. a -> [a] -> [a]
: [TypeDefinition () InputValueDefinition]
typeDefinitions))

-- | getSchemaDocIntrospection converts the `PartitionedTypeDefinitions` to
-- `IntrospectionResult` because the function `buildRemoteParser` function which
-- builds the remote schema parsers accepts an `IntrospectionResult`. The
-- conversion involves converting `G.TypeDefinition ()` to `G.TypeDefinition
-- [G.Name]`. The `[G.Name]` here being the list of object names that an
-- interface implements. This is needed to be done here by-hand because while
-- specifying the `SchemaDocument` through the GraphQL DSL, it doesn't include
-- the `possibleTypes` along with an object.
getSchemaDocIntrospection ::
  [G.TypeDefinition () RemoteSchemaInputValueDefinition] ->
  (Maybe G.Name, Maybe G.Name, Maybe G.Name) ->
  IntrospectionResult
getSchemaDocIntrospection :: [TypeDefinition () RemoteSchemaInputValueDefinition]
-> (Maybe Name, Maybe Name, Maybe Name) -> IntrospectionResult
getSchemaDocIntrospection [TypeDefinition () RemoteSchemaInputValueDefinition]
providedTypeDefns (Maybe Name
queryRoot, Maybe Name
mutationRoot, Maybe Name
subscriptionRoot) =
  let objects :: [ObjectTypeDefinition RemoteSchemaInputValueDefinition]
objects = ((TypeDefinition () RemoteSchemaInputValueDefinition
  -> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
 -> [TypeDefinition () RemoteSchemaInputValueDefinition]
 -> [ObjectTypeDefinition RemoteSchemaInputValueDefinition])
-> [TypeDefinition () RemoteSchemaInputValueDefinition]
-> (TypeDefinition () RemoteSchemaInputValueDefinition
    -> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
-> [ObjectTypeDefinition RemoteSchemaInputValueDefinition]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TypeDefinition () RemoteSchemaInputValueDefinition
 -> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
-> [TypeDefinition () RemoteSchemaInputValueDefinition]
-> [ObjectTypeDefinition RemoteSchemaInputValueDefinition]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe [TypeDefinition () RemoteSchemaInputValueDefinition]
providedTypeDefns ((TypeDefinition () RemoteSchemaInputValueDefinition
  -> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
 -> [ObjectTypeDefinition RemoteSchemaInputValueDefinition])
-> (TypeDefinition () RemoteSchemaInputValueDefinition
    -> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
-> [ObjectTypeDefinition RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ \case
        G.TypeDefinitionObject ObjectTypeDefinition RemoteSchemaInputValueDefinition
obj -> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a. a -> Maybe a
Just ObjectTypeDefinition RemoteSchemaInputValueDefinition
obj
        TypeDefinition () RemoteSchemaInputValueDefinition
_ -> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a. Maybe a
Nothing
      possibleTypesMap :: HashMap Name [Name]
possibleTypesMap = [ObjectTypeDefinition RemoteSchemaInputValueDefinition]
-> HashMap Name [Name]
createPossibleTypesMap [ObjectTypeDefinition RemoteSchemaInputValueDefinition]
objects
      modifiedTypeDefns :: [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
modifiedTypeDefns = do
        TypeDefinition () RemoteSchemaInputValueDefinition
providedType <- [TypeDefinition () RemoteSchemaInputValueDefinition]
providedTypeDefns
        case TypeDefinition () RemoteSchemaInputValueDefinition
providedType of
          G.TypeDefinitionInterface interface :: InterfaceTypeDefinition () RemoteSchemaInputValueDefinition
interface@(G.InterfaceTypeDefinition Maybe Description
_ Name
name [Directive Void]
_ [FieldDefinition RemoteSchemaInputValueDefinition]
_ ()
_) ->
            TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              (TypeDefinition [Name] RemoteSchemaInputValueDefinition
 -> [TypeDefinition [Name] RemoteSchemaInputValueDefinition])
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionInterface
              (InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
 -> TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall a b. (a -> b) -> a -> b
$ InterfaceTypeDefinition () RemoteSchemaInputValueDefinition
interface {_itdPossibleTypes :: [Name]
G._itdPossibleTypes = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name]) -> [[Name]] -> [Name]
forall a b. (a -> b) -> a -> b
$ Maybe [Name] -> [[Name]]
forall a. Maybe a -> [a]
maybeToList (Name -> HashMap Name [Name] -> Maybe [Name]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
name HashMap Name [Name]
possibleTypesMap)}
          G.TypeDefinitionScalar ScalarTypeDefinition
scalar -> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] RemoteSchemaInputValueDefinition
 -> [TypeDefinition [Name] RemoteSchemaInputValueDefinition])
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ ScalarTypeDefinition
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
ScalarTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionScalar ScalarTypeDefinition
scalar
          G.TypeDefinitionEnum EnumTypeDefinition
enum -> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] RemoteSchemaInputValueDefinition
 -> [TypeDefinition [Name] RemoteSchemaInputValueDefinition])
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ EnumTypeDefinition
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
EnumTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionEnum EnumTypeDefinition
enum
          G.TypeDefinitionObject ObjectTypeDefinition RemoteSchemaInputValueDefinition
obj -> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] RemoteSchemaInputValueDefinition
 -> [TypeDefinition [Name] RemoteSchemaInputValueDefinition])
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
ObjectTypeDefinition inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionObject ObjectTypeDefinition RemoteSchemaInputValueDefinition
obj
          G.TypeDefinitionUnion UnionTypeDefinition
union' -> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] RemoteSchemaInputValueDefinition
 -> [TypeDefinition [Name] RemoteSchemaInputValueDefinition])
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ UnionTypeDefinition
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
UnionTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionUnion UnionTypeDefinition
union'
          G.TypeDefinitionInputObject InputObjectTypeDefinition RemoteSchemaInputValueDefinition
inpObj -> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] RemoteSchemaInputValueDefinition
 -> [TypeDefinition [Name] RemoteSchemaInputValueDefinition])
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
InputObjectTypeDefinition inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionInputObject InputObjectTypeDefinition RemoteSchemaInputValueDefinition
inpObj
      remoteSchemaIntrospection :: RemoteSchemaIntrospection
remoteSchemaIntrospection = HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> RemoteSchemaIntrospection
RemoteSchemaIntrospection (HashMap
   Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
 -> RemoteSchemaIntrospection)
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> RemoteSchemaIntrospection
forall a b. (a -> b) -> a -> b
$ (TypeDefinition [Name] RemoteSchemaInputValueDefinition -> Name)
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
HashMap.fromListOn TypeDefinition [Name] RemoteSchemaInputValueDefinition -> Name
forall possibleTypes inputType.
TypeDefinition possibleTypes inputType -> Name
getTypeName [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
modifiedTypeDefns
   in RemoteSchemaIntrospection
-> Name -> Maybe Name -> Maybe Name -> IntrospectionResult
IntrospectionResult RemoteSchemaIntrospection
remoteSchemaIntrospection (Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
GName._Query Maybe Name
queryRoot) Maybe Name
mutationRoot Maybe Name
subscriptionRoot

-- | validateRemoteSchema accepts two arguments, the `SchemaDocument` of
--   the role-based schema, that is provided by the user and the `SchemaIntrospection`
--   of the upstream remote schema. This function, in turn calls the other validation
--   functions for scalars, enums, unions, interfaces,input objects and objects.
validateRemoteSchema ::
  ( MonadValidate [RoleBasedSchemaValidationError] m,
    MonadReader G.SchemaDocument m
  ) =>
  RemoteSchemaIntrospection ->
  m IntrospectionResult
validateRemoteSchema :: forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
RemoteSchemaIntrospection -> m IntrospectionResult
validateRemoteSchema RemoteSchemaIntrospection
upstreamRemoteSchemaIntrospection = do
  G.SchemaDocument [TypeSystemDefinition]
providedTypeSystemDefinitions <- m SchemaDocument
forall r (m :: * -> *). MonadReader r m => m r
ask
  let ([SchemaDefinition]
providedSchemaDefinitions, [TypeDefinition () InputValueDefinition]
providedTypeDefinitions) =
        [TypeSystemDefinition]
-> ([SchemaDefinition], [TypeDefinition () InputValueDefinition])
partitionTypeSystemDefinitions [TypeSystemDefinition]
providedTypeSystemDefinitions
      duplicateTypesList :: [Name]
duplicateTypesList = HashSet Name -> [Name]
forall a. HashSet a -> [a]
S.toList (HashSet Name -> [Name]) -> HashSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> HashSet Name
forall a. Hashable a => [a] -> HashSet a
duplicates (TypeDefinition () InputValueDefinition -> Name
forall possibleTypes inputType.
TypeDefinition possibleTypes inputType -> Name
getTypeName (TypeDefinition () InputValueDefinition -> Name)
-> [TypeDefinition () InputValueDefinition] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDefinition () InputValueDefinition]
providedTypeDefinitions)
  Maybe (NonEmpty Name) -> (NonEmpty Name -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Name]
duplicateTypesList) ((NonEmpty Name -> m Any) -> m ())
-> (NonEmpty Name -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Name
duplicateTypeNames ->
    [RoleBasedSchemaValidationError] -> m Any
forall a. [RoleBasedSchemaValidationError] -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute ([RoleBasedSchemaValidationError] -> m Any)
-> [RoleBasedSchemaValidationError] -> m Any
forall a b. (a -> b) -> a -> b
$ RoleBasedSchemaValidationError -> [RoleBasedSchemaValidationError]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> [RoleBasedSchemaValidationError])
-> RoleBasedSchemaValidationError
-> [RoleBasedSchemaValidationError]
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> RoleBasedSchemaValidationError
DuplicateTypeNames NonEmpty Name
duplicateTypeNames
  (Maybe Name, Maybe Name, Maybe Name)
rootTypeNames <- [SchemaDefinition] -> m (Maybe Name, Maybe Name, Maybe Name)
forall (m :: * -> *).
MonadValidate [RoleBasedSchemaValidationError] m =>
[SchemaDefinition] -> m (Maybe Name, Maybe Name, Maybe Name)
validateSchemaDefinitions [SchemaDefinition]
providedSchemaDefinitions
  let providedInterfacesTypes :: HashSet Name
providedInterfacesTypes =
        [Name] -> HashSet Name
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList
          ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ ((TypeDefinition () InputValueDefinition -> Maybe Name)
 -> [TypeDefinition () InputValueDefinition] -> [Name])
-> [TypeDefinition () InputValueDefinition]
-> (TypeDefinition () InputValueDefinition -> Maybe Name)
-> [Name]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TypeDefinition () InputValueDefinition -> Maybe Name)
-> [TypeDefinition () InputValueDefinition] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe [TypeDefinition () InputValueDefinition]
providedTypeDefinitions
          ((TypeDefinition () InputValueDefinition -> Maybe Name) -> [Name])
-> (TypeDefinition () InputValueDefinition -> Maybe Name) -> [Name]
forall a b. (a -> b) -> a -> b
$ \case
            G.TypeDefinitionInterface InterfaceTypeDefinition () InputValueDefinition
interface -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ InterfaceTypeDefinition () InputValueDefinition -> Name
forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> Name
G._itdName InterfaceTypeDefinition () InputValueDefinition
interface
            TypeDefinition () InputValueDefinition
_ -> Maybe Name
forall a. Maybe a
Nothing
  [TypeDefinition () RemoteSchemaInputValueDefinition]
validatedTypeDefinitions <-
    [TypeDefinition () InputValueDefinition]
-> (TypeDefinition () InputValueDefinition
    -> m (TypeDefinition () RemoteSchemaInputValueDefinition))
-> m [TypeDefinition () RemoteSchemaInputValueDefinition]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [TypeDefinition () InputValueDefinition]
providedTypeDefinitions ((TypeDefinition () InputValueDefinition
  -> m (TypeDefinition () RemoteSchemaInputValueDefinition))
 -> m [TypeDefinition () RemoteSchemaInputValueDefinition])
-> (TypeDefinition () InputValueDefinition
    -> m (TypeDefinition () RemoteSchemaInputValueDefinition))
-> m [TypeDefinition () RemoteSchemaInputValueDefinition]
forall a b. (a -> b) -> a -> b
$ \case
      G.TypeDefinitionScalar ScalarTypeDefinition
providedScalarTypeDefn -> do
        let nameTxt :: Text
nameTxt = Name -> Text
G.unName (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ ScalarTypeDefinition -> Name
G._stdName ScalarTypeDefinition
providedScalarTypeDefn
        case Text
nameTxt Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"ID", Text
"Int", Text
"Float", Text
"Boolean", Text
"String"] of
          Bool
True -> TypeDefinition () RemoteSchemaInputValueDefinition
-> m (TypeDefinition () RemoteSchemaInputValueDefinition)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition () RemoteSchemaInputValueDefinition
 -> m (TypeDefinition () RemoteSchemaInputValueDefinition))
-> TypeDefinition () RemoteSchemaInputValueDefinition
-> m (TypeDefinition () RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ ScalarTypeDefinition
-> TypeDefinition () RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
ScalarTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionScalar ScalarTypeDefinition
providedScalarTypeDefn
          Bool
False -> do
            ScalarTypeDefinition
upstreamScalarTypeDefn <-
              RemoteSchemaIntrospection -> Name -> Maybe ScalarTypeDefinition
lookupScalar RemoteSchemaIntrospection
upstreamRemoteSchemaIntrospection (ScalarTypeDefinition -> Name
G._stdName ScalarTypeDefinition
providedScalarTypeDefn)
                Maybe ScalarTypeDefinition
-> m ScalarTypeDefinition -> m ScalarTypeDefinition
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` GraphQLType -> Name -> m ScalarTypeDefinition
forall {f :: * -> *} {m :: * -> *} {a}.
(MonadValidate (f RoleBasedSchemaValidationError) m,
 Applicative f) =>
GraphQLType -> Name -> m a
typeNotFound GraphQLType
Scalar (ScalarTypeDefinition -> Name
G._stdName ScalarTypeDefinition
providedScalarTypeDefn)
            ScalarTypeDefinition
-> TypeDefinition () RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
ScalarTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionScalar (ScalarTypeDefinition
 -> TypeDefinition () RemoteSchemaInputValueDefinition)
-> m ScalarTypeDefinition
-> m (TypeDefinition () RemoteSchemaInputValueDefinition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScalarTypeDefinition
-> ScalarTypeDefinition -> m ScalarTypeDefinition
forall (m :: * -> *).
MonadValidate [RoleBasedSchemaValidationError] m =>
ScalarTypeDefinition
-> ScalarTypeDefinition -> m ScalarTypeDefinition
validateScalarDefinition ScalarTypeDefinition
providedScalarTypeDefn ScalarTypeDefinition
upstreamScalarTypeDefn
      G.TypeDefinitionInterface InterfaceTypeDefinition () InputValueDefinition
providedInterfaceTypeDefn -> do
        InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
upstreamInterfaceTypeDefn <-
          RemoteSchemaIntrospection
-> Name
-> Maybe
     (InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition)
lookupInterface RemoteSchemaIntrospection
upstreamRemoteSchemaIntrospection (InterfaceTypeDefinition () InputValueDefinition -> Name
forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> Name
G._itdName InterfaceTypeDefinition () InputValueDefinition
providedInterfaceTypeDefn)
            Maybe
  (InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> m (InterfaceTypeDefinition
        [Name] RemoteSchemaInputValueDefinition)
-> m (InterfaceTypeDefinition
        [Name] RemoteSchemaInputValueDefinition)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` GraphQLType
-> Name
-> m (InterfaceTypeDefinition
        [Name] RemoteSchemaInputValueDefinition)
forall {f :: * -> *} {m :: * -> *} {a}.
(MonadValidate (f RoleBasedSchemaValidationError) m,
 Applicative f) =>
GraphQLType -> Name -> m a
typeNotFound GraphQLType
Interface (InterfaceTypeDefinition () InputValueDefinition -> Name
forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> Name
G._itdName InterfaceTypeDefinition () InputValueDefinition
providedInterfaceTypeDefn)
        InterfaceTypeDefinition () RemoteSchemaInputValueDefinition
-> TypeDefinition () RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionInterface (InterfaceTypeDefinition () RemoteSchemaInputValueDefinition
 -> TypeDefinition () RemoteSchemaInputValueDefinition)
-> m (InterfaceTypeDefinition () RemoteSchemaInputValueDefinition)
-> m (TypeDefinition () RemoteSchemaInputValueDefinition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InterfaceTypeDefinition () InputValueDefinition
-> InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
-> m (InterfaceTypeDefinition () RemoteSchemaInputValueDefinition)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
InterfaceTypeDefinition () InputValueDefinition
-> InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
-> m (InterfaceTypeDefinition () RemoteSchemaInputValueDefinition)
validateInterfaceDefinition InterfaceTypeDefinition () InputValueDefinition
providedInterfaceTypeDefn InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
upstreamInterfaceTypeDefn
      G.TypeDefinitionObject ObjectTypeDefinition InputValueDefinition
providedObjectTypeDefn -> do
        ObjectTypeDefinition RemoteSchemaInputValueDefinition
upstreamObjectTypeDefn <-
          RemoteSchemaIntrospection
-> Name
-> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
lookupObject RemoteSchemaIntrospection
upstreamRemoteSchemaIntrospection (ObjectTypeDefinition InputValueDefinition -> Name
forall inputType. ObjectTypeDefinition inputType -> Name
G._otdName ObjectTypeDefinition InputValueDefinition
providedObjectTypeDefn)
            Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` GraphQLType
-> Name
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall {f :: * -> *} {m :: * -> *} {a}.
(MonadValidate (f RoleBasedSchemaValidationError) m,
 Applicative f) =>
GraphQLType -> Name -> m a
typeNotFound GraphQLType
Object (ObjectTypeDefinition InputValueDefinition -> Name
forall inputType. ObjectTypeDefinition inputType -> Name
G._otdName ObjectTypeDefinition InputValueDefinition
providedObjectTypeDefn)
        ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> TypeDefinition () RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
ObjectTypeDefinition inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionObject
          (ObjectTypeDefinition RemoteSchemaInputValueDefinition
 -> TypeDefinition () RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (TypeDefinition () RemoteSchemaInputValueDefinition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObjectTypeDefinition InputValueDefinition
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> HashSet Name
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
ObjectTypeDefinition InputValueDefinition
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> HashSet Name
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
validateObjectDefinition ObjectTypeDefinition InputValueDefinition
providedObjectTypeDefn ObjectTypeDefinition RemoteSchemaInputValueDefinition
upstreamObjectTypeDefn HashSet Name
providedInterfacesTypes
      G.TypeDefinitionUnion UnionTypeDefinition
providedUnionTypeDefn -> do
        UnionTypeDefinition
upstreamUnionTypeDefn <-
          RemoteSchemaIntrospection -> Name -> Maybe UnionTypeDefinition
lookupUnion RemoteSchemaIntrospection
upstreamRemoteSchemaIntrospection (UnionTypeDefinition -> Name
G._utdName UnionTypeDefinition
providedUnionTypeDefn)
            Maybe UnionTypeDefinition
-> m UnionTypeDefinition -> m UnionTypeDefinition
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` GraphQLType -> Name -> m UnionTypeDefinition
forall {f :: * -> *} {m :: * -> *} {a}.
(MonadValidate (f RoleBasedSchemaValidationError) m,
 Applicative f) =>
GraphQLType -> Name -> m a
typeNotFound GraphQLType
Union (UnionTypeDefinition -> Name
G._utdName UnionTypeDefinition
providedUnionTypeDefn)
        UnionTypeDefinition
-> TypeDefinition () RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
UnionTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionUnion (UnionTypeDefinition
 -> TypeDefinition () RemoteSchemaInputValueDefinition)
-> m UnionTypeDefinition
-> m (TypeDefinition () RemoteSchemaInputValueDefinition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnionTypeDefinition -> UnionTypeDefinition -> m UnionTypeDefinition
forall (m :: * -> *).
MonadValidate [RoleBasedSchemaValidationError] m =>
UnionTypeDefinition -> UnionTypeDefinition -> m UnionTypeDefinition
validateUnionDefinition UnionTypeDefinition
providedUnionTypeDefn UnionTypeDefinition
upstreamUnionTypeDefn
      G.TypeDefinitionEnum EnumTypeDefinition
providedEnumTypeDefn -> do
        EnumTypeDefinition
upstreamEnumTypeDefn <-
          RemoteSchemaIntrospection -> Name -> Maybe EnumTypeDefinition
lookupEnum RemoteSchemaIntrospection
upstreamRemoteSchemaIntrospection (EnumTypeDefinition -> Name
G._etdName EnumTypeDefinition
providedEnumTypeDefn)
            Maybe EnumTypeDefinition
-> m EnumTypeDefinition -> m EnumTypeDefinition
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` GraphQLType -> Name -> m EnumTypeDefinition
forall {f :: * -> *} {m :: * -> *} {a}.
(MonadValidate (f RoleBasedSchemaValidationError) m,
 Applicative f) =>
GraphQLType -> Name -> m a
typeNotFound GraphQLType
Enum (EnumTypeDefinition -> Name
G._etdName EnumTypeDefinition
providedEnumTypeDefn)
        EnumTypeDefinition
-> TypeDefinition () RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
EnumTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionEnum (EnumTypeDefinition
 -> TypeDefinition () RemoteSchemaInputValueDefinition)
-> m EnumTypeDefinition
-> m (TypeDefinition () RemoteSchemaInputValueDefinition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumTypeDefinition -> EnumTypeDefinition -> m EnumTypeDefinition
forall (m :: * -> *).
MonadValidate [RoleBasedSchemaValidationError] m =>
EnumTypeDefinition -> EnumTypeDefinition -> m EnumTypeDefinition
validateEnumTypeDefinition EnumTypeDefinition
providedEnumTypeDefn EnumTypeDefinition
upstreamEnumTypeDefn
      G.TypeDefinitionInputObject InputObjectTypeDefinition InputValueDefinition
providedInputObjectTypeDefn -> do
        InputObjectTypeDefinition RemoteSchemaInputValueDefinition
upstreamInputObjectTypeDefn <-
          RemoteSchemaIntrospection
-> Name
-> Maybe
     (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
lookupInputObject RemoteSchemaIntrospection
upstreamRemoteSchemaIntrospection (InputObjectTypeDefinition InputValueDefinition -> Name
forall inputType. InputObjectTypeDefinition inputType -> Name
G._iotdName InputObjectTypeDefinition InputValueDefinition
providedInputObjectTypeDefn)
            Maybe (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` GraphQLType
-> Name
-> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall {f :: * -> *} {m :: * -> *} {a}.
(MonadValidate (f RoleBasedSchemaValidationError) m,
 Applicative f) =>
GraphQLType -> Name -> m a
typeNotFound GraphQLType
InputObject (InputObjectTypeDefinition InputValueDefinition -> Name
forall inputType. InputObjectTypeDefinition inputType -> Name
G._iotdName InputObjectTypeDefinition InputValueDefinition
providedInputObjectTypeDefn)
        InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> TypeDefinition () RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
InputObjectTypeDefinition inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionInputObject
          (InputObjectTypeDefinition RemoteSchemaInputValueDefinition
 -> TypeDefinition () RemoteSchemaInputValueDefinition)
-> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (TypeDefinition () RemoteSchemaInputValueDefinition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputObjectTypeDefinition InputValueDefinition
-> InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
InputObjectTypeDefinition InputValueDefinition
-> InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
validateInputObjectTypeDefinition InputObjectTypeDefinition InputValueDefinition
providedInputObjectTypeDefn InputObjectTypeDefinition RemoteSchemaInputValueDefinition
upstreamInputObjectTypeDefn
  IntrospectionResult -> m IntrospectionResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntrospectionResult -> m IntrospectionResult)
-> IntrospectionResult -> m IntrospectionResult
forall a b. (a -> b) -> a -> b
$ [TypeDefinition () RemoteSchemaInputValueDefinition]
-> (Maybe Name, Maybe Name, Maybe Name) -> IntrospectionResult
getSchemaDocIntrospection [TypeDefinition () RemoteSchemaInputValueDefinition]
validatedTypeDefinitions (Maybe Name, Maybe Name, Maybe Name)
rootTypeNames
  where
    typeNotFound :: GraphQLType -> Name -> m a
typeNotFound GraphQLType
gType Name
name = f RoleBasedSchemaValidationError -> m a
forall a. f RoleBasedSchemaValidationError -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute (RoleBasedSchemaValidationError -> f RoleBasedSchemaValidationError
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RoleBasedSchemaValidationError
 -> f RoleBasedSchemaValidationError)
-> RoleBasedSchemaValidationError
-> f RoleBasedSchemaValidationError
forall a b. (a -> b) -> a -> b
$ GraphQLType -> Name -> RoleBasedSchemaValidationError
TypeDoesNotExist GraphQLType
gType Name
name)

resolveRoleBasedRemoteSchema ::
  (MonadError QErr m) =>
  RoleName ->
  RemoteSchemaName ->
  IntrospectionResult ->
  G.SchemaDocument ->
  m (IntrospectionResult, SchemaDependency)
resolveRoleBasedRemoteSchema :: forall (m :: * -> *).
MonadError QErr m =>
RoleName
-> RemoteSchemaName
-> IntrospectionResult
-> SchemaDocument
-> m (IntrospectionResult, SchemaDependency)
resolveRoleBasedRemoteSchema RoleName
roleName RemoteSchemaName
remoteSchemaName IntrospectionResult
remoteSchemaIntrospection (G.SchemaDocument [TypeSystemDefinition]
providedTypeDefns) = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RoleName
roleName RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
== RoleName
adminRoleName) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ConstraintViolation (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"cannot define permission for admin role"
  let providedSchemaDocWithDefaultScalars :: SchemaDocument
providedSchemaDocWithDefaultScalars =
        [TypeSystemDefinition] -> SchemaDocument
G.SchemaDocument
          ([TypeSystemDefinition] -> SchemaDocument)
-> [TypeSystemDefinition] -> SchemaDocument
forall a b. (a -> b) -> a -> b
$ [TypeSystemDefinition]
providedTypeDefns
          [TypeSystemDefinition]
-> [TypeSystemDefinition] -> [TypeSystemDefinition]
forall a. Semigroup a => a -> a -> a
<> ((ScalarTypeDefinition -> TypeSystemDefinition)
-> [ScalarTypeDefinition] -> [TypeSystemDefinition]
forall a b. (a -> b) -> [a] -> [b]
map (TypeDefinition () InputValueDefinition -> TypeSystemDefinition
G.TypeSystemDefinitionType (TypeDefinition () InputValueDefinition -> TypeSystemDefinition)
-> (ScalarTypeDefinition -> TypeDefinition () InputValueDefinition)
-> ScalarTypeDefinition
-> TypeSystemDefinition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScalarTypeDefinition -> TypeDefinition () InputValueDefinition
forall possibleTypes inputType.
ScalarTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionScalar) [ScalarTypeDefinition]
defaultScalars)
  IntrospectionResult
introspectionRes <-
    (Either [RoleBasedSchemaValidationError] IntrospectionResult
 -> ([RoleBasedSchemaValidationError] -> m IntrospectionResult)
 -> m IntrospectionResult)
-> ([RoleBasedSchemaValidationError] -> m IntrospectionResult)
-> Either [RoleBasedSchemaValidationError] IntrospectionResult
-> m IntrospectionResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip Either [RoleBasedSchemaValidationError] IntrospectionResult
-> ([RoleBasedSchemaValidationError] -> m IntrospectionResult)
-> m IntrospectionResult
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft (Code -> Text -> m IntrospectionResult
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed (Text -> m IntrospectionResult)
-> ([RoleBasedSchemaValidationError] -> Text)
-> [RoleBasedSchemaValidationError]
-> m IntrospectionResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RoleBasedSchemaValidationError] -> Text
showErrors)
      (Either [RoleBasedSchemaValidationError] IntrospectionResult
 -> m IntrospectionResult)
-> m (Either [RoleBasedSchemaValidationError] IntrospectionResult)
-> m IntrospectionResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ValidateT [RoleBasedSchemaValidationError] m IntrospectionResult
-> m (Either [RoleBasedSchemaValidationError] IntrospectionResult)
forall e (m :: * -> *) a.
Functor m =>
ValidateT e m a -> m (Either e a)
runValidateT
        ( (ReaderT
   SchemaDocument
   (ValidateT [RoleBasedSchemaValidationError] m)
   IntrospectionResult
 -> SchemaDocument
 -> ValidateT
      [RoleBasedSchemaValidationError] m IntrospectionResult)
-> SchemaDocument
-> ReaderT
     SchemaDocument
     (ValidateT [RoleBasedSchemaValidationError] m)
     IntrospectionResult
-> ValidateT [RoleBasedSchemaValidationError] m IntrospectionResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  SchemaDocument
  (ValidateT [RoleBasedSchemaValidationError] m)
  IntrospectionResult
-> SchemaDocument
-> ValidateT [RoleBasedSchemaValidationError] m IntrospectionResult
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT SchemaDocument
providedSchemaDocWithDefaultScalars
            (ReaderT
   SchemaDocument
   (ValidateT [RoleBasedSchemaValidationError] m)
   IntrospectionResult
 -> ValidateT
      [RoleBasedSchemaValidationError] m IntrospectionResult)
-> ReaderT
     SchemaDocument
     (ValidateT [RoleBasedSchemaValidationError] m)
     IntrospectionResult
-> ValidateT [RoleBasedSchemaValidationError] m IntrospectionResult
forall a b. (a -> b) -> a -> b
$ RemoteSchemaIntrospection
-> ReaderT
     SchemaDocument
     (ValidateT [RoleBasedSchemaValidationError] m)
     IntrospectionResult
forall (m :: * -> *).
(MonadValidate [RoleBasedSchemaValidationError] m,
 MonadReader SchemaDocument m) =>
RemoteSchemaIntrospection -> m IntrospectionResult
validateRemoteSchema
            (RemoteSchemaIntrospection
 -> ReaderT
      SchemaDocument
      (ValidateT [RoleBasedSchemaValidationError] m)
      IntrospectionResult)
-> RemoteSchemaIntrospection
-> ReaderT
     SchemaDocument
     (ValidateT [RoleBasedSchemaValidationError] m)
     IntrospectionResult
forall a b. (a -> b) -> a -> b
$ IntrospectionResult -> RemoteSchemaIntrospection
irDoc IntrospectionResult
remoteSchemaIntrospection
        )
  (IntrospectionResult, SchemaDependency)
-> m (IntrospectionResult, SchemaDependency)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntrospectionResult
introspectionRes, SchemaDependency
schemaDependency)
  where
    showErrors :: [RoleBasedSchemaValidationError] -> Text
    showErrors :: [RoleBasedSchemaValidationError] -> Text
showErrors [RoleBasedSchemaValidationError]
errors =
      Text
"validation for the given role-based schema failed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reasonsMessage
      where
        reasonsMessage :: Text
reasonsMessage = case [RoleBasedSchemaValidationError]
errors of
          [RoleBasedSchemaValidationError
singleError] -> Text
"because " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RoleBasedSchemaValidationError -> Text
showRoleBasedSchemaValidationError RoleBasedSchemaValidationError
singleError
          [RoleBasedSchemaValidationError]
_ ->
            Text
"for the following reasons:\n"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines
                ((RoleBasedSchemaValidationError -> Text)
-> [RoleBasedSchemaValidationError] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
" • " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> (RoleBasedSchemaValidationError -> Text)
-> RoleBasedSchemaValidationError
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RoleBasedSchemaValidationError -> Text
showRoleBasedSchemaValidationError) [RoleBasedSchemaValidationError]
errors)

    schemaDependency :: SchemaDependency
schemaDependency = SchemaObjId -> DependencyReason -> SchemaDependency
SchemaDependency (RemoteSchemaName -> SchemaObjId
SORemoteSchema RemoteSchemaName
remoteSchemaName) DependencyReason
DRRemoteSchema

    defaultScalars :: [ScalarTypeDefinition]
defaultScalars =
      (Name -> ScalarTypeDefinition) -> [Name] -> [ScalarTypeDefinition]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
n -> Maybe Description
-> Name -> [Directive Void] -> ScalarTypeDefinition
G.ScalarTypeDefinition Maybe Description
forall a. Maybe a
Nothing Name
n [])
        ([Name] -> [ScalarTypeDefinition])
-> (HashSet Name -> [Name])
-> HashSet Name
-> [ScalarTypeDefinition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet Name -> [Name]
forall a. HashSet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        (HashSet Name -> [ScalarTypeDefinition])
-> HashSet Name -> [ScalarTypeDefinition]
forall a b. (a -> b) -> a -> b
$ HashSet Name
GName.builtInScalars