From 56b63f1c3eda70e6de5da4b6395b98a378b1e4e7 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 30 Sep 2020 05:14:52 +0200 Subject: [PATCH] Validate input object field names --- src/Language/GraphQL/AST/Document.hs | 12 +- src/Language/GraphQL/AST/Encoder.hs | 181 +++++----- src/Language/GraphQL/AST/Parser.hs | 303 ++++++++-------- src/Language/GraphQL/Execute/Transform.hs | 2 +- src/Language/GraphQL/Validate.hs | 375 +++++++++++++------- src/Language/GraphQL/Validate/Rules.hs | 161 +++++---- src/Language/GraphQL/Validate/Validation.hs | 3 +- tests/Language/GraphQL/AST/EncoderSpec.hs | 65 ++-- tests/Language/GraphQL/ValidateSpec.hs | 16 + 9 files changed, 640 insertions(+), 478 deletions(-) diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index c870580..0b118af 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} -- | This module defines an abstract syntax tree for the @GraphQL@ language. It @@ -72,7 +73,10 @@ instance Ord Location where | otherwise = compare thisColumn thatColumn -- | Contains some tree node with a location. -data Node a = Node a Location deriving (Eq, Show) +data Node a = Node + { value :: a + , location :: Location + } deriving (Eq, Show) -- ** Document @@ -258,7 +262,7 @@ data ObjectField a = ObjectField Name a Location -- Variables are usually passed along with the query, but not in the query -- itself. They make queries reusable. data VariableDefinition = - VariableDefinition Name Type (Maybe ConstValue) Location + VariableDefinition Name Type (Maybe (Node ConstValue)) Location deriving (Eq, Show) -- ** Type References @@ -484,8 +488,8 @@ instance Monoid ArgumentsDefinition where -- @ -- -- The input type "Point2D" contains two value definitions: "x" and "y". -data InputValueDefinition - = InputValueDefinition Description Name Type (Maybe ConstValue) [Directive] +data InputValueDefinition = InputValueDefinition + Description Name Type (Maybe (Node ConstValue)) [Directive] deriving (Eq, Show) -- ** Unions diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 011527a..dd464c2 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -25,7 +25,7 @@ import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) -import Language.GraphQL.AST.Document +import qualified Language.GraphQL.AST.Document as Full -- | Instructs the encoder whether the GraphQL document should be minified or -- pretty printed. @@ -44,77 +44,78 @@ minified :: Formatter minified = Minified -- | Converts a Document' into a string. -document :: Formatter -> Document -> Lazy.Text +document :: Formatter -> Full.Document -> Lazy.Text document formatter defs | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n' where encodeDocument = foldr executableDefinition [] defs - executableDefinition (ExecutableDefinition executableDefinition') acc = + executableDefinition (Full.ExecutableDefinition executableDefinition') acc = definition formatter executableDefinition' : acc executableDefinition _ acc = acc -- | Converts a t'ExecutableDefinition' into a string. -definition :: Formatter -> ExecutableDefinition -> Lazy.Text +definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text definition formatter x | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n' | Minified <- formatter = encodeDefinition x where - encodeDefinition (DefinitionOperation operation) + encodeDefinition (Full.DefinitionOperation operation) = operationDefinition formatter operation - encodeDefinition (DefinitionFragment fragment) + encodeDefinition (Full.DefinitionFragment fragment) = fragmentDefinition formatter fragment -- | Converts a 'OperationDefinition into a string. -operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text +operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text operationDefinition formatter = \case - SelectionSet sels _ -> selectionSet formatter sels - OperationDefinition Query name vars dirs sels _ -> - "query " <> node formatter name vars dirs sels - OperationDefinition Mutation name vars dirs sels _ -> - "mutation " <> node formatter name vars dirs sels - OperationDefinition Subscription name vars dirs sels _ -> - "subscription " <> node formatter name vars dirs sels + Full.SelectionSet sels _ -> selectionSet formatter sels + Full.OperationDefinition Full.Query name vars dirs sels _ -> + "query " <> root name vars dirs sels + Full.OperationDefinition Full.Mutation name vars dirs sels _ -> + "mutation " <> root name vars dirs sels + Full.OperationDefinition Full.Subscription name vars dirs sels _ -> + "subscription " <> root name vars dirs sels + where + -- | Converts a Query or Mutation into a string. + root :: Maybe Full.Name -> + [Full.VariableDefinition] -> + [Full.Directive] -> + Full.SelectionSet -> + Lazy.Text + root name vars dirs sels + = Lazy.Text.fromStrict (fold name) + <> optempty (variableDefinitions formatter) vars + <> optempty (directives formatter) dirs + <> eitherFormat formatter " " mempty + <> selectionSet formatter sels --- | Converts a Query or Mutation into a string. -node :: Formatter -> - Maybe Name -> - [VariableDefinition] -> - [Directive] -> - SelectionSet -> - Lazy.Text -node formatter name vars dirs sels - = Lazy.Text.fromStrict (fold name) - <> optempty (variableDefinitions formatter) vars - <> optempty (directives formatter) dirs - <> eitherFormat formatter " " mempty - <> selectionSet formatter sels - -variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text +variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text variableDefinitions formatter = parensCommas formatter $ variableDefinition formatter -variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text -variableDefinition formatter (VariableDefinition var ty defaultValue' _) - = variable var +variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text +variableDefinition formatter variableDefinition' = + let Full.VariableDefinition variableName variableType defaultValue' _ = + variableDefinition' + in variable variableName <> eitherFormat formatter ": " ":" - <> type' ty - <> maybe mempty (defaultValue formatter) defaultValue' + <> type' variableType + <> maybe mempty (defaultValue formatter) (Full.value <$> defaultValue') -defaultValue :: Formatter -> ConstValue -> Lazy.Text +defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text defaultValue formatter val = eitherFormat formatter " = " "=" <> value formatter (fromConstValue val) -variable :: Name -> Lazy.Text +variable :: Full.Name -> Lazy.Text variable var = "$" <> Lazy.Text.fromStrict var -selectionSet :: Formatter -> SelectionSet -> Lazy.Text +selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text selectionSet formatter = bracesList formatter (selection formatter) . NonEmpty.toList -selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text +selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text selectionSetOpt formatter = bracesList formatter $ selection formatter indentSymbol :: Lazy.Text @@ -123,14 +124,14 @@ indentSymbol = " " indent :: (Integral a) => a -> Lazy.Text indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol -selection :: Formatter -> Selection -> Lazy.Text +selection :: Formatter -> Full.Selection -> Lazy.Text selection formatter = Lazy.Text.append indent' . encodeSelection where - encodeSelection (FieldSelection fieldSelection) = + encodeSelection (Full.FieldSelection fieldSelection) = field incrementIndent fieldSelection - encodeSelection (InlineFragmentSelection fragmentSelection) = + encodeSelection (Full.InlineFragmentSelection fragmentSelection) = inlineFragment incrementIndent fragmentSelection - encodeSelection (FragmentSpreadSelection fragmentSelection) = + encodeSelection (Full.FragmentSpreadSelection fragmentSelection) = fragmentSpread incrementIndent fragmentSelection incrementIndent | Pretty indentation <- formatter = Pretty $ indentation + 1 @@ -143,8 +144,8 @@ colon :: Formatter -> Lazy.Text colon formatter = eitherFormat formatter ": " ":" -- | Converts Field into a string. -field :: Formatter -> Field -> Lazy.Text -field formatter (Field alias name args dirs set _) +field :: Formatter -> Full.Field -> Lazy.Text +field formatter (Full.Field alias name args dirs set _) = optempty prependAlias (fold alias) <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args @@ -155,32 +156,32 @@ field formatter (Field alias name args dirs set _) selectionSetOpt' = (eitherFormat formatter " " "" <>) . selectionSetOpt formatter -arguments :: Formatter -> [Argument] -> Lazy.Text +arguments :: Formatter -> [Full.Argument] -> Lazy.Text arguments formatter = parensCommas formatter $ argument formatter -argument :: Formatter -> Argument -> Lazy.Text -argument formatter (Argument name (Node value' _) _) +argument :: Formatter -> Full.Argument -> Lazy.Text +argument formatter (Full.Argument name value' _) = Lazy.Text.fromStrict name <> colon formatter - <> value formatter value' + <> value formatter (Full.value value') -- * Fragments -fragmentSpread :: Formatter -> FragmentSpread -> Lazy.Text -fragmentSpread formatter (FragmentSpread name directives' _) +fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text +fragmentSpread formatter (Full.FragmentSpread name directives' _) = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) directives' -inlineFragment :: Formatter -> InlineFragment -> Lazy.Text -inlineFragment formatter (InlineFragment typeCondition directives' selections _) +inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text +inlineFragment formatter (Full.InlineFragment typeCondition directives' selections _) = "... on " <> Lazy.Text.fromStrict (fold typeCondition) <> directives formatter directives' <> eitherFormat formatter " " mempty <> selectionSet formatter selections -fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text -fragmentDefinition formatter (FragmentDefinition name tc dirs sels _) +fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text +fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels _) = "fragment " <> Lazy.Text.fromStrict name <> " on " <> Lazy.Text.fromStrict tc <> optempty (directives formatter) dirs @@ -190,38 +191,38 @@ fragmentDefinition formatter (FragmentDefinition name tc dirs sels _) -- * Miscellaneous -- | Converts a 'Directive' into a string. -directive :: Formatter -> Directive -> Lazy.Text -directive formatter (Directive name args _) +directive :: Formatter -> Full.Directive -> Lazy.Text +directive formatter (Full.Directive name args _) = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args -directives :: Formatter -> [Directive] -> Lazy.Text +directives :: Formatter -> [Full.Directive] -> Lazy.Text directives Minified = spaces (directive Minified) directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter) -- | Converts a 'Value' into a string. -value :: Formatter -> Value -> Lazy.Text -value _ (Variable x) = variable x -value _ (Int x) = Builder.toLazyText $ decimal x -value _ (Float x) = Builder.toLazyText $ realFloat x -value _ (Boolean x) = booleanValue x -value _ Null = "null" -value formatter (String string) = stringValue formatter string -value _ (Enum x) = Lazy.Text.fromStrict x -value formatter (List x) = listValue formatter x -value formatter (Object x) = objectValue formatter x +value :: Formatter -> Full.Value -> Lazy.Text +value _ (Full.Variable x) = variable x +value _ (Full.Int x) = Builder.toLazyText $ decimal x +value _ (Full.Float x) = Builder.toLazyText $ realFloat x +value _ (Full.Boolean x) = booleanValue x +value _ Full.Null = "null" +value formatter (Full.String string) = stringValue formatter string +value _ (Full.Enum x) = Lazy.Text.fromStrict x +value formatter (Full.List x) = listValue formatter x +value formatter (Full.Object x) = objectValue formatter x -fromConstValue :: ConstValue -> Value -fromConstValue (ConstInt x) = Int x -fromConstValue (ConstFloat x) = Float x -fromConstValue (ConstBoolean x) = Boolean x -fromConstValue ConstNull = Null -fromConstValue (ConstString string) = String string -fromConstValue (ConstEnum x) = Enum x -fromConstValue (ConstList x) = List $ fromConstValue <$> x -fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x +fromConstValue :: Full.ConstValue -> Full.Value +fromConstValue (Full.ConstInt x) = Full.Int x +fromConstValue (Full.ConstFloat x) = Full.Float x +fromConstValue (Full.ConstBoolean x) = Full.Boolean x +fromConstValue Full.ConstNull = Full.Null +fromConstValue (Full.ConstString string) = Full.String string +fromConstValue (Full.ConstEnum x) = Full.Enum x +fromConstValue (Full.ConstList x) = Full.List $ fromConstValue <$> x +fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x where - fromConstObjectField (ObjectField key value' location) = - ObjectField key (fromConstValue value') location + fromConstObjectField (Full.ObjectField key value' location) = + Full.ObjectField key (fromConstValue value') location booleanValue :: Bool -> Lazy.Text booleanValue True = "true" @@ -278,10 +279,10 @@ escape char' where unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord) -listValue :: Formatter -> [Value] -> Lazy.Text +listValue :: Formatter -> [Full.Value] -> Lazy.Text listValue formatter = bracketsCommas formatter $ value formatter -objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text +objectValue :: Formatter -> [Full.ObjectField Full.Value] -> Lazy.Text objectValue formatter = intercalate $ objectField formatter where intercalate f @@ -289,22 +290,22 @@ objectValue formatter = intercalate $ objectField formatter . Lazy.Text.intercalate (eitherFormat formatter ", " ",") . fmap f -objectField :: Formatter -> ObjectField Value -> Lazy.Text -objectField formatter (ObjectField name value' _) = +objectField :: Formatter -> Full.ObjectField Full.Value -> Lazy.Text +objectField formatter (Full.ObjectField name value' _) = Lazy.Text.fromStrict name <> colon formatter <> value formatter value' -- | Converts a 'Type' a type into a string. -type' :: Type -> Lazy.Text -type' (TypeNamed x) = Lazy.Text.fromStrict x -type' (TypeList x) = listType x -type' (TypeNonNull x) = nonNullType x +type' :: Full.Type -> Lazy.Text +type' (Full.TypeNamed x) = Lazy.Text.fromStrict x +type' (Full.TypeList x) = listType x +type' (Full.TypeNonNull x) = nonNullType x -listType :: Type -> Lazy.Text +listType :: Full.Type -> Lazy.Text listType x = brackets (type' x) -nonNullType :: NonNullType -> Lazy.Text -nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!" -nonNullType (NonNullTypeList x) = listType x <> "!" +nonNullType :: Full.NonNullType -> Lazy.Text +nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!" +nonNullType (Full.NonNullTypeList x) = listType x <> "!" -- * Internal diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index eb82f38..2695e6f 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -18,7 +19,7 @@ import Language.GraphQL.AST.DirectiveLocation , ExecutableDirectiveLocation , TypeSystemDirectiveLocation ) -import Language.GraphQL.AST.Document +import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.Lexer import Text.Megaparsec ( MonadParsec(..) @@ -32,13 +33,13 @@ import Text.Megaparsec ) -- | Parser for the GraphQL documents. -document :: Parser Document +document :: Parser Full.Document document = unicodeBOM *> spaceConsumer *> lexeme (NonEmpty.some definition) -definition :: Parser Definition -definition = ExecutableDefinition <$> executableDefinition +definition :: Parser Full.Definition +definition = Full.ExecutableDefinition <$> executableDefinition <|> typeSystemDefinition' <|> typeSystemExtension' "Definition" @@ -46,41 +47,41 @@ definition = ExecutableDefinition <$> executableDefinition typeSystemDefinition' = do location <- getLocation definition' <- typeSystemDefinition - pure $ TypeSystemDefinition definition' location + pure $ Full.TypeSystemDefinition definition' location typeSystemExtension' = do location <- getLocation definition' <- typeSystemExtension - pure $ TypeSystemExtension definition' location + pure $ Full.TypeSystemExtension definition' location -getLocation :: Parser Location +getLocation :: Parser Full.Location getLocation = fromSourcePosition <$> getSourcePos where fromSourcePosition SourcePos{..} = - Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn) + Full.Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn) wordFromPosition = fromIntegral . unPos -executableDefinition :: Parser ExecutableDefinition -executableDefinition = DefinitionOperation <$> operationDefinition - <|> DefinitionFragment <$> fragmentDefinition +executableDefinition :: Parser Full.ExecutableDefinition +executableDefinition = Full.DefinitionOperation <$> operationDefinition + <|> Full.DefinitionFragment <$> fragmentDefinition "ExecutableDefinition" -typeSystemDefinition :: Parser TypeSystemDefinition +typeSystemDefinition :: Parser Full.TypeSystemDefinition typeSystemDefinition = schemaDefinition <|> typeSystemDefinitionWithDescription "TypeSystemDefinition" where typeSystemDefinitionWithDescription = description >>= liftA2 (<|>) typeDefinition' directiveDefinition - typeDefinition' description' = TypeDefinition + typeDefinition' description' = Full.TypeDefinition <$> typeDefinition description' -typeSystemExtension :: Parser TypeSystemExtension -typeSystemExtension = SchemaExtension <$> schemaExtension - <|> TypeExtension <$> typeExtension +typeSystemExtension :: Parser Full.TypeSystemExtension +typeSystemExtension = Full.SchemaExtension <$> schemaExtension + <|> Full.TypeExtension <$> typeExtension "TypeSystemExtension" -directiveDefinition :: Description -> Parser TypeSystemDefinition -directiveDefinition description' = DirectiveDefinition description' +directiveDefinition :: Full.Description -> Parser Full.TypeSystemDefinition +directiveDefinition description' = Full.DirectiveDefinition description' <$ symbol "directive" <* at <*> name @@ -124,7 +125,7 @@ typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA" <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION" "TypeSystemDirectiveLocation" -typeDefinition :: Description -> Parser TypeDefinition +typeDefinition :: Full.Description -> Parser Full.TypeDefinition typeDefinition description' = scalarTypeDefinition description' <|> objectTypeDefinition description' <|> interfaceTypeDefinition description' @@ -133,7 +134,7 @@ typeDefinition description' = scalarTypeDefinition description' <|> inputObjectTypeDefinition description' "TypeDefinition" -typeExtension :: Parser TypeExtension +typeExtension :: Parser Full.TypeExtension typeExtension = scalarTypeExtension <|> objectTypeExtension <|> interfaceTypeExtension @@ -142,143 +143,143 @@ typeExtension = scalarTypeExtension <|> inputObjectTypeExtension "TypeExtension" -scalarTypeDefinition :: Description -> Parser TypeDefinition -scalarTypeDefinition description' = ScalarTypeDefinition description' +scalarTypeDefinition :: Full.Description -> Parser Full.TypeDefinition +scalarTypeDefinition description' = Full.ScalarTypeDefinition description' <$ symbol "scalar" <*> name <*> directives "ScalarTypeDefinition" -scalarTypeExtension :: Parser TypeExtension +scalarTypeExtension :: Parser Full.TypeExtension scalarTypeExtension = extend "scalar" "ScalarTypeExtension" - $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] + $ (Full.ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] -objectTypeDefinition :: Description -> Parser TypeDefinition -objectTypeDefinition description' = ObjectTypeDefinition description' +objectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition +objectTypeDefinition description' = Full.ObjectTypeDefinition description' <$ symbol "type" <*> name - <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) + <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> directives <*> braces (many fieldDefinition) "ObjectTypeDefinition" -objectTypeExtension :: Parser TypeExtension +objectTypeExtension :: Parser Full.TypeExtension objectTypeExtension = extend "type" "ObjectTypeExtension" $ fieldsDefinitionExtension :| [ directivesExtension , implementsInterfacesExtension ] where - fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension + fieldsDefinitionExtension = Full.ObjectTypeFieldsDefinitionExtension <$> name - <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) + <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> directives <*> braces (NonEmpty.some fieldDefinition) - directivesExtension = ObjectTypeDirectivesExtension + directivesExtension = Full.ObjectTypeDirectivesExtension <$> name - <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) + <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> NonEmpty.some directive - implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension + implementsInterfacesExtension = Full.ObjectTypeImplementsInterfacesExtension <$> name <*> implementsInterfaces NonEmpty.sepBy1 -description :: Parser Description -description = Description +description :: Parser Full.Description +description = Full.Description <$> optional stringValue "Description" -unionTypeDefinition :: Description -> Parser TypeDefinition -unionTypeDefinition description' = UnionTypeDefinition description' +unionTypeDefinition :: Full.Description -> Parser Full.TypeDefinition +unionTypeDefinition description' = Full.UnionTypeDefinition description' <$ symbol "union" <*> name <*> directives - <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1) + <*> option (Full.UnionMemberTypes []) (unionMemberTypes sepBy1) "UnionTypeDefinition" -unionTypeExtension :: Parser TypeExtension +unionTypeExtension :: Parser Full.TypeExtension unionTypeExtension = extend "union" "UnionTypeExtension" $ unionMemberTypesExtension :| [directivesExtension] where - unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension + unionMemberTypesExtension = Full.UnionTypeUnionMemberTypesExtension <$> name <*> directives <*> unionMemberTypes NonEmpty.sepBy1 - directivesExtension = UnionTypeDirectivesExtension + directivesExtension = Full.UnionTypeDirectivesExtension <$> name <*> NonEmpty.some directive unionMemberTypes :: Foldable t => - (Parser Text -> Parser Text -> Parser (t NamedType)) -> - Parser (UnionMemberTypes t) -unionMemberTypes sepBy' = UnionMemberTypes + (Parser Text -> Parser Text -> Parser (t Full.NamedType)) -> + Parser (Full.UnionMemberTypes t) +unionMemberTypes sepBy' = Full.UnionMemberTypes <$ equals <* optional pipe <*> name `sepBy'` pipe "UnionMemberTypes" -interfaceTypeDefinition :: Description -> Parser TypeDefinition -interfaceTypeDefinition description' = InterfaceTypeDefinition description' +interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition +interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description' <$ symbol "interface" <*> name <*> directives <*> braces (many fieldDefinition) "InterfaceTypeDefinition" -interfaceTypeExtension :: Parser TypeExtension +interfaceTypeExtension :: Parser Full.TypeExtension interfaceTypeExtension = extend "interface" "InterfaceTypeExtension" $ fieldsDefinitionExtension :| [directivesExtension] where - fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension + fieldsDefinitionExtension = Full.InterfaceTypeFieldsDefinitionExtension <$> name <*> directives <*> braces (NonEmpty.some fieldDefinition) - directivesExtension = InterfaceTypeDirectivesExtension + directivesExtension = Full.InterfaceTypeDirectivesExtension <$> name <*> NonEmpty.some directive -enumTypeDefinition :: Description -> Parser TypeDefinition -enumTypeDefinition description' = EnumTypeDefinition description' +enumTypeDefinition :: Full.Description -> Parser Full.TypeDefinition +enumTypeDefinition description' = Full.EnumTypeDefinition description' <$ symbol "enum" <*> name <*> directives <*> listOptIn braces enumValueDefinition "EnumTypeDefinition" -enumTypeExtension :: Parser TypeExtension +enumTypeExtension :: Parser Full.TypeExtension enumTypeExtension = extend "enum" "EnumTypeExtension" $ enumValuesDefinitionExtension :| [directivesExtension] where - enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension + enumValuesDefinitionExtension = Full.EnumTypeEnumValuesDefinitionExtension <$> name <*> directives <*> braces (NonEmpty.some enumValueDefinition) - directivesExtension = EnumTypeDirectivesExtension + directivesExtension = Full.EnumTypeDirectivesExtension <$> name <*> NonEmpty.some directive -inputObjectTypeDefinition :: Description -> Parser TypeDefinition -inputObjectTypeDefinition description' = InputObjectTypeDefinition description' +inputObjectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition +inputObjectTypeDefinition description' = Full.InputObjectTypeDefinition description' <$ symbol "input" <*> name <*> directives <*> listOptIn braces inputValueDefinition "InputObjectTypeDefinition" -inputObjectTypeExtension :: Parser TypeExtension +inputObjectTypeExtension :: Parser Full.TypeExtension inputObjectTypeExtension = extend "input" "InputObjectTypeExtension" $ inputFieldsDefinitionExtension :| [directivesExtension] where - inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension + inputFieldsDefinitionExtension = Full.InputObjectTypeInputFieldsDefinitionExtension <$> name <*> directives <*> braces (NonEmpty.some inputValueDefinition) - directivesExtension = InputObjectTypeDirectivesExtension + directivesExtension = Full.InputObjectTypeDirectivesExtension <$> name <*> NonEmpty.some directive -enumValueDefinition :: Parser EnumValueDefinition -enumValueDefinition = EnumValueDefinition +enumValueDefinition :: Parser Full.EnumValueDefinition +enumValueDefinition = Full.EnumValueDefinition <$> description <*> enumValue <*> directives @@ -286,16 +287,16 @@ enumValueDefinition = EnumValueDefinition implementsInterfaces :: Foldable t => - (Parser Text -> Parser Text -> Parser (t NamedType)) -> - Parser (ImplementsInterfaces t) -implementsInterfaces sepBy' = ImplementsInterfaces + (Parser Text -> Parser Text -> Parser (t Full.NamedType)) -> + Parser (Full.ImplementsInterfaces t) +implementsInterfaces sepBy' = Full.ImplementsInterfaces <$ symbol "implements" <* optional amp <*> name `sepBy'` amp "ImplementsInterfaces" -inputValueDefinition :: Parser InputValueDefinition -inputValueDefinition = InputValueDefinition +inputValueDefinition :: Parser Full.InputValueDefinition +inputValueDefinition = Full.InputValueDefinition <$> description <*> name <* colon @@ -304,13 +305,13 @@ inputValueDefinition = InputValueDefinition <*> directives "InputValueDefinition" -argumentsDefinition :: Parser ArgumentsDefinition -argumentsDefinition = ArgumentsDefinition +argumentsDefinition :: Parser Full.ArgumentsDefinition +argumentsDefinition = Full.ArgumentsDefinition <$> listOptIn parens inputValueDefinition "ArgumentsDefinition" -fieldDefinition :: Parser FieldDefinition -fieldDefinition = FieldDefinition +fieldDefinition :: Parser Full.FieldDefinition +fieldDefinition = Full.FieldDefinition <$> description <*> name <*> argumentsDefinition @@ -319,33 +320,33 @@ fieldDefinition = FieldDefinition <*> directives "FieldDefinition" -schemaDefinition :: Parser TypeSystemDefinition -schemaDefinition = SchemaDefinition +schemaDefinition :: Parser Full.TypeSystemDefinition +schemaDefinition = Full.SchemaDefinition <$ symbol "schema" <*> directives <*> operationTypeDefinitions "SchemaDefinition" -operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition) +operationTypeDefinitions :: Parser (NonEmpty Full.OperationTypeDefinition) operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition -schemaExtension :: Parser SchemaExtension +schemaExtension :: Parser Full.SchemaExtension schemaExtension = extend "schema" "SchemaExtension" $ schemaOperationExtension :| [directivesExtension] where - directivesExtension = SchemaDirectivesExtension + directivesExtension = Full.SchemaDirectivesExtension <$> NonEmpty.some directive - schemaOperationExtension = SchemaOperationExtension + schemaOperationExtension = Full.SchemaOperationExtension <$> directives <*> operationTypeDefinitions -operationTypeDefinition :: Parser OperationTypeDefinition -operationTypeDefinition = OperationTypeDefinition +operationTypeDefinition :: Parser Full.OperationTypeDefinition +operationTypeDefinition = Full.OperationTypeDefinition <$> operationType <* colon <*> name "OperationTypeDefinition" -operationDefinition :: Parser OperationDefinition +operationDefinition :: Parser Full.OperationDefinition operationDefinition = shorthand <|> operationDefinition' "OperationDefinition" @@ -353,7 +354,7 @@ operationDefinition = shorthand shorthand = do location <- getLocation selectionSet' <- selectionSet - pure $ SelectionSet selectionSet' location + pure $ Full.SelectionSet selectionSet' location operationDefinition' = do location <- getLocation operationType' <- operationType @@ -361,27 +362,33 @@ operationDefinition = shorthand variableDefinitions' <- variableDefinitions directives' <- directives selectionSet' <- selectionSet - pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location + pure $ Full.OperationDefinition + operationType' + operationName + variableDefinitions' + directives' + selectionSet' + location -operationType :: Parser OperationType -operationType = Query <$ symbol "query" - <|> Mutation <$ symbol "mutation" - <|> Subscription <$ symbol "subscription" +operationType :: Parser Full.OperationType +operationType = Full.Query <$ symbol "query" + <|> Full.Mutation <$ symbol "mutation" + <|> Full.Subscription <$ symbol "subscription" "OperationType" -selectionSet :: Parser SelectionSet +selectionSet :: Parser Full.SelectionSet selectionSet = braces (NonEmpty.some selection) "SelectionSet" -selectionSetOpt :: Parser SelectionSetOpt +selectionSetOpt :: Parser Full.SelectionSetOpt selectionSetOpt = listOptIn braces selection "SelectionSet" -selection :: Parser Selection -selection = FieldSelection <$> field - <|> FragmentSpreadSelection <$> try fragmentSpread - <|> InlineFragmentSelection <$> inlineFragment +selection :: Parser Full.Selection +selection = Full.FieldSelection <$> field + <|> Full.FragmentSpreadSelection <$> try fragmentSpread + <|> Full.InlineFragmentSelection <$> inlineFragment "Selection" -field :: Parser Field +field :: Parser Full.Field field = label "Field" $ do location <- getLocation alias' <- optional alias @@ -389,40 +396,40 @@ field = label "Field" $ do arguments' <- arguments directives' <- directives selectionSetOpt' <- selectionSetOpt - pure $ Field alias' name' arguments' directives' selectionSetOpt' location + pure $ Full.Field alias' name' arguments' directives' selectionSetOpt' location -alias :: Parser Name +alias :: Parser Full.Name alias = try (name <* colon) "Alias" -arguments :: Parser [Argument] +arguments :: Parser [Full.Argument] arguments = listOptIn parens argument "Arguments" -argument :: Parser Argument +argument :: Parser Full.Argument argument = label "Argument" $ do location <- getLocation name' <- name colon - value' <- valueNode - pure $ Argument name' value' location + value' <- valueNode value + pure $ Full.Argument name' value' location -fragmentSpread :: Parser FragmentSpread +fragmentSpread :: Parser Full.FragmentSpread fragmentSpread = label "FragmentSpread" $ do location <- getLocation _ <- spread fragmentName' <- fragmentName directives' <- directives - pure $ FragmentSpread fragmentName' directives' location + pure $ Full.FragmentSpread fragmentName' directives' location -inlineFragment :: Parser InlineFragment +inlineFragment :: Parser Full.InlineFragment inlineFragment = label "InlineFragment" $ do location <- getLocation _ <- spread typeCondition' <- optional typeCondition directives' <- directives selectionSet' <- selectionSet - pure $ InlineFragment typeCondition' directives' selectionSet' location + pure $ Full.InlineFragment typeCondition' directives' selectionSet' location -fragmentDefinition :: Parser FragmentDefinition +fragmentDefinition :: Parser Full.FragmentDefinition fragmentDefinition = label "FragmentDefinition" $ do location <- getLocation _ <- symbol "fragment" @@ -430,42 +437,42 @@ fragmentDefinition = label "FragmentDefinition" $ do typeCondition' <- typeCondition directives' <- directives selectionSet' <- selectionSet - pure $ FragmentDefinition + pure $ Full.FragmentDefinition fragmentName' typeCondition' directives' selectionSet' location -fragmentName :: Parser Name +fragmentName :: Parser Full.Name fragmentName = but (symbol "on") *> name "FragmentName" -typeCondition :: Parser TypeCondition +typeCondition :: Parser Full.TypeCondition typeCondition = symbol "on" *> name "TypeCondition" -valueNode :: Parser (Node Value) -valueNode = do +valueNode :: forall a. Parser a -> Parser (Full.Node a) +valueNode valueParser = do location <- getLocation - value' <- value - pure $ Node value' location + value' <- valueParser + pure $ Full.Node value' location -value :: Parser Value -value = Variable <$> variable - <|> Float <$> try float - <|> Int <$> integer - <|> Boolean <$> booleanValue - <|> Null <$ nullValue - <|> String <$> stringValue - <|> Enum <$> try enumValue - <|> List <$> brackets (some value) - <|> Object <$> braces (some $ objectField value) +value :: Parser Full.Value +value = Full.Variable <$> variable + <|> Full.Float <$> try float + <|> Full.Int <$> integer + <|> Full.Boolean <$> booleanValue + <|> Full.Null <$ nullValue + <|> Full.String <$> stringValue + <|> Full.Enum <$> try enumValue + <|> Full.List <$> brackets (some value) + <|> Full.Object <$> braces (some $ objectField value) "Value" -constValue :: Parser ConstValue -constValue = ConstFloat <$> try float - <|> ConstInt <$> integer - <|> ConstBoolean <$> booleanValue - <|> ConstNull <$ nullValue - <|> ConstString <$> stringValue - <|> ConstEnum <$> try enumValue - <|> ConstList <$> brackets (some constValue) - <|> ConstObject <$> braces (some $ objectField constValue) +constValue :: Parser Full.ConstValue +constValue = Full.ConstFloat <$> try float + <|> Full.ConstInt <$> integer + <|> Full.ConstBoolean <$> booleanValue + <|> Full.ConstNull <$ nullValue + <|> Full.ConstString <$> stringValue + <|> Full.ConstEnum <$> try enumValue + <|> Full.ConstList <$> brackets (some constValue) + <|> Full.ConstObject <$> braces (some $ objectField constValue) "Value" booleanValue :: Parser Bool @@ -473,7 +480,7 @@ booleanValue = True <$ symbol "true" <|> False <$ symbol "false" "BooleanValue" -enumValue :: Parser Name +enumValue :: Parser Full.Name enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") @@ -486,54 +493,54 @@ stringValue = blockString <|> string "StringValue" nullValue :: Parser Text nullValue = symbol "null" "NullValue" -objectField :: Parser a -> Parser (ObjectField a) +objectField :: Parser a -> Parser (Full.ObjectField a) objectField valueParser = label "ObjectField" $ do location <- getLocation fieldName <- name colon fieldValue <- valueParser - pure $ ObjectField fieldName fieldValue location + pure $ Full.ObjectField fieldName fieldValue location -variableDefinitions :: Parser [VariableDefinition] +variableDefinitions :: Parser [Full.VariableDefinition] variableDefinitions = listOptIn parens variableDefinition "VariableDefinitions" -variableDefinition :: Parser VariableDefinition +variableDefinition :: Parser Full.VariableDefinition variableDefinition = label "VariableDefinition" $ do location <- getLocation variableName <- variable colon variableType <- type' variableValue <- defaultValue - pure $ VariableDefinition variableName variableType variableValue location + pure $ Full.VariableDefinition variableName variableType variableValue location -variable :: Parser Name +variable :: Parser Full.Name variable = dollar *> name "Variable" -defaultValue :: Parser (Maybe ConstValue) -defaultValue = optional (equals *> constValue) "DefaultValue" +defaultValue :: Parser (Maybe (Full.Node Full.ConstValue)) +defaultValue = optional (equals *> valueNode constValue) "DefaultValue" -type' :: Parser Type -type' = try (TypeNonNull <$> nonNullType) - <|> TypeList <$> brackets type' - <|> TypeNamed <$> name +type' :: Parser Full.Type +type' = try (Full.TypeNonNull <$> nonNullType) + <|> Full.TypeList <$> brackets type' + <|> Full.TypeNamed <$> name "Type" -nonNullType :: Parser NonNullType -nonNullType = NonNullTypeNamed <$> name <* bang - <|> NonNullTypeList <$> brackets type' <* bang +nonNullType :: Parser Full.NonNullType +nonNullType = Full.NonNullTypeNamed <$> name <* bang + <|> Full.NonNullTypeList <$> brackets type' <* bang "NonNullType" -directives :: Parser [Directive] +directives :: Parser [Full.Directive] directives = many directive "Directives" -directive :: Parser Directive +directive :: Parser Full.Directive directive = label "Directive" $ do location <- getLocation at directiveName <- name directiveArguments <- arguments - pure $ Directive directiveName directiveArguments location + pure $ Full.Directive directiveName directiveArguments location listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a] listOptIn surround = option [] . surround . some diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index d5b7a9c..80e7a83 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -153,7 +153,7 @@ coerceVariableValues types operationDefinition variableValues = forEach variableDefinition coercedValues = do let Full.VariableDefinition variableName variableTypeName defaultValue _ = variableDefinition - let defaultValue' = constValue <$> defaultValue + let defaultValue' = constValue . Full.value <$> defaultValue variableType <- lookupInputType variableTypeName types Coerce.matchFieldValues diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index eedad6c..b4ac29e 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -23,7 +23,7 @@ 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 qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.Type.Internal import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In @@ -35,7 +35,7 @@ import Language.GraphQL.Validate.Validation (Validation(Validation)) import qualified Language.GraphQL.Validate.Validation as Validation type ApplySelectionRule m a - = HashMap Name (Schema.Type m) + = HashMap Full.Name (Schema.Type m) -> Validation.Rule m -> Maybe (Out.Type m) -> a @@ -48,7 +48,7 @@ type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.RuleT m) document :: forall m . Schema m -> [Validation.Rule m] - -> Document + -> Full.Document -> Seq Validation.Error document schema' rules' document' = runReaderT reader context @@ -111,121 +111,145 @@ document schema' rules' document' = definition :: Validation.Rule m -> Validation m - -> Definition + -> Full.Definition -> Seq (Validation.RuleT m) -> Seq (Validation.RuleT m) definition (Validation.DefinitionRule rule) _ definition' accumulator = accumulator |> rule definition' -definition rule context (ExecutableDefinition definition') accumulator = +definition rule context (Full.ExecutableDefinition definition') accumulator = accumulator >< executableDefinition rule context definition' -definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator = - accumulator >< typeSystemDefinition rule typeSystemDefinition' -definition rule _ (TypeSystemExtension extension _) accumulator = - accumulator >< typeSystemExtension rule extension +definition rule context (Full.TypeSystemDefinition typeSystemDefinition' _) accumulator = + accumulator >< typeSystemDefinition context rule typeSystemDefinition' +definition rule context (Full.TypeSystemExtension extension _) accumulator = + accumulator >< typeSystemExtension context rule extension -typeSystemExtension :: forall m. ApplyRule m TypeSystemExtension -typeSystemExtension rule = \case - SchemaExtension extension -> schemaExtension rule extension - TypeExtension extension -> typeExtension rule extension +typeSystemExtension :: forall m + . Validation m + -> ApplyRule m Full.TypeSystemExtension +typeSystemExtension context rule = \case + Full.SchemaExtension extension -> schemaExtension context rule extension + Full.TypeExtension extension -> typeExtension context rule extension -typeExtension :: forall m. ApplyRule m TypeExtension -typeExtension rule = \case - ScalarTypeExtension _ directives' -> directives rule directives' - ObjectTypeFieldsDefinitionExtension _ _ directives' fields -> - directives rule directives' >< foldMap (fieldDefinition rule) fields - ObjectTypeDirectivesExtension _ _ directives' -> directives rule directives' - ObjectTypeImplementsInterfacesExtension _ _ -> mempty - InterfaceTypeFieldsDefinitionExtension _ directives' fields -> - directives rule directives' >< foldMap (fieldDefinition rule) fields - InterfaceTypeDirectivesExtension _ directives' -> - directives rule directives' - UnionTypeUnionMemberTypesExtension _ directives' _ -> - directives rule directives' - UnionTypeDirectivesExtension _ directives' -> directives rule directives' - EnumTypeEnumValuesDefinitionExtension _ directives' values -> - directives rule directives' >< foldMap (enumValueDefinition rule) values - EnumTypeDirectivesExtension _ directives' -> directives rule directives' - InputObjectTypeInputFieldsDefinitionExtension _ directives' fields - -> directives rule directives' - >< foldMap (inputValueDefinition rule) fields - InputObjectTypeDirectivesExtension _ directives' -> - directives rule directives' +typeExtension :: forall m. Validation m -> ApplyRule m Full.TypeExtension +typeExtension context rule = \case + Full.ScalarTypeExtension _ directives' -> directives context rule directives' + Full.ObjectTypeFieldsDefinitionExtension _ _ directives' fields + -> directives context rule directives' + >< foldMap (fieldDefinition context rule) fields + Full.ObjectTypeDirectivesExtension _ _ directives' -> + directives context rule directives' + Full.ObjectTypeImplementsInterfacesExtension _ _ -> mempty + Full.InterfaceTypeFieldsDefinitionExtension _ directives' fields + -> directives context rule directives' + >< foldMap (fieldDefinition context rule) fields + Full.InterfaceTypeDirectivesExtension _ directives' -> + directives context rule directives' + Full.UnionTypeUnionMemberTypesExtension _ directives' _ -> + directives context rule directives' + Full.UnionTypeDirectivesExtension _ directives' -> + directives context rule directives' + Full.EnumTypeEnumValuesDefinitionExtension _ directives' values + -> directives context rule directives' + >< foldMap (enumValueDefinition context rule) values + Full.EnumTypeDirectivesExtension _ directives' -> + directives context rule directives' + Full.InputObjectTypeInputFieldsDefinitionExtension _ directives' fields + -> directives context rule directives' + >< foldMap (inputValueDefinition context rule) fields + Full.InputObjectTypeDirectivesExtension _ directives' -> + directives context rule directives' -schemaExtension :: forall m. ApplyRule m SchemaExtension -schemaExtension rule = \case - SchemaOperationExtension directives' _ -> directives rule directives' - SchemaDirectivesExtension directives' -> directives rule directives' +schemaExtension :: forall m. Validation m -> ApplyRule m Full.SchemaExtension +schemaExtension context rule = \case + Full.SchemaOperationExtension directives' _ -> + directives context rule directives' + Full.SchemaDirectivesExtension directives' -> directives context rule directives' executableDefinition :: forall m . Validation.Rule m -> Validation m - -> ExecutableDefinition + -> Full.ExecutableDefinition -> Seq (Validation.RuleT m) -executableDefinition rule context (DefinitionOperation operation) = +executableDefinition rule context (Full.DefinitionOperation operation) = operationDefinition rule context operation -executableDefinition rule context (DefinitionFragment fragment) = +executableDefinition rule context (Full.DefinitionFragment fragment) = fragmentDefinition rule context fragment -typeSystemDefinition :: forall m. ApplyRule m TypeSystemDefinition -typeSystemDefinition rule = \case - SchemaDefinition directives' _ -> directives rule directives' - TypeDefinition typeDefinition' -> typeDefinition rule typeDefinition' - DirectiveDefinition _ _ arguments' _ -> argumentsDefinition rule arguments' +typeSystemDefinition :: forall m + . Validation m + -> ApplyRule m Full.TypeSystemDefinition +typeSystemDefinition context rule = \case + Full.SchemaDefinition directives' _ -> directives context rule directives' + Full.TypeDefinition typeDefinition' -> + typeDefinition context rule typeDefinition' + Full.DirectiveDefinition _ _ arguments' _ -> + argumentsDefinition context rule arguments' -typeDefinition :: forall m. ApplyRule m TypeDefinition -typeDefinition rule = \case - ScalarTypeDefinition _ _ directives' -> directives rule directives' - ObjectTypeDefinition _ _ _ directives' fields -> - directives rule directives' >< foldMap (fieldDefinition rule) fields - InterfaceTypeDefinition _ _ directives' fields -> - directives rule directives' >< foldMap (fieldDefinition rule) fields - UnionTypeDefinition _ _ directives' _ -> directives rule directives' - EnumTypeDefinition _ _ directives' values -> - directives rule directives' >< foldMap (enumValueDefinition rule) values - InputObjectTypeDefinition _ _ directives' fields - -> directives rule directives' - <> foldMap (inputValueDefinition rule) fields +typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition +typeDefinition context rule = \case + Full.ScalarTypeDefinition _ _ directives' -> + directives context rule directives' + Full.ObjectTypeDefinition _ _ _ directives' fields + -> directives context rule directives' + >< foldMap (fieldDefinition context rule) fields + Full.InterfaceTypeDefinition _ _ directives' fields + -> directives context rule directives' + >< foldMap (fieldDefinition context rule) fields + Full.UnionTypeDefinition _ _ directives' _ -> + directives context rule directives' + Full.EnumTypeDefinition _ _ directives' values + -> directives context rule directives' + >< foldMap (enumValueDefinition context rule) values + Full.InputObjectTypeDefinition _ _ directives' fields + -> directives context rule directives' + <> foldMap (inputValueDefinition context rule) fields -enumValueDefinition :: forall m. ApplyRule m EnumValueDefinition -enumValueDefinition rule (EnumValueDefinition _ _ directives') = - directives rule directives' +enumValueDefinition :: forall m + . Validation m + -> ApplyRule m Full.EnumValueDefinition +enumValueDefinition context rule (Full.EnumValueDefinition _ _ directives') = + directives context rule directives' -fieldDefinition :: forall m. ApplyRule m FieldDefinition -fieldDefinition rule (FieldDefinition _ _ arguments' _ directives') = - directives rule directives' >< argumentsDefinition rule arguments' +fieldDefinition :: forall m. Validation m -> ApplyRule m Full.FieldDefinition +fieldDefinition context rule (Full.FieldDefinition _ _ arguments' _ directives') + = directives context rule directives' + >< argumentsDefinition context rule arguments' -argumentsDefinition :: forall m. ApplyRule m ArgumentsDefinition -argumentsDefinition rule (ArgumentsDefinition definitions) = - foldMap (inputValueDefinition rule) definitions +argumentsDefinition :: forall m + . Validation m + -> ApplyRule m Full.ArgumentsDefinition +argumentsDefinition context rule (Full.ArgumentsDefinition definitions) = + foldMap (inputValueDefinition context rule) definitions -inputValueDefinition :: forall m. ApplyRule m InputValueDefinition -inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') = - directives rule directives' +inputValueDefinition :: forall m + . Validation m + -> ApplyRule m Full.InputValueDefinition +inputValueDefinition context rule (Full.InputValueDefinition _ _ _ _ directives') = + directives context rule directives' operationDefinition :: forall m . Validation.Rule m -> Validation m - -> OperationDefinition + -> Full.OperationDefinition -> Seq (Validation.RuleT m) operationDefinition rule context operation | Validation.OperationDefinitionRule operationRule <- rule = pure $ operationRule operation | Validation.VariablesRule variablesRule <- rule - , OperationDefinition _ _ variables _ _ _ <- operation - = Seq.fromList (variableDefinition rule <$> variables) - |> variablesRule variables - | SelectionSet selections _ <- operation = - selectionSet types' rule (getRootType Query) selections - | OperationDefinition operationType _ _ directives' selections _ <- operation - = selectionSet types' rule (getRootType operationType) selections - >< directives rule directives' + , Full.OperationDefinition _ _ variables _ _ _ <- operation = + foldMap (variableDefinition context rule) variables |> variablesRule variables + | Full.SelectionSet selections _ <- operation = + selectionSet context types' rule (getRootType Full.Query) selections + | Full.OperationDefinition operationType _ _ directives' selections _ <- operation + = selectionSet context types' rule (getRootType operationType) selections + >< directives context rule directives' where types' = Validation.types context - getRootType Query = + getRootType Full.Query = Just $ Out.NamedObjectType $ Schema.query $ Validation.schema context - getRootType Mutation = + getRootType Full.Mutation = Out.NamedObjectType <$> Schema.mutation (Validation.schema context) - getRootType Subscription = + getRootType Full.Subscription = Out.NamedObjectType <$> Schema.subscription (Validation.schema context) typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m) @@ -239,88 +263,159 @@ typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType typeToOut _ = Nothing variableDefinition :: forall m + . Validation m + -> ApplyRule m Full.VariableDefinition +variableDefinition context rule (Full.VariableDefinition _ typeName value' _) + | Just defaultValue' <- value' + , variableType <- lookupInputType typeName $ Validation.types context = + constValue rule variableType $ Full.value defaultValue' +variableDefinition _ _ _ = mempty + +constValue :: forall m . Validation.Rule m - -> VariableDefinition - -> Validation.RuleT m -variableDefinition (Validation.ValueRule _ rule) (VariableDefinition _ _ value _) = - maybe (lift mempty) rule value -variableDefinition _ _ = lift mempty + -> Maybe In.Type + -> Full.ConstValue + -> Seq (Validation.RuleT m) +constValue (Validation.ValueRule _ rule) valueType = go valueType + where + go inputObjectType value'@(Full.ConstObject fields) + = foldMap (forEach inputObjectType) (Seq.fromList fields) + |> rule inputObjectType value' + go listType value'@(Full.ConstList values) + = foldMap (go $ valueTypeFromList listType) (Seq.fromList values) + |> rule listType value' + go anotherValue value' = pure $ rule anotherValue value' + forEach inputObjectType (Full.ObjectField fieldName fieldValue _) = + go (valueTypeByName fieldName inputObjectType) fieldValue +constValue _ _ = const mempty + +inputFieldType :: In.InputField -> In.Type +inputFieldType (In.InputField _ inputFieldType' _) = inputFieldType' + +valueTypeByName :: Full.Name -> Maybe In.Type -> Maybe In.Type +valueTypeByName fieldName (Just( In.InputObjectBaseType inputObjectType)) = + let In.InputObjectType _ _ fieldTypes = inputObjectType + in inputFieldType <$> HashMap.lookup fieldName fieldTypes +valueTypeByName _ _ = Nothing + +valueTypeFromList :: Maybe In.Type -> Maybe In.Type +valueTypeFromList (Just (In.ListBaseType listType)) = Just listType +valueTypeFromList _ = Nothing fragmentDefinition :: forall m . Validation.Rule m -> Validation m - -> FragmentDefinition + -> Full.FragmentDefinition -> Seq (Validation.RuleT m) fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' = pure $ rule definition' fragmentDefinition rule context definition' - | FragmentDefinition _ typeCondition directives' selections _ <- definition' + | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition' , Validation.FragmentRule definitionRule _ <- rule = applyToChildren typeCondition directives' selections |> definitionRule definition' - | FragmentDefinition _ typeCondition directives' selections _ <- definition' + | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition' = applyToChildren typeCondition directives' selections where types' = Validation.types context applyToChildren typeCondition directives' selections - = selectionSet types' rule (lookupType' typeCondition) selections - >< directives rule directives' + = selectionSet context types' rule (lookupType' typeCondition) selections + >< directives context rule directives' lookupType' = flip lookupType types' lookupType :: forall m - . TypeCondition - -> HashMap Name (Schema.Type m) + . Full.TypeCondition + -> HashMap Full.Name (Schema.Type m) -> Maybe (Out.Type m) lookupType typeCondition types' = HashMap.lookup typeCondition types' >>= typeToOut -selectionSet :: Traversable t => forall m. ApplySelectionRule m (t Selection) -selectionSet types' rule = foldMap . selection types' rule +selectionSet :: Traversable t + => forall m + . Validation m + -> ApplySelectionRule m (t Full.Selection) +selectionSet context types' rule = foldMap . selection context types' rule -selection :: forall m. ApplySelectionRule m Selection -selection types' rule objectType selection' +selection :: forall m. Validation m -> ApplySelectionRule m Full.Selection +selection context types' rule objectType selection' | Validation.SelectionRule selectionRule <- rule = applyToChildren |> selectionRule objectType selection' | otherwise = applyToChildren where applyToChildren = case selection' of - FieldSelection field' -> field types' rule objectType field' - InlineFragmentSelection inlineFragment' -> - inlineFragment types' rule objectType inlineFragment' - FragmentSpreadSelection fragmentSpread' -> - fragmentSpread rule fragmentSpread' + Full.FieldSelection field' -> + field context types' rule objectType field' + Full.InlineFragmentSelection inlineFragment' -> + inlineFragment context types' rule objectType inlineFragment' + Full.FragmentSpreadSelection fragmentSpread' -> + fragmentSpread context rule fragmentSpread' -field :: forall m. ApplySelectionRule m Field -field types' rule objectType field' = go field' +field :: forall m. Validation m -> ApplySelectionRule m Full.Field +field context types' rule objectType field' = go field' where - go (Field _ fieldName _ _ _ _) + go (Full.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' + typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes 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' + let Full.Field _ _ arguments' directives' selections _ = field' + typeField = objectType >>= lookupTypeField fieldName + argumentTypes = maybe mempty typeFieldArguments typeField + in selectionSet context types' rule (typeFieldType <$> typeField) selections + >< directives context rule directives' + >< arguments rule argumentTypes arguments' -arguments :: forall m. ApplyRule m [Argument] -arguments = (.) Seq.fromList . fmap . argument - -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. ApplySelectionRule m InlineFragment -inlineFragment types' rule objectType inlineFragment' = go inlineFragment' +arguments :: forall m + . Validation.Rule m + -> In.Arguments + -> [Full.Argument] + -> Seq (Validation.RuleT m) +arguments rule argumentTypes = foldMap forEach . Seq.fromList where - go (InlineFragment optionalType directives' selections _) + forEach argument'@(Full.Argument argumentName _ _) = + let argumentType = HashMap.lookup argumentName argumentTypes + in argument rule argumentType argument' + +argument :: forall m + . Validation.Rule m + -> Maybe In.Argument + -> Full.Argument + -> Seq (Validation.RuleT m) +argument rule argumentType (Full.Argument _ value' _) = + value rule (valueType <$> argumentType) $ Full.value value' + where + valueType (In.Argument _ valueType' _) = valueType' + +value :: forall m + . Validation.Rule m + -> Maybe In.Type + -> Full.Value + -> Seq (Validation.RuleT m) +value (Validation.ValueRule rule _) valueType = go valueType + where + go inputObjectType value'@(Full.Object fields) + = foldMap (forEach inputObjectType) (Seq.fromList fields) + |> rule inputObjectType value' + go listType value'@(Full.List values) + = foldMap (go $ valueTypeFromList listType) (Seq.fromList values) + |> rule listType value' + go anotherValue value' = pure $ rule anotherValue value' + forEach inputObjectType (Full.ObjectField fieldName fieldValue _) = + go (valueTypeByName fieldName inputObjectType) fieldValue +value _ _ = const mempty + +inlineFragment :: forall m + . Validation m + -> ApplySelectionRule m Full.InlineFragment +inlineFragment context types' rule objectType inlineFragment' = + go inlineFragment' + where + go (Full.InlineFragment optionalType directives' selections _) | Validation.FragmentRule _ fragmentRule <- rule = applyToChildren (refineTarget optionalType) directives' selections |> fragmentRule inlineFragment' @@ -328,27 +423,35 @@ inlineFragment types' rule objectType inlineFragment' = go inlineFragment' refineTarget (Just typeCondition) = lookupType typeCondition types' refineTarget Nothing = objectType applyToChildren objectType' directives' selections - = selectionSet types' rule objectType' selections - >< directives rule directives' + = selectionSet context types' rule objectType' selections + >< directives context rule directives' -fragmentSpread :: forall m. ApplyRule m FragmentSpread -fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _) +fragmentSpread :: forall m. Validation m -> ApplyRule m Full.FragmentSpread +fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _) | Validation.FragmentSpreadRule fragmentRule <- rule = applyToChildren |> fragmentRule fragmentSpread' | otherwise = applyToChildren where - applyToChildren = directives rule directives' + applyToChildren = directives context rule directives' -directives :: Traversable t => forall m. ApplyRule m (t Directive) -directives rule directives' +directives :: Traversable t + => forall m + . Validation m + -> ApplyRule m (t Full.Directive) +directives context rule directives' | Validation.DirectivesRule directivesRule <- rule = applyToChildren |> directivesRule directiveList | otherwise = applyToChildren where directiveList = toList directives' - applyToChildren = foldMap (directive rule) directiveList + applyToChildren = foldMap (directive context rule) directiveList -directive :: forall m. ApplyRule m Directive -directive (Validation.ArgumentsRule _ argumentsRule) directive' = +directive :: forall m. Validation m -> ApplyRule m Full.Directive +directive _ (Validation.ArgumentsRule _ argumentsRule) directive' = pure $ argumentsRule directive' -directive rule (Directive _ arguments' _) = arguments rule arguments' +directive context rule (Full.Directive directiveName arguments' _) = + let argumentTypes = maybe HashMap.empty directiveArguments + $ HashMap.lookup directiveName (Validation.directives context) + in arguments rule argumentTypes arguments' + where + directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 6e550f8..7cfa712 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -17,6 +18,7 @@ module Language.GraphQL.Validate.Rules , loneAnonymousOperationRule , knownArgumentNamesRule , knownDirectiveNamesRule + , knownInputFieldNamesRule , noFragmentCyclesRule , noUndefinedVariablesRule , noUnusedFragmentsRule @@ -53,6 +55,7 @@ import qualified Data.Text as Text import Language.GraphQL.AST.Document import qualified Language.GraphQL.Type.Definition as Definition import Language.GraphQL.Type.Internal +import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Validate.Validation @@ -83,6 +86,7 @@ specifiedRules = , fragmentSpreadTargetDefinedRule , noFragmentCyclesRule -- Values + , knownInputFieldNamesRule , uniqueInputFieldNamesRule -- Directives. , knownDirectiveNamesRule @@ -98,19 +102,19 @@ specifiedRules = executableDefinitionsRule :: forall m. Rule m executableDefinitionsRule = DefinitionRule $ \case ExecutableDefinition _ -> lift mempty - TypeSystemDefinition _ location -> pure $ error' location - TypeSystemExtension _ location -> pure $ error' location + TypeSystemDefinition _ location' -> pure $ error' location' + TypeSystemExtension _ location' -> pure $ error' location' where - error' location = Error + error' location' = Error { message = "Definition must be OperationDefinition or FragmentDefinition." - , locations = [location] + , locations = [location'] } -- | Subscription operations must have exactly one root field. singleFieldSubscriptionsRule :: forall m. Rule m singleFieldSubscriptionsRule = OperationDefinitionRule $ \case - OperationDefinition Subscription name' _ _ rootFields location -> do + OperationDefinition Subscription name' _ _ rootFields location' -> do groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty case HashSet.size groupedFieldSet of 1 -> lift mempty @@ -121,11 +125,11 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case , Text.unpack name , "must select only one top level field." ] - , locations = [location] + , locations = [location'] } | otherwise -> pure $ Error { message = errorMessage - , locations = [location] + , locations = [location'] } _ -> lift mempty where @@ -203,10 +207,10 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case SelectionSet _ thatLocation | thisLocation /= thatLocation -> pure $ error' thisLocation _ -> mempty - error' location = Error + error' location' = Error { message = "This anonymous operation must be the only defined operation." - , locations = [location] + , locations = [location'] } -- | Each named operation definition must be unique within a document when @@ -283,12 +287,12 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case -- It is a validation error if the target of a spread is not defined. fragmentSpreadTargetDefinedRule :: forall m. Rule m fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case - FragmentSpread fragmentName _ location -> do + FragmentSpread fragmentName _ location' -> do ast' <- asks ast case find (isSpreadTarget fragmentName) ast' of Nothing -> pure $ Error { message = error' fragmentName - , locations = [location] + , locations = [location'] } Just _ -> lift mempty where @@ -310,7 +314,7 @@ isSpreadTarget _ _ = False fragmentSpreadTypeExistenceRule :: forall m. Rule m fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case FragmentSpreadSelection fragmentSelection - | FragmentSpread fragmentName _ location <- fragmentSelection -> do + | FragmentSpread fragmentName _ location' <- fragmentSelection -> do ast' <- asks ast let target = find (isSpreadTarget fragmentName) ast' typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition @@ -318,17 +322,17 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case case HashMap.lookup typeCondition types' of Nothing -> pure $ Error { message = spreadError fragmentName typeCondition - , locations = [location] + , locations = [location'] } Just _ -> lift mempty InlineFragmentSelection fragmentSelection - | InlineFragment maybeType _ _ location <- fragmentSelection + | InlineFragment maybeType _ _ location' <- fragmentSelection , Just typeCondition <- maybeType -> do types' <- asks types case HashMap.lookup typeCondition types' of Nothing -> pure $ Error { message = inlineError typeCondition - , locations = [location] + , locations = [location'] } Just _ -> lift mempty _ -> lift mempty @@ -360,19 +364,19 @@ maybeToSeq Nothing = mempty fragmentsOnCompositeTypesRule :: forall m. Rule m fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule where - inlineRule (InlineFragment (Just typeCondition) _ _ location) = - check typeCondition location + inlineRule (InlineFragment (Just typeCondition) _ _ location') = + check typeCondition location' inlineRule _ = lift mempty - definitionRule (FragmentDefinition _ typeCondition _ _ location) = - check typeCondition location - check typeCondition location = do + definitionRule (FragmentDefinition _ typeCondition _ _ location') = + check typeCondition location' + check typeCondition location' = do types' <- asks types -- Skip unknown types, they are checked by another rule. _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types' case lookupTypeCondition typeCondition types' of Nothing -> pure $ Error { message = errorMessage typeCondition - , locations = [location] + , locations = [location'] } Just _ -> lift mempty errorMessage typeCondition = concat @@ -384,19 +388,19 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule -- | Defined fragments must be used within a document. noUnusedFragmentsRule :: forall m. Rule m noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do - let FragmentDefinition fragmentName _ _ _ location = fragment - in mapReaderT (checkFragmentName fragmentName location) + let FragmentDefinition fragmentName _ _ _ location' = fragment + in mapReaderT (checkFragmentName fragmentName location') $ asks ast >>= flip evalStateT HashSet.empty . filterSelections evaluateSelection . foldMap definitionSelections where - checkFragmentName fragmentName location elements + checkFragmentName fragmentName location' elements | fragmentName `elem` elements = mempty - | otherwise = pure $ makeError fragmentName location - makeError fragName location = Error + | otherwise = pure $ makeError fragmentName location' + makeError fragName location' = Error { message = errorMessage fragName - , locations = [location] + , locations = [location'] } errorMessage fragName = concat [ "Fragment \"" @@ -440,7 +444,7 @@ filterSelections applyFilter selections -- on cycles in the underlying data. noFragmentCyclesRule :: forall m. Rule m noFragmentCyclesRule = FragmentDefinitionRule $ \case - FragmentDefinition fragmentName _ _ selections location -> do + FragmentDefinition fragmentName _ _ selections location' -> do state <- evalStateT (collectFields selections) (0, fragmentName) let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state) @@ -453,7 +457,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case , Text.unpack $ Text.intercalate " -> " $ fragmentName : spreadPath , ")." ] - , locations = [location] + , locations = [location'] } _ -> lift mempty where @@ -502,7 +506,7 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule lift $ filterDuplicates extract "argument" arguments directiveRule (Directive _ arguments _) = lift $ filterDuplicates extract "argument" arguments - extract (Argument argumentName _ location) = (argumentName, location) + extract (Argument argumentName _ location') = (argumentName, location') -- | Directives are used to describe some metadata or behavioral change on the -- definition they apply to. When more than one directive of the same name is @@ -512,7 +516,7 @@ uniqueDirectiveNamesRule :: forall m. Rule m uniqueDirectiveNamesRule = DirectivesRule $ lift . filterDuplicates extract "directive" where - extract (Directive directiveName _ location) = (directiveName, location) + extract (Directive directiveName _ location') = (directiveName, location') filterDuplicates :: (a -> (Text, Location)) -> String -> [a] -> Seq Error filterDuplicates extract nodeType = Seq.fromList @@ -542,8 +546,8 @@ uniqueVariableNamesRule :: forall m. Rule m uniqueVariableNamesRule = VariablesRule $ lift . filterDuplicates extract "variable" where - extract (VariableDefinition variableName _ _ location) = - (variableName, location) + extract (VariableDefinition variableName _ _ location') = + (variableName, location') -- | Variables can only be input types. Objects, unions and interfaces cannot be -- used as inputs. @@ -551,12 +555,12 @@ variablesAreInputTypesRule :: forall m. Rule m variablesAreInputTypesRule = VariablesRule $ (traverse check . Seq.fromList) >=> lift where - check (VariableDefinition name typeName _ location) + check (VariableDefinition name typeName _ location') = asks types >>= lift - . maybe (makeError name typeName location) (const mempty) + . maybe (makeError name typeName location') (const mempty) . lookupInputType typeName - makeError name typeName location = pure $ Error + makeError name typeName location' = pure $ Error { message = concat [ "Variable \"$" , Text.unpack name @@ -564,7 +568,7 @@ variablesAreInputTypesRule = VariablesRule , Text.unpack $ getTypeName typeName , "\"." ] - , locations = [location] + , locations = [location'] } getTypeName (TypeNamed name) = name getTypeName (TypeList name) = getTypeName name @@ -610,8 +614,8 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas . difference variableNames' . HashMap.fromListWith (++) . toList - getVariableName (VariableDefinition variableName _ _ location) = - (variableName, [location]) + getVariableName (VariableDefinition variableName _ _ location') = + (variableName, [location']) filterSelections' :: Foldable t => t Selection -> ValidationState m (Name, [Location]) @@ -638,8 +642,8 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas findDirectiveVariables (Directive _ arguments _) = mapArguments arguments mapArguments = Seq.fromList . mapMaybe findArgumentVariables mapDirectives = foldMap findDirectiveVariables - findArgumentVariables (Argument _ (Node (Variable value) location) _) = - Just (value, [location]) + findArgumentVariables (Argument _ Node{ value = Variable value', ..} _) = + Just (value', [location]) findArgumentVariables _ = Nothing makeError operationName (variableName, locations') = Error { message = errorMessage operationName variableName @@ -669,19 +673,15 @@ noUnusedVariablesRule = variableUsageDifference HashMap.difference errorMessage -- otherwise an ambiguity would exist which includes an ignored portion of -- syntax. uniqueInputFieldNamesRule :: forall m. Rule m -uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo) +uniqueInputFieldNamesRule = + ValueRule (const $ lift . go) (const $ lift . constGo) where - go (Object fields) = foldMap (objectField go) fields - <> filterFieldDuplicates fields - go (List values) = foldMap go values + go (Object fields) = filterFieldDuplicates fields go _ = mempty - objectField go' (ObjectField _ fieldValue _) = go' fieldValue filterFieldDuplicates fields = filterDuplicates getFieldName "input field" fields - getFieldName (ObjectField fieldName _ location) = (fieldName, location) - constGo (ConstObject fields) = foldMap (objectField constGo) fields - <> filterFieldDuplicates fields - constGo (ConstList values) = foldMap constGo values + getFieldName (ObjectField fieldName _ location') = (fieldName, location') + constGo (ConstObject fields) = filterFieldDuplicates fields constGo _ = mempty -- | The target field of a field selection must be defined on the scoped type of @@ -689,12 +689,12 @@ uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo) fieldsOnCorrectTypeRule :: forall m. Rule m fieldsOnCorrectTypeRule = FieldRule fieldRule where - fieldRule parentType (Field _ fieldName _ _ _ location) + fieldRule parentType (Field _ fieldName _ _ _ location') | Just objectType <- parentType , Nothing <- lookupTypeField fieldName objectType , Just typeName <- compositeTypeName objectType = pure $ Error { message = errorMessage fieldName typeName - , locations = [location] + , locations = [location'] } | otherwise = lift mempty errorMessage fieldName typeName = concat @@ -742,9 +742,9 @@ scalarLeafsRule = FieldRule fieldRule check (Out.EnumBaseType (Definition.EnumType typeName _ _)) = checkEmpty typeName check (Out.ListBaseType wrappedType) = check wrappedType - checkNotEmpty typeName (Field _ fieldName _ _ [] location) = + checkNotEmpty typeName (Field _ fieldName _ _ [] location') = let fieldName' = Text.unpack fieldName - in makeError location $ concat + in makeError location' $ concat [ "Field \"" , fieldName' , "\" of type \"" @@ -756,17 +756,17 @@ scalarLeafsRule = FieldRule fieldRule checkNotEmpty _ _ = mempty checkEmpty _ (Field _ _ _ _ [] _) = mempty checkEmpty typeName field' = - let Field _ fieldName _ _ _ location = field' - in makeError location $ concat + let Field _ fieldName _ _ _ location' = field' + in makeError location' $ concat [ "Field \"" , Text.unpack fieldName , "\" must not have a selection since type \"" , Text.unpack typeName , "\" has no subfields." ] - makeError location errorMessage = pure $ Error + makeError location' errorMessage = pure $ Error { message = errorMessage - , locations = [location] + , locations = [location'] } -- | Every argument provided to a field or directive must be defined in the set @@ -779,12 +779,12 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule , Just typeName <- compositeTypeName objectType = lift $ foldr (go typeName fieldName typeField) Seq.empty arguments fieldRule _ _ = lift mempty - go typeName fieldName fieldDefinition (Argument argumentName _ location) errors + 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] + , locations = [location'] } fieldMessage argumentName fieldName typeName = concat [ "Unknown argument \"" @@ -797,15 +797,15 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule ] directiveRule (Directive directiveName arguments _) = do available <- asks $ HashMap.lookup directiveName . directives - Argument argumentName _ location <- lift $ Seq.fromList arguments + Argument argumentName _ location' <- lift $ Seq.fromList arguments case available of Just (Schema.Directive _ _ definitions) | not $ HashMap.member argumentName definitions -> - pure $ makeError argumentName directiveName location + pure $ makeError argumentName directiveName location' _ -> lift mempty - makeError argumentName directiveName location = Error + makeError argumentName directiveName location' = Error { message = directiveMessage argumentName directiveName - , locations = [location] + , locations = [location'] } directiveMessage argumentName directiveName = concat [ "Unknown argument \"" @@ -829,12 +829,41 @@ knownDirectiveNamesRule = DirectivesRule $ \directives' -> do definitionFilter difference = flip HashSet.member difference . directiveName directiveName (Directive directiveName' _ _) = directiveName' - makeError (Directive directiveName' _ location) = Error + makeError (Directive directiveName' _ location') = Error { message = errorMessage directiveName' - , locations = [location] + , locations = [location'] } errorMessage directiveName' = concat [ "Unknown directive \"@" , Text.unpack directiveName' , "\"." ] + +-- | Every input field provided in an input object value must be defined in the +-- set of possible fields of that input object’s expected type. +knownInputFieldNamesRule :: Rule m +knownInputFieldNamesRule = ValueRule go constGo + where + go (Just valueType) (Object inputFields) + | In.InputObjectBaseType objectType <- valueType = + lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields + go _ _ = lift mempty + constGo (Just valueType) (ConstObject inputFields) + | In.InputObjectBaseType objectType <- valueType = + lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields + constGo _ _ = lift mempty + forEach objectType (ObjectField inputFieldName _ location') + | In.InputObjectType _ _ fieldTypes <- objectType + , Just _ <- HashMap.lookup inputFieldName fieldTypes = Nothing + | otherwise + , In.InputObjectType typeName _ _ <- objectType = pure $ Error + { message = errorMessage inputFieldName typeName + , locations = [location'] + } + errorMessage fieldName typeName = concat + [ "Field \"" + , Text.unpack fieldName + , "\" is not defined by type \"" + , Text.unpack typeName + , "\"." + ] diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index ae39e58..0e9f1a8 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -14,6 +14,7 @@ import Control.Monad.Trans.Reader (ReaderT) import Data.HashMap.Strict (HashMap) import Data.Sequence (Seq) import Language.GraphQL.AST.Document +import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema (Schema) import qualified Language.GraphQL.Type.Schema as Schema @@ -46,7 +47,7 @@ data Rule 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) + | ValueRule (Maybe In.Type -> Value -> RuleT m) (Maybe In.Type -> ConstValue -> RuleT m) -- | Monad transformer used by the rules. type RuleT m = ReaderT (Validation m) Seq Error diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs index d189679..0c7dd39 100644 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -4,7 +4,7 @@ module Language.GraphQL.AST.EncoderSpec ( spec ) where -import Language.GraphQL.AST +import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.Encoder import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain) import Test.QuickCheck (choose, oneof, forAll) @@ -15,52 +15,52 @@ spec :: Spec spec = do describe "value" $ do context "null value" $ do - let testNull formatter = value formatter Null `shouldBe` "null" + let testNull formatter = value formatter Full.Null `shouldBe` "null" it "minified" $ testNull minified it "pretty" $ testNull pretty context "minified" $ do it "escapes \\" $ - value minified (String "\\") `shouldBe` "\"\\\\\"" + value minified (Full.String "\\") `shouldBe` "\"\\\\\"" it "escapes double quotes" $ - value minified (String "\"") `shouldBe` "\"\\\"\"" + value minified (Full.String "\"") `shouldBe` "\"\\\"\"" it "escapes \\f" $ - value minified (String "\f") `shouldBe` "\"\\f\"" + value minified (Full.String "\f") `shouldBe` "\"\\f\"" it "escapes \\n" $ - value minified (String "\n") `shouldBe` "\"\\n\"" + value minified (Full.String "\n") `shouldBe` "\"\\n\"" it "escapes \\r" $ - value minified (String "\r") `shouldBe` "\"\\r\"" + value minified (Full.String "\r") `shouldBe` "\"\\r\"" it "escapes \\t" $ - value minified (String "\t") `shouldBe` "\"\\t\"" + value minified (Full.String "\t") `shouldBe` "\"\\t\"" it "escapes backspace" $ - value minified (String "a\bc") `shouldBe` "\"a\\bc\"" + value minified (Full.String "a\bc") `shouldBe` "\"a\\bc\"" context "escapes Unicode for chars less than 0010" $ do - it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\"" - it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\"" + it "Null" $ value minified (Full.String "\x0000") `shouldBe` "\"\\u0000\"" + it "bell" $ value minified (Full.String "\x0007") `shouldBe` "\"\\u0007\"" context "escapes Unicode for char less than 0020" $ do - it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\"" - it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\"" + it "DLE" $ value minified (Full.String "\x0010") `shouldBe` "\"\\u0010\"" + it "EM" $ value minified (Full.String "\x0019") `shouldBe` "\"\\u0019\"" context "encodes without escape" $ do - it "space" $ value minified (String "\x0020") `shouldBe` "\" \"" - it "~" $ value minified (String "\x007E") `shouldBe` "\"~\"" + it "space" $ value minified (Full.String "\x0020") `shouldBe` "\" \"" + it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\"" context "pretty" $ do it "uses strings for short string values" $ - value pretty (String "Short text") `shouldBe` "\"Short text\"" + value pretty (Full.String "Short text") `shouldBe` "\"Short text\"" it "uses block strings for text with new lines, with newline symbol" $ - value pretty (String "Line 1\nLine 2") + value pretty (Full.String "Line 1\nLine 2") `shouldBe` [r|""" Line 1 Line 2 """|] it "uses block strings for text with new lines, with CR symbol" $ - value pretty (String "Line 1\rLine 2") + value pretty (Full.String "Line 1\rLine 2") `shouldBe` [r|""" Line 1 Line 2 """|] it "uses block strings for text with new lines, with CR symbol followed by newline" $ - value pretty (String "Line 1\r\nLine 2") + value pretty (Full.String "Line 1\r\nLine 2") `shouldBe` [r|""" Line 1 Line 2 @@ -77,12 +77,12 @@ spec = do forAll genNotAllowedSymbol $ \x -> do let rawValue = "Short \n" <> cons x "text" - encoded = value pretty (String $ toStrict rawValue) + encoded = value pretty (Full.String $ toStrict rawValue) shouldStartWith (unpack encoded) "\"" shouldEndWith (unpack encoded) "\"" shouldNotContain (unpack encoded) "\"\"\"" - it "Hello world" $ value pretty (String "Hello,\n World!\n\nYours,\n GraphQL.") + it "Hello world" $ value pretty (Full.String "Hello,\n World!\n\nYours,\n GraphQL.") `shouldBe` [r|""" Hello, World! @@ -91,29 +91,29 @@ spec = do GraphQL. """|] - it "has only newlines" $ value pretty (String "\n") `shouldBe` [r|""" + it "has only newlines" $ value pretty (Full.String "\n") `shouldBe` [r|""" """|] it "has newlines and one symbol at the begining" $ - value pretty (String "a\n\n") `shouldBe` [r|""" + value pretty (Full.String "a\n\n") `shouldBe` [r|""" a """|] it "has newlines and one symbol at the end" $ - value pretty (String "\n\na") `shouldBe` [r|""" + value pretty (Full.String "\n\na") `shouldBe` [r|""" a """|] it "has newlines and one symbol in the middle" $ - value pretty (String "\na\n") `shouldBe` [r|""" + value pretty (Full.String "\na\n") `shouldBe` [r|""" a """|] - it "skip trailing whitespaces" $ value pretty (String " Short\ntext ") + it "skip trailing whitespaces" $ value pretty (Full.String " Short\ntext ") `shouldBe` [r|""" Short text @@ -121,12 +121,13 @@ spec = do describe "definition" $ it "indents block strings in arguments" $ - let location = Location 0 0 - argumentValue = Node (String "line1\nline2") location - arguments = [Argument "message" argumentValue location] - field = Field Nothing "field" arguments [] [] location - operation = DefinitionOperation - $ SelectionSet (pure $ FieldSelection field) location + let location = Full.Location 0 0 + argumentValue = Full.Node (Full.String "line1\nline2") location + arguments = [Full.Argument "message" argumentValue location] + field = Full.Field Nothing "field" arguments [] [] location + fieldSelection = pure $ Full.FieldSelection field + operation = Full.DefinitionOperation + $ Full.SelectionSet fieldSelection location in definition pretty operation `shouldBe` [r|{ field(message: """ line1 diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index fd53145..b4433ca 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -590,3 +590,19 @@ spec = , locations = [AST.Location 4 54] } in validate queryString `shouldBe` [expected] + + it "rejects undefined input object fields" $ + let queryString = [r| + { + findDog(complex: { favoriteCookieFlavor: "Bacon" }) { + name + } + } + |] + expected = Error + { message = + "Field \"favoriteCookieFlavor\" is not defined \ + \by type \"DogData\"." + , locations = [AST.Location 3 36] + } + in validate queryString `shouldBe` [expected]