From 4602eb1df3a713989b155f0140ff8909eb0370cf Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Mon, 28 Sep 2020 07:06:15 +0200 Subject: [PATCH] Validate arguments are defined --- CHANGELOG.md | 7 + src/Language/GraphQL.hs | 2 +- src/Language/GraphQL/Execute.hs | 4 +- src/Language/GraphQL/Execute/Transform.hs | 15 +- src/Language/GraphQL/Type.hs | 2 +- src/Language/GraphQL/Type/In.hs | 26 +-- src/Language/GraphQL/Type/Internal.hs | 63 +++--- src/Language/GraphQL/Type/Schema.hs | 27 ++- src/Language/GraphQL/Validate.hs | 200 ++++++++++++++------ src/Language/GraphQL/Validate/Rules.hs | 133 ++++++++----- src/Language/GraphQL/Validate/Validation.hs | 4 +- stack.yaml | 2 +- tests/Language/GraphQL/ExecuteSpec.hs | 8 +- tests/Language/GraphQL/ValidateSpec.hs | 38 +++- tests/Test/DirectiveSpec.hs | 3 +- tests/Test/FragmentSpec.hs | 3 +- tests/Test/RootOperationSpec.hs | 9 +- tests/Test/StarWars/QuerySpec.hs | 4 +- tests/Test/StarWars/Schema.hs | 10 +- 19 files changed, 375 insertions(+), 185 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index fa12cea..b0f4606 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,6 +23,7 @@ and this project adheres to the path without executing the query. - `Error.Error`: `path` added. It is currently always empty. - `Validate.Validation.Path` was moved to `Error`. +- `Type.Schema.Schema` gets an additional field, `Schema.directives`. ### Added - `Validate.Validation.Rule` constructors: @@ -32,6 +33,7 @@ and this project adheres to - `ArgumentsRule` - `DirectivesRule` - `VariablesRule` + - `FieldRule` - `Validate.Rules`: - `fragmentsOnCompositeTypesRule` - `fragmentSpreadTargetDefinedRule` @@ -48,10 +50,15 @@ and this project adheres to - `uniqueInputFieldNamesRule` - `fieldsOnCorrectTypeRule` - `scalarLeafsRule` + - `knownArgumentNamesRule` - `AST.Document.Field`. - `AST.Document.FragmentSpread`. - `AST.Document.InlineFragment`. - `AST.Document.Node`. +- `Type.In.Arguments`: Type alias for an argument map. +- `Type.Schema.Directive` and `Type.Schema.Directives` are directive definition + representation. +- `Type.Schema.schema`: Shortcut for creating a schema. ### Fixed - Collecting existing types from the schema considers subscriptions. diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 1f2d7ba..03ef54b 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -18,7 +18,7 @@ import Language.GraphQL.AST import Language.GraphQL.Error import Language.GraphQL.Execute import qualified Language.GraphQL.Validate as Validate -import Language.GraphQL.Type.Schema +import Language.GraphQL.Type.Schema (Schema) import Text.Megaparsec (parse) -- | If the text parses correctly as a @GraphQL@ query the query is diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 2b615f4..283e56c 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -32,8 +32,8 @@ execute :: (MonadCatch m, VariableValue a, Serialize b) -> HashMap Name a -- ^ Variable substitution function. -> Document -- @GraphQL@ document. -> m (Either (ResponseEventStream m b) (Response b)) -execute schema operationName subs document = - case Transform.document schema operationName subs document of +execute schema' operationName subs document = + case Transform.document schema' operationName subs document of Left queryError -> pure $ Right $ singleError diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index cf90dbf..d5b7a9c 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -49,14 +49,15 @@ import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type as Type import Language.GraphQL.Type.Internal import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema +import Language.GraphQL.Type.Schema (Schema) +import qualified Language.GraphQL.Type.Schema as Schema -- | Associates a fragment name with a list of 'Field's. data Replacement m = Replacement { fragments :: HashMap Full.Name (Fragment m) , fragmentDefinitions :: FragmentDefinitions , variableValues :: Type.Subs - , types :: HashMap Full.Name (Type m) + , types :: HashMap Full.Name (Schema.Type m) } type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition @@ -84,7 +85,7 @@ data Field m = Field -- | Contains the operation to be executed along with its root type. data Document m = Document - (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m) + (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m) data OperationDefinition = OperationDefinition Full.OperationType @@ -140,7 +141,7 @@ getOperation (Just operationName) operations coerceVariableValues :: Coerce.VariableValue a => forall m - . HashMap Full.Name (Type m) + . HashMap Full.Name (Schema.Type m) -> OperationDefinition -> HashMap.HashMap Full.Name a -> Either QueryError Type.Subs @@ -203,14 +204,14 @@ document schema operationName subs ast = do } case chosenOperation of OperationDefinition Full.Query _ _ _ _ -> - pure $ Document referencedTypes (query schema) + pure $ Document referencedTypes (Schema.query schema) $ operation chosenOperation replacement OperationDefinition Full.Mutation _ _ _ _ - | Just mutationType <- mutation schema -> + | Just mutationType <- Schema.mutation schema -> pure $ Document referencedTypes mutationType $ operation chosenOperation replacement OperationDefinition Full.Subscription _ _ _ _ - | Just subscriptionType <- subscription schema -> + | Just subscriptionType <- Schema.subscription schema -> pure $ Document referencedTypes subscriptionType $ operation chosenOperation replacement _ -> Left UnsupportedRootOperation diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index e84fc03..fc4f0fc 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -21,6 +21,6 @@ module Language.GraphQL.Type ) where import Language.GraphQL.Type.Definition -import Language.GraphQL.Type.Schema (Schema(..)) +import Language.GraphQL.Type.Schema (Schema(..), schema) import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs index 8b08041..59a6d59 100644 --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.hs @@ -11,6 +11,7 @@ -- with 'Language.GraphQL.Type.Out'. module Language.GraphQL.Type.In ( Argument(..) + , Arguments , InputField(..) , InputObjectType(..) , Type(..) @@ -24,10 +25,10 @@ module Language.GraphQL.Type.In import Data.HashMap.Strict (HashMap) import Data.Text (Text) import Language.GraphQL.AST.Document (Name) -import Language.GraphQL.Type.Definition +import qualified Language.GraphQL.Type.Definition as Definition -- | Single field of an 'InputObjectType'. -data InputField = InputField (Maybe Text) Type (Maybe Value) +data InputField = InputField (Maybe Text) Type (Maybe Definition.Value) -- | Input object type definition. -- @@ -45,25 +46,28 @@ instance Eq InputObjectType where -- type can wrap other wrapping or named types. Wrapping types are lists and -- Non-Null types (named types are nullable by default). data Type - = NamedScalarType ScalarType - | NamedEnumType EnumType + = NamedScalarType Definition.ScalarType + | NamedEnumType Definition.EnumType | NamedInputObjectType InputObjectType | ListType Type - | NonNullScalarType ScalarType - | NonNullEnumType EnumType + | NonNullScalarType Definition.ScalarType + | NonNullEnumType Definition.EnumType | NonNullInputObjectType InputObjectType | NonNullListType Type deriving Eq -- | Field argument definition. -data Argument = Argument (Maybe Text) Type (Maybe Value) +data Argument = Argument (Maybe Text) Type (Maybe Definition.Value) + +-- | Field argument definitions. +type Arguments = HashMap Name Argument -- | Matches either 'NamedScalarType' or 'NonNullScalarType'. -pattern ScalarBaseType :: ScalarType -> Type +pattern ScalarBaseType :: Definition.ScalarType -> Type pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType) -- | Matches either 'NamedEnumType' or 'NonNullEnumType'. -pattern EnumBaseType :: EnumType -> Type +pattern EnumBaseType :: Definition.EnumType -> Type pattern EnumBaseType enumType <- (isEnumType -> Just enumType) -- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'. @@ -76,7 +80,7 @@ pattern ListBaseType listType <- (isListType -> Just listType) {-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-} -isScalarType :: Type -> Maybe ScalarType +isScalarType :: Type -> Maybe Definition.ScalarType isScalarType (NamedScalarType inputType) = Just inputType isScalarType (NonNullScalarType inputType) = Just inputType isScalarType _ = Nothing @@ -86,7 +90,7 @@ isInputObjectType (NamedInputObjectType inputType) = Just inputType isInputObjectType (NonNullInputObjectType inputType) = Just inputType isInputObjectType _ = Nothing -isEnumType :: Type -> Maybe EnumType +isEnumType :: Type -> Maybe Definition.EnumType isEnumType (NamedEnumType inputType) = Just inputType isEnumType (NonNullEnumType inputType) = Just inputType isEnumType _ = Nothing diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 444a52d..2aea996 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -18,12 +18,12 @@ module Language.GraphQL.Type.Internal import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text) import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema +import Language.GraphQL.Type.Schema (Schema) +import qualified Language.GraphQL.Type.Schema as Schema -- | These types may describe the parent context of a selection set. data CompositeType m @@ -39,13 +39,15 @@ data AbstractType m deriving Eq -- | Traverses the schema and finds all referenced types. -collectReferencedTypes :: forall m. Schema m -> HashMap Full.Name (Type m) +collectReferencedTypes :: forall m + . Schema m + -> HashMap Full.Name (Schema.Type m) collectReferencedTypes schema = - let queryTypes = traverseObjectType (query schema) HashMap.empty + let queryTypes = traverseObjectType (Schema.query schema) HashMap.empty mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes) - $ mutation schema + $ Schema.mutation schema in maybe mutationTypes (`traverseObjectType` queryTypes) - $ subscription schema + $ Schema.subscription schema where collect traverser typeName element foundTypes | HashMap.member typeName foundTypes = foundTypes @@ -59,17 +61,17 @@ collectReferencedTypes schema = getField (Out.EventStreamResolver field _ _) = field traverseInputType (In.InputObjectBaseType objectType) = let In.InputObjectType typeName _ inputFields = objectType - element = InputObjectType objectType + element = Schema.InputObjectType objectType traverser = flip (foldr visitInputFields) inputFields in collect traverser typeName element traverseInputType (In.ListBaseType listType) = traverseInputType listType traverseInputType (In.ScalarBaseType scalarType) = let Definition.ScalarType typeName _ = scalarType - in collect Prelude.id typeName (ScalarType scalarType) + in collect Prelude.id typeName (Schema.ScalarType scalarType) traverseInputType (In.EnumBaseType enumType) = let Definition.EnumType typeName _ _ = enumType - in collect Prelude.id typeName (EnumType enumType) + in collect Prelude.id typeName (Schema.EnumType enumType) traverseOutputType (Out.ObjectBaseType objectType) = traverseObjectType objectType traverseOutputType (Out.InterfaceBaseType interfaceType) = @@ -77,23 +79,23 @@ collectReferencedTypes schema = traverseOutputType (Out.UnionBaseType unionType) = let Out.UnionType typeName _ types = unionType traverser = flip (foldr traverseObjectType) types - in collect traverser typeName (UnionType unionType) + in collect traverser typeName (Schema.UnionType unionType) traverseOutputType (Out.ListBaseType listType) = traverseOutputType listType traverseOutputType (Out.ScalarBaseType scalarType) = let Definition.ScalarType typeName _ = scalarType - in collect Prelude.id typeName (ScalarType scalarType) + in collect Prelude.id typeName (Schema.ScalarType scalarType) traverseOutputType (Out.EnumBaseType enumType) = let Definition.EnumType typeName _ _ = enumType - in collect Prelude.id typeName (EnumType enumType) + in collect Prelude.id typeName (Schema.EnumType enumType) traverseObjectType objectType foundTypes = let Out.ObjectType typeName _ interfaces fields = objectType - element = ObjectType objectType + element = Schema.ObjectType objectType traverser = polymorphicTraverser interfaces (getField <$> fields) in collect traverser typeName element foundTypes traverseInterfaceType interfaceType foundTypes = let Out.InterfaceType typeName _ interfaces fields = interfaceType - element = InterfaceType interfaceType + element = Schema.InterfaceType interfaceType traverser = polymorphicTraverser interfaces fields in collect traverser typeName element foundTypes polymorphicTraverser interfaces fields @@ -126,27 +128,28 @@ instanceOf objectType (AbstractUnionType unionType) = lookupTypeCondition :: forall m . Full.Name - -> HashMap Full.Name (Type m) + -> HashMap Full.Name (Schema.Type m) -> Maybe (CompositeType m) lookupTypeCondition type' types' = case HashMap.lookup type' types' of - Just (ObjectType objectType) -> Just $ CompositeObjectType objectType - Just (UnionType unionType) -> Just $ CompositeUnionType unionType - Just (InterfaceType interfaceType) -> + Just (Schema.ObjectType objectType) -> + Just $ CompositeObjectType objectType + Just (Schema.UnionType unionType) -> Just $ CompositeUnionType unionType + Just (Schema.InterfaceType interfaceType) -> Just $ CompositeInterfaceType interfaceType _ -> Nothing lookupInputType :: Full.Type - -> HashMap.HashMap Full.Name (Type m) + -> HashMap.HashMap Full.Name (Schema.Type m) -> Maybe In.Type lookupInputType (Full.TypeNamed name) types = case HashMap.lookup name types of - Just (ScalarType scalarType) -> + Just (Schema.ScalarType scalarType) -> Just $ In.NamedScalarType scalarType - Just (EnumType enumType) -> + Just (Schema.EnumType enumType) -> Just $ In.NamedEnumType enumType - Just (InputObjectType objectType) -> + Just (Schema.InputObjectType objectType) -> Just $ In.NamedInputObjectType objectType _ -> Nothing lookupInputType (Full.TypeList list) types @@ -154,18 +157,18 @@ lookupInputType (Full.TypeList list) types <$> lookupInputType list types lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types = case HashMap.lookup nonNull types of - Just (ScalarType scalarType) -> + Just (Schema.ScalarType scalarType) -> Just $ In.NonNullScalarType scalarType - Just (EnumType enumType) -> + Just (Schema.EnumType enumType) -> Just $ In.NonNullEnumType enumType - Just (InputObjectType objectType) -> + Just (Schema.InputObjectType objectType) -> Just $ In.NonNullInputObjectType objectType _ -> Nothing lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types = In.NonNullListType <$> lookupInputType nonNull types -lookupTypeField :: forall a. Text -> Out.Type a -> Maybe (Out.Type a) +lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a) lookupTypeField fieldName = \case Out.ObjectBaseType objectType -> objectChild objectType @@ -177,8 +180,6 @@ lookupTypeField fieldName = \case objectChild (Out.ObjectType _ _ _ resolvers) = resolverType <$> HashMap.lookup fieldName resolvers interfaceChild (Out.InterfaceType _ _ _ fields) = - fieldType <$> HashMap.lookup fieldName fields - resolverType (Out.ValueResolver objectField _) = fieldType objectField - resolverType (Out.EventStreamResolver objectField _ _) = - fieldType objectField - fieldType (Out.Field _ type' _) = type' + HashMap.lookup fieldName fields + resolverType (Out.ValueResolver objectField _) = objectField + resolverType (Out.EventStreamResolver objectField _ _) = objectField diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 581d9b2..6562fb5 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -2,13 +2,22 @@ v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. -} +{-# LANGUAGE ExplicitForAll #-} + -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Type.Schema - ( Schema(..) + ( Directive(..) + , Directives + , Schema(..) , Type(..) + , schema ) where +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import qualified Language.GraphQL.AST.Document as Full +import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation) import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out @@ -23,6 +32,12 @@ data Type m | UnionType (Out.UnionType m) deriving Eq +-- | Directive definition. +data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments + +-- | Directive definitions. +type Directives = HashMap Full.Name Directive + -- | A Schema is created by supplying the root types of each type of operation, -- query and mutation (optional). A schema definition is then supplied to the -- validator and executor. @@ -34,4 +49,14 @@ data Schema m = Schema { query :: Out.ObjectType m , mutation :: Maybe (Out.ObjectType m) , subscription :: Maybe (Out.ObjectType m) + , directives :: Directives + } + +-- | Shortcut for creating a schema. +schema :: forall m. Out.ObjectType m -> Schema m +schema query' = Schema + { query = query' + , mutation = Nothing + , subscription = Nothing + , directives = mempty } diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 0fa04cb..eedad6c 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -3,11 +3,12 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | GraphQL validator. module Language.GraphQL.Validate - ( Error(..) + ( Validation.Error(..) , document , module Language.GraphQL.Validate.Rules ) where @@ -20,38 +21,100 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Sequence (Seq(..), (><), (|>)) import qualified Data.Sequence as Seq +import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) +import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation import Language.GraphQL.AST.Document import Language.GraphQL.Type.Internal +import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema (Schema(..)) +import Language.GraphQL.Type.Schema (Schema) import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Validate.Rules -import Language.GraphQL.Validate.Validation +import Language.GraphQL.Validate.Validation (Validation(Validation)) +import qualified Language.GraphQL.Validate.Validation as Validation -type ApplyRule m a = - HashMap Name (Schema.Type m) -> Rule m -> Maybe (Out.Type m) -> a -> Seq (RuleT m) +type ApplySelectionRule m a + = HashMap Name (Schema.Type m) + -> Validation.Rule m + -> Maybe (Out.Type m) + -> a + -> Seq (Validation.RuleT m) + +type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.RuleT m) -- | Validates a document and returns a list of found errors. If the returned -- list is empty, the document is valid. -document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error +document :: forall m + . Schema m + -> [Validation.Rule m] + -> Document + -> Seq Validation.Error document schema' rules' document' = runReaderT reader context where context = Validation - { ast = document' - , schema = schema' - , types = collectReferencedTypes schema' + { Validation.ast = document' + , Validation.schema = schema' + , Validation.types = collectReferencedTypes schema' + , Validation.directives = allDirectives } + allDirectives = + HashMap.union (Schema.directives schema') defaultDirectives + defaultDirectives = HashMap.fromList + [ ("skip", skipDirective) + , ("include", includeDirective) + , ("deprecated", deprecatedDirective) + ] + includeDirective = + Schema.Directive includeDescription skipIncludeLocations includeArguments + includeArguments = HashMap.singleton "if" + $ In.Argument (Just "Included when true.") ifType Nothing + includeDescription = Just + "Directs the executor to include this field or fragment only when the \ + \`if` argument is true." + skipDirective = + Schema.Directive skipDescription skipIncludeLocations skipArguments + skipArguments = HashMap.singleton "if" + $ In.Argument (Just "skipped when true.") ifType Nothing + ifType = In.NonNullScalarType Definition.boolean + skipDescription = Just + "Directs the executor to skip this field or fragment when the `if` \ + \argument is true." + skipIncludeLocations = + [ ExecutableDirectiveLocation DirectiveLocation.Field + , ExecutableDirectiveLocation DirectiveLocation.FragmentSpread + , ExecutableDirectiveLocation DirectiveLocation.InlineFragment + ] + deprecatedDirective = + Schema.Directive deprecatedDescription deprecatedLocations deprecatedArguments + reasonDescription = Just + "Explains why this element was deprecated, usually also including a \ + \suggestion for how to access supported similar data. Formatted using \ + \the Markdown syntax, as specified by \ + \[CommonMark](https://commonmark.org/).'" + deprecatedArguments = HashMap.singleton "reason" + $ In.Argument reasonDescription reasonType + $ Just "No longer supported" + reasonType = In.NamedScalarType Definition.string + deprecatedDescription = Just + "Marks an element of a GraphQL schema as no longer supported." + deprecatedLocations = + [ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition + , TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition + , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition + , TypeSystemDirectiveLocation DirectiveLocation.EnumValue + ] reader = do rule' <- lift $ Seq.fromList rules' join $ lift $ foldr (definition rule' context) Seq.empty document' -definition :: Rule m +definition :: Validation.Rule m -> Validation m -> Definition - -> Seq (RuleT m) - -> Seq (RuleT m) -definition (DefinitionRule rule) _ definition' accumulator = + -> Seq (Validation.RuleT m) + -> Seq (Validation.RuleT m) +definition (Validation.DefinitionRule rule) _ definition' accumulator = accumulator |> rule definition' definition rule context (ExecutableDefinition definition') accumulator = accumulator >< executableDefinition rule context definition' @@ -60,12 +123,12 @@ definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator = definition rule _ (TypeSystemExtension extension _) accumulator = accumulator >< typeSystemExtension rule extension -typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m) +typeSystemExtension :: forall m. ApplyRule m TypeSystemExtension typeSystemExtension rule = \case SchemaExtension extension -> schemaExtension rule extension TypeExtension extension -> typeExtension rule extension -typeExtension :: Rule m -> TypeExtension -> Seq (RuleT m) +typeExtension :: forall m. ApplyRule m TypeExtension typeExtension rule = \case ScalarTypeExtension _ directives' -> directives rule directives' ObjectTypeFieldsDefinitionExtension _ _ directives' fields -> @@ -88,27 +151,28 @@ typeExtension rule = \case InputObjectTypeDirectivesExtension _ directives' -> directives rule directives' -schemaExtension :: Rule m -> SchemaExtension -> Seq (RuleT m) +schemaExtension :: forall m. ApplyRule m SchemaExtension schemaExtension rule = \case SchemaOperationExtension directives' _ -> directives rule directives' SchemaDirectivesExtension directives' -> directives rule directives' -executableDefinition :: Rule m +executableDefinition :: forall m + . Validation.Rule m -> Validation m -> ExecutableDefinition - -> Seq (RuleT m) + -> Seq (Validation.RuleT m) executableDefinition rule context (DefinitionOperation operation) = operationDefinition rule context operation executableDefinition rule context (DefinitionFragment fragment) = fragmentDefinition rule context fragment -typeSystemDefinition :: Rule m -> TypeSystemDefinition -> Seq (RuleT m) +typeSystemDefinition :: forall m. ApplyRule m TypeSystemDefinition typeSystemDefinition rule = \case SchemaDefinition directives' _ -> directives rule directives' TypeDefinition typeDefinition' -> typeDefinition rule typeDefinition' DirectiveDefinition _ _ arguments' _ -> argumentsDefinition rule arguments' -typeDefinition :: Rule m -> TypeDefinition -> Seq (RuleT m) +typeDefinition :: forall m. ApplyRule m TypeDefinition typeDefinition rule = \case ScalarTypeDefinition _ _ directives' -> directives rule directives' ObjectTypeDefinition _ _ _ directives' fields -> @@ -122,30 +186,31 @@ typeDefinition rule = \case -> directives rule directives' <> foldMap (inputValueDefinition rule) fields -enumValueDefinition :: Rule m -> EnumValueDefinition -> Seq (RuleT m) +enumValueDefinition :: forall m. ApplyRule m EnumValueDefinition enumValueDefinition rule (EnumValueDefinition _ _ directives') = directives rule directives' -fieldDefinition :: Rule m -> FieldDefinition -> Seq (RuleT m) +fieldDefinition :: forall m. ApplyRule m FieldDefinition fieldDefinition rule (FieldDefinition _ _ arguments' _ directives') = directives rule directives' >< argumentsDefinition rule arguments' -argumentsDefinition :: Rule m -> ArgumentsDefinition -> Seq (RuleT m) +argumentsDefinition :: forall m. ApplyRule m ArgumentsDefinition argumentsDefinition rule (ArgumentsDefinition definitions) = foldMap (inputValueDefinition rule) definitions -inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m) +inputValueDefinition :: forall m. ApplyRule m InputValueDefinition inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') = directives rule directives' -operationDefinition :: Rule m +operationDefinition :: forall m + . Validation.Rule m -> Validation m -> OperationDefinition - -> Seq (RuleT m) + -> Seq (Validation.RuleT m) operationDefinition rule context operation - | OperationDefinitionRule operationRule <- rule = + | Validation.OperationDefinitionRule operationRule <- rule = pure $ operationRule operation - | VariablesRule variablesRule <- rule + | Validation.VariablesRule variablesRule <- rule , OperationDefinition _ _ variables _ _ _ <- operation = Seq.fromList (variableDefinition rule <$> variables) |> variablesRule variables @@ -155,11 +220,13 @@ operationDefinition rule context operation = selectionSet types' rule (getRootType operationType) selections >< directives rule directives' where - types' = types context - getRootType Query = Just $ Out.NamedObjectType $ query $ schema context - getRootType Mutation = Out.NamedObjectType <$> mutation (schema context) + types' = Validation.types context + getRootType Query = + Just $ Out.NamedObjectType $ Schema.query $ Validation.schema context + getRootType Mutation = + Out.NamedObjectType <$> Schema.mutation (Validation.schema context) getRootType Subscription = - Out.NamedObjectType <$> subscription (schema context) + Out.NamedObjectType <$> Schema.subscription (Validation.schema context) typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m) typeToOut (Schema.ObjectType objectType) = @@ -171,27 +238,30 @@ typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType typeToOut _ = Nothing -variableDefinition :: Rule m -> VariableDefinition -> RuleT m -variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) = +variableDefinition :: forall m + . Validation.Rule m + -> VariableDefinition + -> Validation.RuleT m +variableDefinition (Validation.ValueRule _ rule) (VariableDefinition _ _ value _) = maybe (lift mempty) rule value variableDefinition _ _ = lift mempty fragmentDefinition :: forall m - . Rule m + . Validation.Rule m -> Validation m -> FragmentDefinition - -> Seq (RuleT m) -fragmentDefinition (FragmentDefinitionRule rule) _ definition' = + -> Seq (Validation.RuleT m) +fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' = pure $ rule definition' fragmentDefinition rule context definition' | FragmentDefinition _ typeCondition directives' selections _ <- definition' - , FragmentRule definitionRule _ <- rule + , Validation.FragmentRule definitionRule _ <- rule = applyToChildren typeCondition directives' selections |> definitionRule definition' | FragmentDefinition _ typeCondition directives' selections _ <- definition' = applyToChildren typeCondition directives' selections where - types' = types context + types' = Validation.types context applyToChildren typeCondition directives' selections = selectionSet types' rule (lookupType' typeCondition) selections >< directives rule directives' @@ -204,12 +274,12 @@ lookupType :: forall m lookupType typeCondition types' = HashMap.lookup typeCondition types' >>= typeToOut -selectionSet :: Traversable t => forall m. ApplyRule m (t Selection) +selectionSet :: Traversable t => forall m. ApplySelectionRule m (t Selection) selectionSet types' rule = foldMap . selection types' rule -selection :: forall m. ApplyRule m Selection +selection :: forall m. ApplySelectionRule m Selection selection types' rule objectType selection' - | SelectionRule selectionRule <- rule = + | Validation.SelectionRule selectionRule <- rule = applyToChildren |> selectionRule objectType selection' | otherwise = applyToChildren where @@ -221,33 +291,37 @@ selection types' rule objectType selection' FragmentSpreadSelection fragmentSpread' -> fragmentSpread rule fragmentSpread' -field :: forall m. ApplyRule m Field +field :: forall m. ApplySelectionRule m Field field types' rule objectType field' = go field' where - go (Field _ fieldName arguments' directives' selections _) - | ArgumentsRule fieldRule _ <- rule - = applyToChildren fieldName arguments' directives' selections - |> fieldRule field' - | otherwise = - applyToChildren fieldName arguments' directives' selections - applyToChildren fieldName arguments' directives' selections = - let child = objectType >>= lookupTypeField fieldName - in selectionSet types' rule child selections + go (Field _ fieldName _ _ _ _) + | Validation.FieldRule fieldRule <- rule = + applyToChildren fieldName |> fieldRule objectType field' + | Validation.ArgumentsRule argumentsRule _ <- rule = + applyToChildren fieldName |> argumentsRule objectType field' + | otherwise = applyToChildren fieldName + typeFieldType (Out.Field _ type' _) = type' + applyToChildren fieldName = + let Field _ _ arguments' directives' selections _ = field' + fieldType = objectType + >>= fmap typeFieldType . lookupTypeField fieldName + in selectionSet types' rule fieldType selections >< directives rule directives' >< arguments rule arguments' -arguments :: Rule m -> [Argument] -> Seq (RuleT m) +arguments :: forall m. ApplyRule m [Argument] arguments = (.) Seq.fromList . fmap . argument -argument :: Rule m -> Argument -> RuleT m -argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value +argument :: forall m. Validation.Rule m -> Argument -> Validation.RuleT m +argument (Validation.ValueRule rule _) (Argument _ (Node value _) _) = + rule value argument _ _ = lift mempty -inlineFragment :: forall m. ApplyRule m InlineFragment +inlineFragment :: forall m. ApplySelectionRule m InlineFragment inlineFragment types' rule objectType inlineFragment' = go inlineFragment' where go (InlineFragment optionalType directives' selections _) - | FragmentRule _ fragmentRule <- rule + | Validation.FragmentRule _ fragmentRule <- rule = applyToChildren (refineTarget optionalType) directives' selections |> fragmentRule inlineFragment' | otherwise = applyToChildren (refineTarget optionalType) directives' selections @@ -257,24 +331,24 @@ inlineFragment types' rule objectType inlineFragment' = go inlineFragment' = selectionSet types' rule objectType' selections >< directives rule directives' -fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m) +fragmentSpread :: forall m. ApplyRule m FragmentSpread fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _) - | FragmentSpreadRule fragmentRule <- rule = + | Validation.FragmentSpreadRule fragmentRule <- rule = applyToChildren |> fragmentRule fragmentSpread' | otherwise = applyToChildren where applyToChildren = directives rule directives' -directives :: Traversable t => Rule m -> t Directive -> Seq (RuleT m) +directives :: Traversable t => forall m. ApplyRule m (t Directive) directives rule directives' - | DirectivesRule directivesRule <- rule = + | Validation.DirectivesRule directivesRule <- rule = applyToChildren |> directivesRule directiveList | otherwise = applyToChildren where directiveList = toList directives' applyToChildren = foldMap (directive rule) directiveList -directive :: Rule m -> Directive -> Seq (RuleT m) -directive (ArgumentsRule _ argumentsRule) directive' = +directive :: forall m. ApplyRule m Directive +directive (Validation.ArgumentsRule _ argumentsRule) directive' = pure $ argumentsRule directive' directive rule (Directive _ arguments' _) = arguments rule arguments' diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index eb6d632..bd0b4ed 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -15,6 +15,7 @@ module Language.GraphQL.Validate.Rules , fragmentSpreadTargetDefinedRule , fragmentSpreadTypeExistenceRule , loneAnonymousOperationRule + , knownArgumentNamesRule , noFragmentCyclesRule , noUndefinedVariablesRule , noUnusedFragmentsRule @@ -44,7 +45,7 @@ import qualified Data.HashSet as HashSet import Data.List (groupBy, sortBy, sortOn) import Data.Maybe (mapMaybe) import Data.Ord (comparing) -import Data.Sequence (Seq(..)) +import Data.Sequence (Seq(..), (|>)) import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as Text @@ -71,6 +72,7 @@ specifiedRules = , fieldsOnCorrectTypeRule , scalarLeafsRule -- Arguments. + , knownArgumentNamesRule , uniqueArgumentNamesRule -- Fragments. , uniqueFragmentNamesRule @@ -134,20 +136,20 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case forSpread accumulator fragmentSelection InlineFragmentSelection fragmentSelection -> forInline accumulator fragmentSelection - forField accumulator (Field alias name _ directives _ _) - | any skip directives = pure accumulator + forField accumulator (Field alias name _ directives' _ _) + | any skip directives' = pure accumulator | Just aliasedName <- alias = pure $ HashSet.insert aliasedName accumulator | otherwise = pure $ HashSet.insert name accumulator - forSpread accumulator (FragmentSpread fragmentName directives _) - | any skip directives = pure accumulator + forSpread accumulator (FragmentSpread fragmentName directives' _) + | any skip directives' = pure accumulator | otherwise = do inVisitetFragments <- gets $ HashSet.member fragmentName if inVisitetFragments then pure accumulator else collectFromSpread fragmentName accumulator - forInline accumulator (InlineFragment maybeType directives selections _) - | any skip directives = pure accumulator + forInline accumulator (InlineFragment maybeType directives' selections _) + | any skip directives' = pure accumulator | Just typeCondition <- maybeType = collectFromFragment typeCondition selections accumulator | otherwise = HashSet.union accumulator @@ -494,7 +496,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case uniqueArgumentNamesRule :: forall m. Rule m uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule where - fieldRule (Field _ _ arguments _ _ _) = + fieldRule _ (Field _ _ arguments _ _ _) = lift $ filterDuplicates extract "argument" arguments directiveRule (Directive _ arguments _) = lift $ filterDuplicates extract "argument" arguments @@ -519,9 +521,9 @@ filterDuplicates extract nodeType = Seq.fromList where getName = fst . extract equalByName lhs rhs = getName lhs == getName rhs - makeError directives = Error - { message = makeMessage $ head directives - , locations = snd . extract <$> directives + makeError directives' = Error + { message = makeMessage $ head directives' + , locations = snd . extract <$> directives' } makeMessage directive = concat [ "There can be only one " @@ -614,11 +616,11 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas filterSelections' = filterSelections variableFilter variableFilter :: Selection -> ValidationState m (Name, [Location]) variableFilter (InlineFragmentSelection inline) - | InlineFragment _ directives _ _ <- inline = - lift $ lift $ mapDirectives directives + | InlineFragment _ directives' _ _ <- inline = + lift $ lift $ mapDirectives directives' variableFilter (FieldSelection fieldSelection) - | Field _ _ arguments directives _ _ <- fieldSelection = - lift $ lift $ mapArguments arguments <> mapDirectives directives + | Field _ _ arguments directives' _ _ <- fieldSelection = + lift $ lift $ mapArguments arguments <> mapDirectives directives' variableFilter (FragmentSpreadSelection spread) | FragmentSpread fragmentName _ _ <- spread = do definitions <- lift $ asks ast @@ -628,9 +630,9 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas Just (viewFragment -> Just fragmentDefinition) | not visited -> diveIntoSpread fragmentDefinition _ -> lift $ lift mempty - diveIntoSpread (FragmentDefinition _ _ directives selections _) + diveIntoSpread (FragmentDefinition _ _ directives' selections _) = filterSelections' selections - >>= lift . mapReaderT (<> mapDirectives directives) . pure + >>= lift . mapReaderT (<> mapDirectives directives') . pure findDirectiveVariables (Directive _ arguments _) = mapArguments arguments mapArguments = Seq.fromList . mapMaybe findArgumentVariables mapDirectives = foldMap findDirectiveVariables @@ -683,13 +685,11 @@ uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo) -- | The target field of a field selection must be defined on the scoped type of -- the selection set. There are no limitations on alias names. fieldsOnCorrectTypeRule :: forall m. Rule m -fieldsOnCorrectTypeRule = SelectionRule go +fieldsOnCorrectTypeRule = FieldRule fieldRule where - go (Just objectType) (FieldSelection fieldSelection) = - fieldRule objectType fieldSelection - go _ _ = lift mempty - fieldRule objectType (Field _ fieldName _ _ _ location) - | Nothing <- lookupTypeField fieldName objectType + fieldRule parentType (Field _ fieldName _ _ _ location) + | Just objectType <- parentType + , Nothing <- lookupTypeField fieldName objectType , Just typeName <- compositeTypeName objectType = pure $ Error { message = errorMessage fieldName typeName , locations = [location] @@ -702,31 +702,32 @@ fieldsOnCorrectTypeRule = SelectionRule go , Text.unpack typeName , "\"." ] - compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = - Just typeName - compositeTypeName (Out.InterfaceBaseType interfaceType) = - let Out.InterfaceType typeName _ _ _ = interfaceType - in Just typeName - compositeTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) = - Just typeName - compositeTypeName (Out.ScalarBaseType _) = - Nothing - compositeTypeName (Out.EnumBaseType _) = - Nothing - compositeTypeName (Out.ListBaseType wrappedType) = - compositeTypeName wrappedType + +compositeTypeName :: forall m. Out.Type m -> Maybe Name +compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = + Just typeName +compositeTypeName (Out.InterfaceBaseType interfaceType) = + let Out.InterfaceType typeName _ _ _ = interfaceType + in Just typeName +compositeTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) = + Just typeName +compositeTypeName (Out.ScalarBaseType _) = + Nothing +compositeTypeName (Out.EnumBaseType _) = + Nothing +compositeTypeName (Out.ListBaseType wrappedType) = + compositeTypeName wrappedType -- | Field selections on scalars or enums are never allowed, because they are -- the leaf nodes of any GraphQL query. scalarLeafsRule :: forall m. Rule m -scalarLeafsRule = SelectionRule go +scalarLeafsRule = FieldRule fieldRule where - go (Just objectType) (FieldSelection fieldSelection) = - fieldRule objectType fieldSelection - go _ _ = lift mempty - fieldRule objectType selectionField@(Field _ fieldName _ _ _ _) - | Just fieldType <- lookupTypeField fieldName objectType = - lift $ check fieldType selectionField + fieldRule parentType selectionField@(Field _ fieldName _ _ _ _) + | Just objectType <- parentType + , Just field <- lookupTypeField fieldName objectType = + let Out.Field _ fieldType _ = field + in lift $ check fieldType selectionField | otherwise = lift mempty check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = checkNotEmpty typeName @@ -765,3 +766,49 @@ scalarLeafsRule = SelectionRule go { message = errorMessage , locations = [location] } + +-- | Every argument provided to a field or directive must be defined in the set +-- of possible arguments of that field or directive. +knownArgumentNamesRule :: forall m. Rule m +knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule + where + fieldRule (Just objectType) (Field _ fieldName arguments _ _ _) + | Just typeField <- lookupTypeField fieldName objectType + , Just typeName <- compositeTypeName objectType = + lift $ foldr (go typeName fieldName typeField) Seq.empty arguments + fieldRule _ _ = lift mempty + go typeName fieldName fieldDefinition (Argument argumentName _ location) errors + | Out.Field _ _ definitions <- fieldDefinition + , Just _ <- HashMap.lookup argumentName definitions = errors + | otherwise = errors |> Error + { message = fieldMessage argumentName fieldName typeName + , locations = [location] + } + fieldMessage argumentName fieldName typeName = concat + [ "Unknown argument \"" + , Text.unpack argumentName + , "\" on field \"" + , Text.unpack typeName + , "." + , Text.unpack fieldName + , "\"." + ] + directiveRule (Directive directiveName arguments _) = do + available <- asks $ HashMap.lookup directiveName . directives + Argument argumentName _ location <- lift $ Seq.fromList arguments + case available of + Just (Schema.Directive _ _ definitions) + | not $ HashMap.member argumentName definitions -> + pure $ makeError argumentName directiveName location + _ -> lift mempty + makeError argumentName directiveName location = Error + { message = directiveMessage argumentName directiveName + , locations = [location] + } + directiveMessage argumentName directiveName = concat + [ "Unknown argument \"" + , Text.unpack argumentName + , "\" on directive \"@" + , Text.unpack directiveName + , "\"." + ] diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index 6c2654a..ae39e58 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -29,6 +29,7 @@ data Validation m = Validation { ast :: Document , schema :: Schema m , types :: HashMap Name (Schema.Type m) + , directives :: Schema.Directives } -- | 'Rule' assigns a function to each AST node that can be validated. If the @@ -41,7 +42,8 @@ data Rule m | SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m) | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m) | FragmentSpreadRule (FragmentSpread -> RuleT m) - | ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m) + | FieldRule (Maybe (Out.Type m) -> Field -> RuleT m) + | ArgumentsRule (Maybe (Out.Type m) -> Field -> RuleT m) (Directive -> RuleT m) | DirectivesRule ([Directive] -> RuleT m) | VariablesRule ([VariableDefinition] -> RuleT m) | ValueRule (Value -> RuleT m) (ConstValue -> RuleT m) diff --git a/stack.yaml b/stack.yaml index 34c7e27..9a89c01 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.15 +resolver: lts-16.16 packages: - . diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 7b67824..e6dd8d9 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -25,11 +25,12 @@ import Test.Hspec (Spec, context, describe, it, shouldBe) import Text.Megaparsec (parse) import Text.RawString.QQ (r) -schema :: Schema (Either SomeException) -schema = Schema +philosopherSchema :: Schema (Either SomeException) +philosopherSchema = Schema { query = queryType , mutation = Nothing , subscription = Just subscriptionType + , directives = HashMap.empty } queryType :: Out.ObjectType (Either SomeException) @@ -79,7 +80,8 @@ type EitherStreamOrValue = Either (Response Aeson.Value) execute' :: Document -> Either SomeException EitherStreamOrValue -execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) +execute' = + execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value) spec :: Spec spec = diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index 1649ad1..84bdfba 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -21,11 +21,12 @@ import Test.Hspec (Spec, describe, it, shouldBe, shouldContain) import Text.Megaparsec (parse) import Text.RawString.QQ (r) -schema :: Schema IO -schema = Schema +petSchema :: Schema IO +petSchema = Schema { query = queryType , mutation = Nothing , subscription = Just subscriptionType + , directives = HashMap.empty } queryType :: ObjectType IO @@ -132,7 +133,7 @@ validate :: Text -> [Error] validate queryString = case parse AST.document "" queryString of Left _ -> [] - Right ast -> toList $ document schema specifiedRules ast + Right ast -> toList $ document petSchema specifiedRules ast spec :: Spec spec = @@ -544,3 +545,34 @@ spec = , locations = [AST.Location 4 19] } in validate queryString `shouldBe` [expected] + + it "rejects field arguments missing in the type" $ + let queryString = [r| + { + dog { + doesKnowCommand(command: CLEAN_UP_HOUSE) + } + } + |] + expected = Error + { message = + "Unknown argument \"command\" on field \ + \\"Dog.doesKnowCommand\"." + , locations = [AST.Location 4 35] + } + in validate queryString `shouldBe` [expected] + + it "rejects directive arguments missing in the definition" $ + let queryString = [r| + { + dog { + isHousetrained(atOtherHomes: true) @include(unless: false) + } + } + |] + expected = Error + { message = + "Unknown argument \"unless\" on directive \"@include\"." + , locations = [AST.Location 4 63] + } + in validate queryString `shouldBe` [expected] diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 800189e..c115163 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -19,8 +19,7 @@ import Test.Hspec.GraphQL import Text.RawString.QQ (r) experimentalResolver :: Schema IO -experimentalResolver = Schema - { query = queryType, mutation = Nothing, subscription = Nothing } +experimentalResolver = schema queryType where queryType = Out.ObjectType "Query" Nothing [] $ HashMap.singleton "experimentalField" diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 8ee1ad2..4fecad8 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -67,8 +67,7 @@ sizeFieldType $ pure $ snd size toSchema :: Text -> (Text, Value) -> Schema IO -toSchema t (_, resolve) = Schema - { query = queryType, mutation = Nothing, subscription = Nothing } +toSchema t (_, resolve) = schema queryType where garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType] typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index ea89279..33b5d3b 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -23,11 +23,12 @@ hatType = Out.ObjectType "Hat" Nothing [] $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty) $ pure $ Int 60 -schema :: Schema IO -schema = Schema +garmentSchema :: Schema IO +garmentSchema = Schema { query = Out.ObjectType "Query" Nothing [] hatFieldResolver , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver , subscription = Nothing + , directives = HashMap.empty } where garment = pure $ Object $ HashMap.fromList @@ -57,7 +58,7 @@ spec = [ "circumference" .= (60 :: Int) ] ] - actual <- graphql schema querySource + actual <- graphql garmentSchema querySource actual `shouldResolveTo` expected it "chooses Mutation" $ do @@ -70,5 +71,5 @@ spec = $ object [ "incrementCircumference" .= (61 :: Int) ] - actual <- graphql schema querySource + actual <- graphql garmentSchema querySource actual `shouldResolveTo` expected diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs index 8d744ab..f9b13d9 100644 --- a/tests/Test/StarWars/QuerySpec.hs +++ b/tests/Test/StarWars/QuerySpec.hs @@ -357,10 +357,10 @@ spec = describe "Star Wars Query Tests" $ do testQuery :: Text -> Aeson.Value -> Expectation testQuery q expected = - let Right (Right actual) = graphql schema q + let Right (Right actual) = graphql starWarsSchema q in Aeson.Object actual `shouldBe` expected testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation testQueryParams f q expected = - let Right (Right actual) = graphqlSubs schema Nothing f q + let Right (Right actual) = graphqlSubs starWarsSchema Nothing f q in Aeson.Object actual `shouldBe` expected diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 34a6a35..706d9b3 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.StarWars.Schema - ( schema + ( starWarsSchema ) where import Control.Monad.Catch (MonadThrow(..), SomeException) @@ -17,12 +17,8 @@ import Prelude hiding (id) -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -schema :: Schema (Either SomeException) -schema = Schema - { query = queryType - , mutation = Nothing - , subscription = Nothing - } +starWarsSchema :: Schema (Either SomeException) +starWarsSchema = schema queryType where queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList [ ("hero", heroFieldResolver)