prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Validate input object field names

Browse Source
This commit is contained in:
Eugen Wissner 2020-09-30 05:14:52 +02:00
parent 466416d4b0
commit 56b63f1c3e
9 changed files with 640 additions and 478 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/Language/GraphQL/AST/Document.hs
View File

@ -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

167
src/Language/GraphQL/AST/Encoder.hs
View File

@ -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.
node :: Formatter ->
Maybe Name ->
[VariableDefinition] ->
[Directive] ->
SelectionSet ->
root :: Maybe Full.Name ->
[Full.VariableDefinition] ->
[Full.Directive] ->
Full.SelectionSet ->
Lazy.Text
node formatter name vars dirs sels
root 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

303
src/Language/GraphQL/AST/Parser.hs
View File

@ -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

2
src/Language/GraphQL/Execute/Transform.hs
View File

@ -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

375
src/Language/GraphQL/Validate.hs
View File

@ -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

161
src/Language/GraphQL/Validate/Rules.hs
View File

@ -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
, "\"."
]

3
src/Language/GraphQL/Validate/Validation.hs
View File

@ -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

65
tests/Language/GraphQL/AST/EncoderSpec.hs
View File

@ -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

16
tests/Language/GraphQL/ValidateSpec.hs
View File

@ -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]