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 #-} {-# LANGUAGE OverloadedStrings #-}
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It -- | This module defines an abstract syntax tree for the @GraphQL@ language. It
@ -72,7 +73,10 @@ instance Ord Location where
| otherwise = compare thisColumn thatColumn | otherwise = compare thisColumn thatColumn
-- | Contains some tree node with a location. -- | 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 -- ** 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 -- Variables are usually passed along with the query, but not in the query
-- itself. They make queries reusable. -- itself. They make queries reusable.
data VariableDefinition = data VariableDefinition =
VariableDefinition Name Type (Maybe ConstValue) Location VariableDefinition Name Type (Maybe (Node ConstValue)) Location
deriving (Eq, Show) deriving (Eq, Show)
-- ** Type References -- ** Type References
@ -484,8 +488,8 @@ instance Monoid ArgumentsDefinition where
-- @ -- @
-- --
-- The input type "Point2D" contains two value definitions: "x" and "y". -- The input type "Point2D" contains two value definitions: "x" and "y".
data InputValueDefinition data InputValueDefinition = InputValueDefinition
= InputValueDefinition Description Name Type (Maybe ConstValue) [Directive] Description Name Type (Maybe (Node ConstValue)) [Directive]
deriving (Eq, Show) deriving (Eq, Show)
-- ** Unions -- ** Unions

169
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 qualified Data.Text.Lazy.Builder as Builder
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat) 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 -- | Instructs the encoder whether the GraphQL document should be minified or
-- pretty printed. -- pretty printed.
@ -44,77 +44,78 @@ minified :: Formatter
minified = Minified minified = Minified
-- | Converts a Document' into a string. -- | Converts a Document' into a string.
document :: Formatter -> Document -> Lazy.Text document :: Formatter -> Full.Document -> Lazy.Text
document formatter defs document formatter defs
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n' | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
where where
encodeDocument = foldr executableDefinition [] defs encodeDocument = foldr executableDefinition [] defs
executableDefinition (ExecutableDefinition executableDefinition') acc = executableDefinition (Full.ExecutableDefinition executableDefinition') acc =
definition formatter executableDefinition' : acc definition formatter executableDefinition' : acc
executableDefinition _ acc = acc executableDefinition _ acc = acc
-- | Converts a t'ExecutableDefinition' into a string. -- | Converts a t'ExecutableDefinition' into a string.
definition :: Formatter -> ExecutableDefinition -> Lazy.Text definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
definition formatter x definition formatter x
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n' | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
| Minified <- formatter = encodeDefinition x | Minified <- formatter = encodeDefinition x
where where
encodeDefinition (DefinitionOperation operation) encodeDefinition (Full.DefinitionOperation operation)
= operationDefinition formatter operation = operationDefinition formatter operation
encodeDefinition (DefinitionFragment fragment) encodeDefinition (Full.DefinitionFragment fragment)
= fragmentDefinition formatter fragment = fragmentDefinition formatter fragment
-- | Converts a 'OperationDefinition into a string. -- | Converts a 'OperationDefinition into a string.
operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
operationDefinition formatter = \case operationDefinition formatter = \case
SelectionSet sels _ -> selectionSet formatter sels Full.SelectionSet sels _ -> selectionSet formatter sels
OperationDefinition Query name vars dirs sels _ -> Full.OperationDefinition Full.Query name vars dirs sels _ ->
"query " <> node formatter name vars dirs sels "query " <> root name vars dirs sels
OperationDefinition Mutation name vars dirs sels _ -> Full.OperationDefinition Full.Mutation name vars dirs sels _ ->
"mutation " <> node formatter name vars dirs sels "mutation " <> root name vars dirs sels
OperationDefinition Subscription name vars dirs sels _ -> Full.OperationDefinition Full.Subscription name vars dirs sels _ ->
"subscription " <> node formatter name vars dirs sels "subscription " <> root name vars dirs sels
where
-- | Converts a Query or Mutation into a string. -- | Converts a Query or Mutation into a string.
node :: Formatter -> root :: Maybe Full.Name ->
Maybe Name -> [Full.VariableDefinition] ->
[VariableDefinition] -> [Full.Directive] ->
[Directive] -> Full.SelectionSet ->
SelectionSet ->
Lazy.Text Lazy.Text
node formatter name vars dirs sels root name vars dirs sels
= Lazy.Text.fromStrict (fold name) = Lazy.Text.fromStrict (fold name)
<> optempty (variableDefinitions formatter) vars <> optempty (variableDefinitions formatter) vars
<> optempty (directives formatter) dirs <> optempty (directives formatter) dirs
<> eitherFormat formatter " " mempty <> eitherFormat formatter " " mempty
<> selectionSet formatter sels <> selectionSet formatter sels
variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
variableDefinitions formatter variableDefinitions formatter
= parensCommas formatter $ variableDefinition formatter = parensCommas formatter $ variableDefinition formatter
variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
variableDefinition formatter (VariableDefinition var ty defaultValue' _) variableDefinition formatter variableDefinition' =
= variable var let Full.VariableDefinition variableName variableType defaultValue' _ =
variableDefinition'
in variable variableName
<> eitherFormat formatter ": " ":" <> eitherFormat formatter ": " ":"
<> type' ty <> type' variableType
<> maybe mempty (defaultValue formatter) defaultValue' <> maybe mempty (defaultValue formatter) (Full.value <$> defaultValue')
defaultValue :: Formatter -> ConstValue -> Lazy.Text defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text
defaultValue formatter val defaultValue formatter val
= eitherFormat formatter " = " "=" = eitherFormat formatter " = " "="
<> value formatter (fromConstValue val) <> value formatter (fromConstValue val)
variable :: Name -> Lazy.Text variable :: Full.Name -> Lazy.Text
variable var = "$" <> Lazy.Text.fromStrict var variable var = "$" <> Lazy.Text.fromStrict var
selectionSet :: Formatter -> SelectionSet -> Lazy.Text selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
selectionSet formatter selectionSet formatter
= bracesList formatter (selection formatter) = bracesList formatter (selection formatter)
. NonEmpty.toList . NonEmpty.toList
selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
selectionSetOpt formatter = bracesList formatter $ selection formatter selectionSetOpt formatter = bracesList formatter $ selection formatter
indentSymbol :: Lazy.Text indentSymbol :: Lazy.Text
@ -123,14 +124,14 @@ indentSymbol = " "
indent :: (Integral a) => a -> Lazy.Text indent :: (Integral a) => a -> Lazy.Text
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol 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 selection formatter = Lazy.Text.append indent' . encodeSelection
where where
encodeSelection (FieldSelection fieldSelection) = encodeSelection (Full.FieldSelection fieldSelection) =
field incrementIndent fieldSelection field incrementIndent fieldSelection
encodeSelection (InlineFragmentSelection fragmentSelection) = encodeSelection (Full.InlineFragmentSelection fragmentSelection) =
inlineFragment incrementIndent fragmentSelection inlineFragment incrementIndent fragmentSelection
encodeSelection (FragmentSpreadSelection fragmentSelection) = encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =
fragmentSpread incrementIndent fragmentSelection fragmentSpread incrementIndent fragmentSelection
incrementIndent incrementIndent
| Pretty indentation <- formatter = Pretty $ indentation + 1 | Pretty indentation <- formatter = Pretty $ indentation + 1
@ -143,8 +144,8 @@ colon :: Formatter -> Lazy.Text
colon formatter = eitherFormat formatter ": " ":" colon formatter = eitherFormat formatter ": " ":"
-- | Converts Field into a string. -- | Converts Field into a string.
field :: Formatter -> Field -> Lazy.Text field :: Formatter -> Full.Field -> Lazy.Text
field formatter (Field alias name args dirs set _) field formatter (Full.Field alias name args dirs set _)
= optempty prependAlias (fold alias) = optempty prependAlias (fold alias)
<> Lazy.Text.fromStrict name <> Lazy.Text.fromStrict name
<> optempty (arguments formatter) args <> optempty (arguments formatter) args
@ -155,32 +156,32 @@ field formatter (Field alias name args dirs set _)
selectionSetOpt' = (eitherFormat formatter " " "" <>) selectionSetOpt' = (eitherFormat formatter " " "" <>)
. selectionSetOpt formatter . selectionSetOpt formatter
arguments :: Formatter -> [Argument] -> Lazy.Text arguments :: Formatter -> [Full.Argument] -> Lazy.Text
arguments formatter = parensCommas formatter $ argument formatter arguments formatter = parensCommas formatter $ argument formatter
argument :: Formatter -> Argument -> Lazy.Text argument :: Formatter -> Full.Argument -> Lazy.Text
argument formatter (Argument name (Node value' _) _) argument formatter (Full.Argument name value' _)
= Lazy.Text.fromStrict name = Lazy.Text.fromStrict name
<> colon formatter <> colon formatter
<> value formatter value' <> value formatter (Full.value value')
-- * Fragments -- * Fragments
fragmentSpread :: Formatter -> FragmentSpread -> Lazy.Text fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
fragmentSpread formatter (FragmentSpread name directives' _) fragmentSpread formatter (Full.FragmentSpread name directives' _)
= "..." <> Lazy.Text.fromStrict name = "..." <> Lazy.Text.fromStrict name
<> optempty (directives formatter) directives' <> optempty (directives formatter) directives'
inlineFragment :: Formatter -> InlineFragment -> Lazy.Text inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
inlineFragment formatter (InlineFragment typeCondition directives' selections _) inlineFragment formatter (Full.InlineFragment typeCondition directives' selections _)
= "... on " = "... on "
<> Lazy.Text.fromStrict (fold typeCondition) <> Lazy.Text.fromStrict (fold typeCondition)
<> directives formatter directives' <> directives formatter directives'
<> eitherFormat formatter " " mempty <> eitherFormat formatter " " mempty
<> selectionSet formatter selections <> selectionSet formatter selections
fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
fragmentDefinition formatter (FragmentDefinition name tc dirs sels _) fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels _)
= "fragment " <> Lazy.Text.fromStrict name = "fragment " <> Lazy.Text.fromStrict name
<> " on " <> Lazy.Text.fromStrict tc <> " on " <> Lazy.Text.fromStrict tc
<> optempty (directives formatter) dirs <> optempty (directives formatter) dirs
@ -190,38 +191,38 @@ fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
-- * Miscellaneous -- * Miscellaneous
-- | Converts a 'Directive' into a string. -- | Converts a 'Directive' into a string.
directive :: Formatter -> Directive -> Lazy.Text directive :: Formatter -> Full.Directive -> Lazy.Text
directive formatter (Directive name args _) directive formatter (Full.Directive name args _)
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) 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 Minified = spaces (directive Minified)
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter) directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
-- | Converts a 'Value' into a string. -- | Converts a 'Value' into a string.
value :: Formatter -> Value -> Lazy.Text value :: Formatter -> Full.Value -> Lazy.Text
value _ (Variable x) = variable x value _ (Full.Variable x) = variable x
value _ (Int x) = Builder.toLazyText $ decimal x value _ (Full.Int x) = Builder.toLazyText $ decimal x
value _ (Float x) = Builder.toLazyText $ realFloat x value _ (Full.Float x) = Builder.toLazyText $ realFloat x
value _ (Boolean x) = booleanValue x value _ (Full.Boolean x) = booleanValue x
value _ Null = "null" value _ Full.Null = "null"
value formatter (String string) = stringValue formatter string value formatter (Full.String string) = stringValue formatter string
value _ (Enum x) = Lazy.Text.fromStrict x value _ (Full.Enum x) = Lazy.Text.fromStrict x
value formatter (List x) = listValue formatter x value formatter (Full.List x) = listValue formatter x
value formatter (Object x) = objectValue formatter x value formatter (Full.Object x) = objectValue formatter x
fromConstValue :: ConstValue -> Value fromConstValue :: Full.ConstValue -> Full.Value
fromConstValue (ConstInt x) = Int x fromConstValue (Full.ConstInt x) = Full.Int x
fromConstValue (ConstFloat x) = Float x fromConstValue (Full.ConstFloat x) = Full.Float x
fromConstValue (ConstBoolean x) = Boolean x fromConstValue (Full.ConstBoolean x) = Full.Boolean x
fromConstValue ConstNull = Null fromConstValue Full.ConstNull = Full.Null
fromConstValue (ConstString string) = String string fromConstValue (Full.ConstString string) = Full.String string
fromConstValue (ConstEnum x) = Enum x fromConstValue (Full.ConstEnum x) = Full.Enum x
fromConstValue (ConstList x) = List $ fromConstValue <$> x fromConstValue (Full.ConstList x) = Full.List $ fromConstValue <$> x
fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x
where where
fromConstObjectField (ObjectField key value' location) = fromConstObjectField (Full.ObjectField key value' location) =
ObjectField key (fromConstValue value') location Full.ObjectField key (fromConstValue value') location
booleanValue :: Bool -> Lazy.Text booleanValue :: Bool -> Lazy.Text
booleanValue True = "true" booleanValue True = "true"
@ -278,10 +279,10 @@ escape char'
where where
unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord) 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 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 objectValue formatter = intercalate $ objectField formatter
where where
intercalate f intercalate f
@ -289,22 +290,22 @@ objectValue formatter = intercalate $ objectField formatter
. Lazy.Text.intercalate (eitherFormat formatter ", " ",") . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
. fmap f . fmap f
objectField :: Formatter -> ObjectField Value -> Lazy.Text objectField :: Formatter -> Full.ObjectField Full.Value -> Lazy.Text
objectField formatter (ObjectField name value' _) = objectField formatter (Full.ObjectField name value' _) =
Lazy.Text.fromStrict name <> colon formatter <> value formatter value' Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
-- | Converts a 'Type' a type into a string. -- | Converts a 'Type' a type into a string.
type' :: Type -> Lazy.Text type' :: Full.Type -> Lazy.Text
type' (TypeNamed x) = Lazy.Text.fromStrict x type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
type' (TypeList x) = listType x type' (Full.TypeList x) = listType x
type' (TypeNonNull x) = nonNullType x type' (Full.TypeNonNull x) = nonNullType x
listType :: Type -> Lazy.Text listType :: Full.Type -> Lazy.Text
listType x = brackets (type' x) listType x = brackets (type' x)
nonNullType :: NonNullType -> Lazy.Text nonNullType :: Full.NonNullType -> Lazy.Text
nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!" nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
nonNullType (NonNullTypeList x) = listType x <> "!" nonNullType (Full.NonNullTypeList x) = listType x <> "!"
-- * Internal -- * Internal

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

@ -1,3 +1,4 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -18,7 +19,7 @@ import Language.GraphQL.AST.DirectiveLocation
, ExecutableDirectiveLocation , ExecutableDirectiveLocation
, TypeSystemDirectiveLocation , TypeSystemDirectiveLocation
) )
import Language.GraphQL.AST.Document import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.AST.Lexer import Language.GraphQL.AST.Lexer
import Text.Megaparsec import Text.Megaparsec
( MonadParsec(..) ( MonadParsec(..)
@ -32,13 +33,13 @@ import Text.Megaparsec
) )
-- | Parser for the GraphQL documents. -- | Parser for the GraphQL documents.
document :: Parser Document document :: Parser Full.Document
document = unicodeBOM document = unicodeBOM
*> spaceConsumer *> spaceConsumer
*> lexeme (NonEmpty.some definition) *> lexeme (NonEmpty.some definition)
definition :: Parser Definition definition :: Parser Full.Definition
definition = ExecutableDefinition <$> executableDefinition definition = Full.ExecutableDefinition <$> executableDefinition
<|> typeSystemDefinition' <|> typeSystemDefinition'
<|> typeSystemExtension' <|> typeSystemExtension'
<?> "Definition" <?> "Definition"
@ -46,41 +47,41 @@ definition = ExecutableDefinition <$> executableDefinition
typeSystemDefinition' = do typeSystemDefinition' = do
location <- getLocation location <- getLocation
definition' <- typeSystemDefinition definition' <- typeSystemDefinition
pure $ TypeSystemDefinition definition' location pure $ Full.TypeSystemDefinition definition' location
typeSystemExtension' = do typeSystemExtension' = do
location <- getLocation location <- getLocation
definition' <- typeSystemExtension definition' <- typeSystemExtension
pure $ TypeSystemExtension definition' location pure $ Full.TypeSystemExtension definition' location
getLocation :: Parser Location getLocation :: Parser Full.Location
getLocation = fromSourcePosition <$> getSourcePos getLocation = fromSourcePosition <$> getSourcePos
where where
fromSourcePosition SourcePos{..} = fromSourcePosition SourcePos{..} =
Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn) Full.Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
wordFromPosition = fromIntegral . unPos wordFromPosition = fromIntegral . unPos
executableDefinition :: Parser ExecutableDefinition executableDefinition :: Parser Full.ExecutableDefinition
executableDefinition = DefinitionOperation <$> operationDefinition executableDefinition = Full.DefinitionOperation <$> operationDefinition
<|> DefinitionFragment <$> fragmentDefinition <|> Full.DefinitionFragment <$> fragmentDefinition
<?> "ExecutableDefinition" <?> "ExecutableDefinition"
typeSystemDefinition :: Parser TypeSystemDefinition typeSystemDefinition :: Parser Full.TypeSystemDefinition
typeSystemDefinition = schemaDefinition typeSystemDefinition = schemaDefinition
<|> typeSystemDefinitionWithDescription <|> typeSystemDefinitionWithDescription
<?> "TypeSystemDefinition" <?> "TypeSystemDefinition"
where where
typeSystemDefinitionWithDescription = description typeSystemDefinitionWithDescription = description
>>= liftA2 (<|>) typeDefinition' directiveDefinition >>= liftA2 (<|>) typeDefinition' directiveDefinition
typeDefinition' description' = TypeDefinition typeDefinition' description' = Full.TypeDefinition
<$> typeDefinition description' <$> typeDefinition description'
typeSystemExtension :: Parser TypeSystemExtension typeSystemExtension :: Parser Full.TypeSystemExtension
typeSystemExtension = SchemaExtension <$> schemaExtension typeSystemExtension = Full.SchemaExtension <$> schemaExtension
<|> TypeExtension <$> typeExtension <|> Full.TypeExtension <$> typeExtension
<?> "TypeSystemExtension" <?> "TypeSystemExtension"
directiveDefinition :: Description -> Parser TypeSystemDefinition directiveDefinition :: Full.Description -> Parser Full.TypeSystemDefinition
directiveDefinition description' = DirectiveDefinition description' directiveDefinition description' = Full.DirectiveDefinition description'
<$ symbol "directive" <$ symbol "directive"
<* at <* at
<*> name <*> name
@ -124,7 +125,7 @@ typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
<|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION" <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
<?> "TypeSystemDirectiveLocation" <?> "TypeSystemDirectiveLocation"
typeDefinition :: Description -> Parser TypeDefinition typeDefinition :: Full.Description -> Parser Full.TypeDefinition
typeDefinition description' = scalarTypeDefinition description' typeDefinition description' = scalarTypeDefinition description'
<|> objectTypeDefinition description' <|> objectTypeDefinition description'
<|> interfaceTypeDefinition description' <|> interfaceTypeDefinition description'
@ -133,7 +134,7 @@ typeDefinition description' = scalarTypeDefinition description'
<|> inputObjectTypeDefinition description' <|> inputObjectTypeDefinition description'
<?> "TypeDefinition" <?> "TypeDefinition"
typeExtension :: Parser TypeExtension typeExtension :: Parser Full.TypeExtension
typeExtension = scalarTypeExtension typeExtension = scalarTypeExtension
<|> objectTypeExtension <|> objectTypeExtension
<|> interfaceTypeExtension <|> interfaceTypeExtension
@ -142,143 +143,143 @@ typeExtension = scalarTypeExtension
<|> inputObjectTypeExtension <|> inputObjectTypeExtension
<?> "TypeExtension" <?> "TypeExtension"
scalarTypeDefinition :: Description -> Parser TypeDefinition scalarTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
scalarTypeDefinition description' = ScalarTypeDefinition description' scalarTypeDefinition description' = Full.ScalarTypeDefinition description'
<$ symbol "scalar" <$ symbol "scalar"
<*> name <*> name
<*> directives <*> directives
<?> "ScalarTypeDefinition" <?> "ScalarTypeDefinition"
scalarTypeExtension :: Parser TypeExtension scalarTypeExtension :: Parser Full.TypeExtension
scalarTypeExtension = extend "scalar" "ScalarTypeExtension" scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
$ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] $ (Full.ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
objectTypeDefinition :: Description -> Parser TypeDefinition objectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
objectTypeDefinition description' = ObjectTypeDefinition description' objectTypeDefinition description' = Full.ObjectTypeDefinition description'
<$ symbol "type" <$ symbol "type"
<*> name <*> name
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> directives <*> directives
<*> braces (many fieldDefinition) <*> braces (many fieldDefinition)
<?> "ObjectTypeDefinition" <?> "ObjectTypeDefinition"
objectTypeExtension :: Parser TypeExtension objectTypeExtension :: Parser Full.TypeExtension
objectTypeExtension = extend "type" "ObjectTypeExtension" objectTypeExtension = extend "type" "ObjectTypeExtension"
$ fieldsDefinitionExtension :| $ fieldsDefinitionExtension :|
[ directivesExtension [ directivesExtension
, implementsInterfacesExtension , implementsInterfacesExtension
] ]
where where
fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension fieldsDefinitionExtension = Full.ObjectTypeFieldsDefinitionExtension
<$> name <$> name
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> directives <*> directives
<*> braces (NonEmpty.some fieldDefinition) <*> braces (NonEmpty.some fieldDefinition)
directivesExtension = ObjectTypeDirectivesExtension directivesExtension = Full.ObjectTypeDirectivesExtension
<$> name <$> name
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> NonEmpty.some directive <*> NonEmpty.some directive
implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension implementsInterfacesExtension = Full.ObjectTypeImplementsInterfacesExtension
<$> name <$> name
<*> implementsInterfaces NonEmpty.sepBy1 <*> implementsInterfaces NonEmpty.sepBy1
description :: Parser Description description :: Parser Full.Description
description = Description description = Full.Description
<$> optional stringValue <$> optional stringValue
<?> "Description" <?> "Description"
unionTypeDefinition :: Description -> Parser TypeDefinition unionTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
unionTypeDefinition description' = UnionTypeDefinition description' unionTypeDefinition description' = Full.UnionTypeDefinition description'
<$ symbol "union" <$ symbol "union"
<*> name <*> name
<*> directives <*> directives
<*> option (UnionMemberTypes []) (unionMemberTypes sepBy1) <*> option (Full.UnionMemberTypes []) (unionMemberTypes sepBy1)
<?> "UnionTypeDefinition" <?> "UnionTypeDefinition"
unionTypeExtension :: Parser TypeExtension unionTypeExtension :: Parser Full.TypeExtension
unionTypeExtension = extend "union" "UnionTypeExtension" unionTypeExtension = extend "union" "UnionTypeExtension"
$ unionMemberTypesExtension :| [directivesExtension] $ unionMemberTypesExtension :| [directivesExtension]
where where
unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension unionMemberTypesExtension = Full.UnionTypeUnionMemberTypesExtension
<$> name <$> name
<*> directives <*> directives
<*> unionMemberTypes NonEmpty.sepBy1 <*> unionMemberTypes NonEmpty.sepBy1
directivesExtension = UnionTypeDirectivesExtension directivesExtension = Full.UnionTypeDirectivesExtension
<$> name <$> name
<*> NonEmpty.some directive <*> NonEmpty.some directive
unionMemberTypes :: unionMemberTypes ::
Foldable t => Foldable t =>
(Parser Text -> Parser Text -> Parser (t NamedType)) -> (Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
Parser (UnionMemberTypes t) Parser (Full.UnionMemberTypes t)
unionMemberTypes sepBy' = UnionMemberTypes unionMemberTypes sepBy' = Full.UnionMemberTypes
<$ equals <$ equals
<* optional pipe <* optional pipe
<*> name `sepBy'` pipe <*> name `sepBy'` pipe
<?> "UnionMemberTypes" <?> "UnionMemberTypes"
interfaceTypeDefinition :: Description -> Parser TypeDefinition interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
interfaceTypeDefinition description' = InterfaceTypeDefinition description' interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
<$ symbol "interface" <$ symbol "interface"
<*> name <*> name
<*> directives <*> directives
<*> braces (many fieldDefinition) <*> braces (many fieldDefinition)
<?> "InterfaceTypeDefinition" <?> "InterfaceTypeDefinition"
interfaceTypeExtension :: Parser TypeExtension interfaceTypeExtension :: Parser Full.TypeExtension
interfaceTypeExtension = extend "interface" "InterfaceTypeExtension" interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
$ fieldsDefinitionExtension :| [directivesExtension] $ fieldsDefinitionExtension :| [directivesExtension]
where where
fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension fieldsDefinitionExtension = Full.InterfaceTypeFieldsDefinitionExtension
<$> name <$> name
<*> directives <*> directives
<*> braces (NonEmpty.some fieldDefinition) <*> braces (NonEmpty.some fieldDefinition)
directivesExtension = InterfaceTypeDirectivesExtension directivesExtension = Full.InterfaceTypeDirectivesExtension
<$> name <$> name
<*> NonEmpty.some directive <*> NonEmpty.some directive
enumTypeDefinition :: Description -> Parser TypeDefinition enumTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
enumTypeDefinition description' = EnumTypeDefinition description' enumTypeDefinition description' = Full.EnumTypeDefinition description'
<$ symbol "enum" <$ symbol "enum"
<*> name <*> name
<*> directives <*> directives
<*> listOptIn braces enumValueDefinition <*> listOptIn braces enumValueDefinition
<?> "EnumTypeDefinition" <?> "EnumTypeDefinition"
enumTypeExtension :: Parser TypeExtension enumTypeExtension :: Parser Full.TypeExtension
enumTypeExtension = extend "enum" "EnumTypeExtension" enumTypeExtension = extend "enum" "EnumTypeExtension"
$ enumValuesDefinitionExtension :| [directivesExtension] $ enumValuesDefinitionExtension :| [directivesExtension]
where where
enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension enumValuesDefinitionExtension = Full.EnumTypeEnumValuesDefinitionExtension
<$> name <$> name
<*> directives <*> directives
<*> braces (NonEmpty.some enumValueDefinition) <*> braces (NonEmpty.some enumValueDefinition)
directivesExtension = EnumTypeDirectivesExtension directivesExtension = Full.EnumTypeDirectivesExtension
<$> name <$> name
<*> NonEmpty.some directive <*> NonEmpty.some directive
inputObjectTypeDefinition :: Description -> Parser TypeDefinition inputObjectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
inputObjectTypeDefinition description' = InputObjectTypeDefinition description' inputObjectTypeDefinition description' = Full.InputObjectTypeDefinition description'
<$ symbol "input" <$ symbol "input"
<*> name <*> name
<*> directives <*> directives
<*> listOptIn braces inputValueDefinition <*> listOptIn braces inputValueDefinition
<?> "InputObjectTypeDefinition" <?> "InputObjectTypeDefinition"
inputObjectTypeExtension :: Parser TypeExtension inputObjectTypeExtension :: Parser Full.TypeExtension
inputObjectTypeExtension = extend "input" "InputObjectTypeExtension" inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
$ inputFieldsDefinitionExtension :| [directivesExtension] $ inputFieldsDefinitionExtension :| [directivesExtension]
where where
inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension inputFieldsDefinitionExtension = Full.InputObjectTypeInputFieldsDefinitionExtension
<$> name <$> name
<*> directives <*> directives
<*> braces (NonEmpty.some inputValueDefinition) <*> braces (NonEmpty.some inputValueDefinition)
directivesExtension = InputObjectTypeDirectivesExtension directivesExtension = Full.InputObjectTypeDirectivesExtension
<$> name <$> name
<*> NonEmpty.some directive <*> NonEmpty.some directive
enumValueDefinition :: Parser EnumValueDefinition enumValueDefinition :: Parser Full.EnumValueDefinition
enumValueDefinition = EnumValueDefinition enumValueDefinition = Full.EnumValueDefinition
<$> description <$> description
<*> enumValue <*> enumValue
<*> directives <*> directives
@ -286,16 +287,16 @@ enumValueDefinition = EnumValueDefinition
implementsInterfaces :: implementsInterfaces ::
Foldable t => Foldable t =>
(Parser Text -> Parser Text -> Parser (t NamedType)) -> (Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
Parser (ImplementsInterfaces t) Parser (Full.ImplementsInterfaces t)
implementsInterfaces sepBy' = ImplementsInterfaces implementsInterfaces sepBy' = Full.ImplementsInterfaces
<$ symbol "implements" <$ symbol "implements"
<* optional amp <* optional amp
<*> name `sepBy'` amp <*> name `sepBy'` amp
<?> "ImplementsInterfaces" <?> "ImplementsInterfaces"
inputValueDefinition :: Parser InputValueDefinition inputValueDefinition :: Parser Full.InputValueDefinition
inputValueDefinition = InputValueDefinition inputValueDefinition = Full.InputValueDefinition
<$> description <$> description
<*> name <*> name
<* colon <* colon
@ -304,13 +305,13 @@ inputValueDefinition = InputValueDefinition
<*> directives <*> directives
<?> "InputValueDefinition" <?> "InputValueDefinition"
argumentsDefinition :: Parser ArgumentsDefinition argumentsDefinition :: Parser Full.ArgumentsDefinition
argumentsDefinition = ArgumentsDefinition argumentsDefinition = Full.ArgumentsDefinition
<$> listOptIn parens inputValueDefinition <$> listOptIn parens inputValueDefinition
<?> "ArgumentsDefinition" <?> "ArgumentsDefinition"
fieldDefinition :: Parser FieldDefinition fieldDefinition :: Parser Full.FieldDefinition
fieldDefinition = FieldDefinition fieldDefinition = Full.FieldDefinition
<$> description <$> description
<*> name <*> name
<*> argumentsDefinition <*> argumentsDefinition
@ -319,33 +320,33 @@ fieldDefinition = FieldDefinition
<*> directives <*> directives
<?> "FieldDefinition" <?> "FieldDefinition"
schemaDefinition :: Parser TypeSystemDefinition schemaDefinition :: Parser Full.TypeSystemDefinition
schemaDefinition = SchemaDefinition schemaDefinition = Full.SchemaDefinition
<$ symbol "schema" <$ symbol "schema"
<*> directives <*> directives
<*> operationTypeDefinitions <*> operationTypeDefinitions
<?> "SchemaDefinition" <?> "SchemaDefinition"
operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition) operationTypeDefinitions :: Parser (NonEmpty Full.OperationTypeDefinition)
operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
schemaExtension :: Parser SchemaExtension schemaExtension :: Parser Full.SchemaExtension
schemaExtension = extend "schema" "SchemaExtension" schemaExtension = extend "schema" "SchemaExtension"
$ schemaOperationExtension :| [directivesExtension] $ schemaOperationExtension :| [directivesExtension]
where where
directivesExtension = SchemaDirectivesExtension directivesExtension = Full.SchemaDirectivesExtension
<$> NonEmpty.some directive <$> NonEmpty.some directive
schemaOperationExtension = SchemaOperationExtension schemaOperationExtension = Full.SchemaOperationExtension
<$> directives <$> directives
<*> operationTypeDefinitions <*> operationTypeDefinitions
operationTypeDefinition :: Parser OperationTypeDefinition operationTypeDefinition :: Parser Full.OperationTypeDefinition
operationTypeDefinition = OperationTypeDefinition operationTypeDefinition = Full.OperationTypeDefinition
<$> operationType <* colon <$> operationType <* colon
<*> name <*> name
<?> "OperationTypeDefinition" <?> "OperationTypeDefinition"
operationDefinition :: Parser OperationDefinition operationDefinition :: Parser Full.OperationDefinition
operationDefinition = shorthand operationDefinition = shorthand
<|> operationDefinition' <|> operationDefinition'
<?> "OperationDefinition" <?> "OperationDefinition"
@ -353,7 +354,7 @@ operationDefinition = shorthand
shorthand = do shorthand = do
location <- getLocation location <- getLocation
selectionSet' <- selectionSet selectionSet' <- selectionSet
pure $ SelectionSet selectionSet' location pure $ Full.SelectionSet selectionSet' location
operationDefinition' = do operationDefinition' = do
location <- getLocation location <- getLocation
operationType' <- operationType operationType' <- operationType
@ -361,27 +362,33 @@ operationDefinition = shorthand
variableDefinitions' <- variableDefinitions variableDefinitions' <- variableDefinitions
directives' <- directives directives' <- directives
selectionSet' <- selectionSet selectionSet' <- selectionSet
pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location pure $ Full.OperationDefinition
operationType'
operationName
variableDefinitions'
directives'
selectionSet'
location
operationType :: Parser OperationType operationType :: Parser Full.OperationType
operationType = Query <$ symbol "query" operationType = Full.Query <$ symbol "query"
<|> Mutation <$ symbol "mutation" <|> Full.Mutation <$ symbol "mutation"
<|> Subscription <$ symbol "subscription" <|> Full.Subscription <$ symbol "subscription"
<?> "OperationType" <?> "OperationType"
selectionSet :: Parser SelectionSet selectionSet :: Parser Full.SelectionSet
selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet" selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"
selectionSetOpt :: Parser SelectionSetOpt selectionSetOpt :: Parser Full.SelectionSetOpt
selectionSetOpt = listOptIn braces selection <?> "SelectionSet" selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
selection :: Parser Selection selection :: Parser Full.Selection
selection = FieldSelection <$> field selection = Full.FieldSelection <$> field
<|> FragmentSpreadSelection <$> try fragmentSpread <|> Full.FragmentSpreadSelection <$> try fragmentSpread
<|> InlineFragmentSelection <$> inlineFragment <|> Full.InlineFragmentSelection <$> inlineFragment
<?> "Selection" <?> "Selection"
field :: Parser Field field :: Parser Full.Field
field = label "Field" $ do field = label "Field" $ do
location <- getLocation location <- getLocation
alias' <- optional alias alias' <- optional alias
@ -389,40 +396,40 @@ field = label "Field" $ do
arguments' <- arguments arguments' <- arguments
directives' <- directives directives' <- directives
selectionSetOpt' <- selectionSetOpt 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" alias = try (name <* colon) <?> "Alias"
arguments :: Parser [Argument] arguments :: Parser [Full.Argument]
arguments = listOptIn parens argument <?> "Arguments" arguments = listOptIn parens argument <?> "Arguments"
argument :: Parser Argument argument :: Parser Full.Argument
argument = label "Argument" $ do argument = label "Argument" $ do
location <- getLocation location <- getLocation
name' <- name name' <- name
colon colon
value' <- valueNode value' <- valueNode value
pure $ Argument name' value' location pure $ Full.Argument name' value' location
fragmentSpread :: Parser FragmentSpread fragmentSpread :: Parser Full.FragmentSpread
fragmentSpread = label "FragmentSpread" $ do fragmentSpread = label "FragmentSpread" $ do
location <- getLocation location <- getLocation
_ <- spread _ <- spread
fragmentName' <- fragmentName fragmentName' <- fragmentName
directives' <- directives directives' <- directives
pure $ FragmentSpread fragmentName' directives' location pure $ Full.FragmentSpread fragmentName' directives' location
inlineFragment :: Parser InlineFragment inlineFragment :: Parser Full.InlineFragment
inlineFragment = label "InlineFragment" $ do inlineFragment = label "InlineFragment" $ do
location <- getLocation location <- getLocation
_ <- spread _ <- spread
typeCondition' <- optional typeCondition typeCondition' <- optional typeCondition
directives' <- directives directives' <- directives
selectionSet' <- selectionSet 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 fragmentDefinition = label "FragmentDefinition" $ do
location <- getLocation location <- getLocation
_ <- symbol "fragment" _ <- symbol "fragment"
@ -430,42 +437,42 @@ fragmentDefinition = label "FragmentDefinition" $ do
typeCondition' <- typeCondition typeCondition' <- typeCondition
directives' <- directives directives' <- directives
selectionSet' <- selectionSet selectionSet' <- selectionSet
pure $ FragmentDefinition pure $ Full.FragmentDefinition
fragmentName' typeCondition' directives' selectionSet' location fragmentName' typeCondition' directives' selectionSet' location
fragmentName :: Parser Name fragmentName :: Parser Full.Name
fragmentName = but (symbol "on") *> name <?> "FragmentName" fragmentName = but (symbol "on") *> name <?> "FragmentName"
typeCondition :: Parser TypeCondition typeCondition :: Parser Full.TypeCondition
typeCondition = symbol "on" *> name <?> "TypeCondition" typeCondition = symbol "on" *> name <?> "TypeCondition"
valueNode :: Parser (Node Value) valueNode :: forall a. Parser a -> Parser (Full.Node a)
valueNode = do valueNode valueParser = do
location <- getLocation location <- getLocation
value' <- value value' <- valueParser
pure $ Node value' location pure $ Full.Node value' location
value :: Parser Value value :: Parser Full.Value
value = Variable <$> variable value = Full.Variable <$> variable
<|> Float <$> try float <|> Full.Float <$> try float
<|> Int <$> integer <|> Full.Int <$> integer
<|> Boolean <$> booleanValue <|> Full.Boolean <$> booleanValue
<|> Null <$ nullValue <|> Full.Null <$ nullValue
<|> String <$> stringValue <|> Full.String <$> stringValue
<|> Enum <$> try enumValue <|> Full.Enum <$> try enumValue
<|> List <$> brackets (some value) <|> Full.List <$> brackets (some value)
<|> Object <$> braces (some $ objectField value) <|> Full.Object <$> braces (some $ objectField value)
<?> "Value" <?> "Value"
constValue :: Parser ConstValue constValue :: Parser Full.ConstValue
constValue = ConstFloat <$> try float constValue = Full.ConstFloat <$> try float
<|> ConstInt <$> integer <|> Full.ConstInt <$> integer
<|> ConstBoolean <$> booleanValue <|> Full.ConstBoolean <$> booleanValue
<|> ConstNull <$ nullValue <|> Full.ConstNull <$ nullValue
<|> ConstString <$> stringValue <|> Full.ConstString <$> stringValue
<|> ConstEnum <$> try enumValue <|> Full.ConstEnum <$> try enumValue
<|> ConstList <$> brackets (some constValue) <|> Full.ConstList <$> brackets (some constValue)
<|> ConstObject <$> braces (some $ objectField constValue) <|> Full.ConstObject <$> braces (some $ objectField constValue)
<?> "Value" <?> "Value"
booleanValue :: Parser Bool booleanValue :: Parser Bool
@ -473,7 +480,7 @@ booleanValue = True <$ symbol "true"
<|> False <$ symbol "false" <|> False <$ symbol "false"
<?> "BooleanValue" <?> "BooleanValue"
enumValue :: Parser Name enumValue :: Parser Full.Name
enumValue = but (symbol "true") enumValue = but (symbol "true")
*> but (symbol "false") *> but (symbol "false")
*> but (symbol "null") *> but (symbol "null")
@ -486,54 +493,54 @@ stringValue = blockString <|> string <?> "StringValue"
nullValue :: Parser Text nullValue :: Parser Text
nullValue = symbol "null" <?> "NullValue" nullValue = symbol "null" <?> "NullValue"
objectField :: Parser a -> Parser (ObjectField a) objectField :: Parser a -> Parser (Full.ObjectField a)
objectField valueParser = label "ObjectField" $ do objectField valueParser = label "ObjectField" $ do
location <- getLocation location <- getLocation
fieldName <- name fieldName <- name
colon colon
fieldValue <- valueParser 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 = listOptIn parens variableDefinition
<?> "VariableDefinitions" <?> "VariableDefinitions"
variableDefinition :: Parser VariableDefinition variableDefinition :: Parser Full.VariableDefinition
variableDefinition = label "VariableDefinition" $ do variableDefinition = label "VariableDefinition" $ do
location <- getLocation location <- getLocation
variableName <- variable variableName <- variable
colon colon
variableType <- type' variableType <- type'
variableValue <- defaultValue 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" variable = dollar *> name <?> "Variable"
defaultValue :: Parser (Maybe ConstValue) defaultValue :: Parser (Maybe (Full.Node Full.ConstValue))
defaultValue = optional (equals *> constValue) <?> "DefaultValue" defaultValue = optional (equals *> valueNode constValue) <?> "DefaultValue"
type' :: Parser Type type' :: Parser Full.Type
type' = try (TypeNonNull <$> nonNullType) type' = try (Full.TypeNonNull <$> nonNullType)
<|> TypeList <$> brackets type' <|> Full.TypeList <$> brackets type'
<|> TypeNamed <$> name <|> Full.TypeNamed <$> name
<?> "Type" <?> "Type"
nonNullType :: Parser NonNullType nonNullType :: Parser Full.NonNullType
nonNullType = NonNullTypeNamed <$> name <* bang nonNullType = Full.NonNullTypeNamed <$> name <* bang
<|> NonNullTypeList <$> brackets type' <* bang <|> Full.NonNullTypeList <$> brackets type' <* bang
<?> "NonNullType" <?> "NonNullType"
directives :: Parser [Directive] directives :: Parser [Full.Directive]
directives = many directive <?> "Directives" directives = many directive <?> "Directives"
directive :: Parser Directive directive :: Parser Full.Directive
directive = label "Directive" $ do directive = label "Directive" $ do
location <- getLocation location <- getLocation
at at
directiveName <- name directiveName <- name
directiveArguments <- arguments directiveArguments <- arguments
pure $ Directive directiveName directiveArguments location pure $ Full.Directive directiveName directiveArguments location
listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a] listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
listOptIn surround = option [] . surround . some 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 forEach variableDefinition coercedValues = do
let Full.VariableDefinition variableName variableTypeName defaultValue _ = let Full.VariableDefinition variableName variableTypeName defaultValue _ =
variableDefinition variableDefinition
let defaultValue' = constValue <$> defaultValue let defaultValue' = constValue . Full.value <$> defaultValue
variableType <- lookupInputType variableTypeName types variableType <- lookupInputType variableTypeName types
Coerce.matchFieldValues 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 qualified Data.Sequence as Seq
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
import qualified Language.GraphQL.AST.DirectiveLocation as 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 Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In 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 import qualified Language.GraphQL.Validate.Validation as Validation
type ApplySelectionRule m a type ApplySelectionRule m a
= HashMap Name (Schema.Type m) = HashMap Full.Name (Schema.Type m)
-> Validation.Rule m -> Validation.Rule m
-> Maybe (Out.Type m) -> Maybe (Out.Type m)
-> a -> a
@ -48,7 +48,7 @@ type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.RuleT m)
document :: forall m document :: forall m
. Schema m . Schema m
-> [Validation.Rule m] -> [Validation.Rule m]
-> Document -> Full.Document
-> Seq Validation.Error -> Seq Validation.Error
document schema' rules' document' = document schema' rules' document' =
runReaderT reader context runReaderT reader context
@ -111,121 +111,145 @@ document schema' rules' document' =
definition :: Validation.Rule m definition :: Validation.Rule m
-> Validation m -> Validation m
-> Definition -> Full.Definition
-> Seq (Validation.RuleT m) -> Seq (Validation.RuleT m)
-> Seq (Validation.RuleT m) -> Seq (Validation.RuleT m)
definition (Validation.DefinitionRule rule) _ definition' accumulator = definition (Validation.DefinitionRule rule) _ definition' accumulator =
accumulator |> rule definition' accumulator |> rule definition'
definition rule context (ExecutableDefinition definition') accumulator = definition rule context (Full.ExecutableDefinition definition') accumulator =
accumulator >< executableDefinition rule context definition' accumulator >< executableDefinition rule context definition'
definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator = definition rule context (Full.TypeSystemDefinition typeSystemDefinition' _) accumulator =
accumulator >< typeSystemDefinition rule typeSystemDefinition' accumulator >< typeSystemDefinition context rule typeSystemDefinition'
definition rule _ (TypeSystemExtension extension _) accumulator = definition rule context (Full.TypeSystemExtension extension _) accumulator =
accumulator >< typeSystemExtension rule extension accumulator >< typeSystemExtension context rule extension
typeSystemExtension :: forall m. ApplyRule m TypeSystemExtension typeSystemExtension :: forall m
typeSystemExtension rule = \case . Validation m
SchemaExtension extension -> schemaExtension rule extension -> ApplyRule m Full.TypeSystemExtension
TypeExtension extension -> typeExtension rule extension 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 :: forall m. Validation m -> ApplyRule m Full.TypeExtension
typeExtension rule = \case typeExtension context rule = \case
ScalarTypeExtension _ directives' -> directives rule directives' Full.ScalarTypeExtension _ directives' -> directives context rule directives'
ObjectTypeFieldsDefinitionExtension _ _ directives' fields -> Full.ObjectTypeFieldsDefinitionExtension _ _ directives' fields
directives rule directives' >< foldMap (fieldDefinition rule) fields -> directives context rule directives'
ObjectTypeDirectivesExtension _ _ directives' -> directives rule directives' >< foldMap (fieldDefinition context rule) fields
ObjectTypeImplementsInterfacesExtension _ _ -> mempty Full.ObjectTypeDirectivesExtension _ _ directives' ->
InterfaceTypeFieldsDefinitionExtension _ directives' fields -> directives context rule directives'
directives rule directives' >< foldMap (fieldDefinition rule) fields Full.ObjectTypeImplementsInterfacesExtension _ _ -> mempty
InterfaceTypeDirectivesExtension _ directives' -> Full.InterfaceTypeFieldsDefinitionExtension _ directives' fields
directives rule directives' -> directives context rule directives'
UnionTypeUnionMemberTypesExtension _ directives' _ -> >< foldMap (fieldDefinition context rule) fields
directives rule directives' Full.InterfaceTypeDirectivesExtension _ directives' ->
UnionTypeDirectivesExtension _ directives' -> directives rule directives' directives context rule directives'
EnumTypeEnumValuesDefinitionExtension _ directives' values -> Full.UnionTypeUnionMemberTypesExtension _ directives' _ ->
directives rule directives' >< foldMap (enumValueDefinition rule) values directives context rule directives'
EnumTypeDirectivesExtension _ directives' -> directives rule directives' Full.UnionTypeDirectivesExtension _ directives' ->
InputObjectTypeInputFieldsDefinitionExtension _ directives' fields directives context rule directives'
-> directives rule directives' Full.EnumTypeEnumValuesDefinitionExtension _ directives' values
>< foldMap (inputValueDefinition rule) fields -> directives context rule directives'
InputObjectTypeDirectivesExtension _ directives' -> >< foldMap (enumValueDefinition context rule) values
directives rule directives' 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 :: forall m. Validation m -> ApplyRule m Full.SchemaExtension
schemaExtension rule = \case schemaExtension context rule = \case
SchemaOperationExtension directives' _ -> directives rule directives' Full.SchemaOperationExtension directives' _ ->
SchemaDirectivesExtension directives' -> directives rule directives' directives context rule directives'
Full.SchemaDirectivesExtension directives' -> directives context rule directives'
executableDefinition :: forall m executableDefinition :: forall m
. Validation.Rule m . Validation.Rule m
-> Validation m -> Validation m
-> ExecutableDefinition -> Full.ExecutableDefinition
-> Seq (Validation.RuleT m) -> Seq (Validation.RuleT m)
executableDefinition rule context (DefinitionOperation operation) = executableDefinition rule context (Full.DefinitionOperation operation) =
operationDefinition rule context operation operationDefinition rule context operation
executableDefinition rule context (DefinitionFragment fragment) = executableDefinition rule context (Full.DefinitionFragment fragment) =
fragmentDefinition rule context fragment fragmentDefinition rule context fragment
typeSystemDefinition :: forall m. ApplyRule m TypeSystemDefinition typeSystemDefinition :: forall m
typeSystemDefinition rule = \case . Validation m
SchemaDefinition directives' _ -> directives rule directives' -> ApplyRule m Full.TypeSystemDefinition
TypeDefinition typeDefinition' -> typeDefinition rule typeDefinition' typeSystemDefinition context rule = \case
DirectiveDefinition _ _ arguments' _ -> argumentsDefinition rule arguments' 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 :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
typeDefinition rule = \case typeDefinition context rule = \case
ScalarTypeDefinition _ _ directives' -> directives rule directives' Full.ScalarTypeDefinition _ _ directives' ->
ObjectTypeDefinition _ _ _ directives' fields -> directives context rule directives'
directives rule directives' >< foldMap (fieldDefinition rule) fields Full.ObjectTypeDefinition _ _ _ directives' fields
InterfaceTypeDefinition _ _ directives' fields -> -> directives context rule directives'
directives rule directives' >< foldMap (fieldDefinition rule) fields >< foldMap (fieldDefinition context rule) fields
UnionTypeDefinition _ _ directives' _ -> directives rule directives' Full.InterfaceTypeDefinition _ _ directives' fields
EnumTypeDefinition _ _ directives' values -> -> directives context rule directives'
directives rule directives' >< foldMap (enumValueDefinition rule) values >< foldMap (fieldDefinition context rule) fields
InputObjectTypeDefinition _ _ directives' fields Full.UnionTypeDefinition _ _ directives' _ ->
-> directives rule directives' directives context rule directives'
<> foldMap (inputValueDefinition rule) fields 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 :: forall m
enumValueDefinition rule (EnumValueDefinition _ _ directives') = . Validation m
directives rule directives' -> ApplyRule m Full.EnumValueDefinition
enumValueDefinition context rule (Full.EnumValueDefinition _ _ directives') =
directives context rule directives'
fieldDefinition :: forall m. ApplyRule m FieldDefinition fieldDefinition :: forall m. Validation m -> ApplyRule m Full.FieldDefinition
fieldDefinition rule (FieldDefinition _ _ arguments' _ directives') = fieldDefinition context rule (Full.FieldDefinition _ _ arguments' _ directives')
directives rule directives' >< argumentsDefinition rule arguments' = directives context rule directives'
>< argumentsDefinition context rule arguments'
argumentsDefinition :: forall m. ApplyRule m ArgumentsDefinition argumentsDefinition :: forall m
argumentsDefinition rule (ArgumentsDefinition definitions) = . Validation m
foldMap (inputValueDefinition rule) definitions -> ApplyRule m Full.ArgumentsDefinition
argumentsDefinition context rule (Full.ArgumentsDefinition definitions) =
foldMap (inputValueDefinition context rule) definitions
inputValueDefinition :: forall m. ApplyRule m InputValueDefinition inputValueDefinition :: forall m
inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') = . Validation m
directives rule directives' -> ApplyRule m Full.InputValueDefinition
inputValueDefinition context rule (Full.InputValueDefinition _ _ _ _ directives') =
directives context rule directives'
operationDefinition :: forall m operationDefinition :: forall m
. Validation.Rule m . Validation.Rule m
-> Validation m -> Validation m
-> OperationDefinition -> Full.OperationDefinition
-> Seq (Validation.RuleT m) -> Seq (Validation.RuleT m)
operationDefinition rule context operation operationDefinition rule context operation
| Validation.OperationDefinitionRule operationRule <- rule = | Validation.OperationDefinitionRule operationRule <- rule =
pure $ operationRule operation pure $ operationRule operation
| Validation.VariablesRule variablesRule <- rule | Validation.VariablesRule variablesRule <- rule
, OperationDefinition _ _ variables _ _ _ <- operation , Full.OperationDefinition _ _ variables _ _ _ <- operation =
= Seq.fromList (variableDefinition rule <$> variables) foldMap (variableDefinition context rule) variables |> variablesRule variables
|> variablesRule variables | Full.SelectionSet selections _ <- operation =
| SelectionSet selections _ <- operation = selectionSet context types' rule (getRootType Full.Query) selections
selectionSet types' rule (getRootType Query) selections | Full.OperationDefinition operationType _ _ directives' selections _ <- operation
| OperationDefinition operationType _ _ directives' selections _ <- operation = selectionSet context types' rule (getRootType operationType) selections
= selectionSet types' rule (getRootType operationType) selections >< directives context rule directives'
>< directives rule directives'
where where
types' = Validation.types context types' = Validation.types context
getRootType Query = getRootType Full.Query =
Just $ Out.NamedObjectType $ Schema.query $ Validation.schema context Just $ Out.NamedObjectType $ Schema.query $ Validation.schema context
getRootType Mutation = getRootType Full.Mutation =
Out.NamedObjectType <$> Schema.mutation (Validation.schema context) Out.NamedObjectType <$> Schema.mutation (Validation.schema context)
getRootType Subscription = getRootType Full.Subscription =
Out.NamedObjectType <$> Schema.subscription (Validation.schema context) Out.NamedObjectType <$> Schema.subscription (Validation.schema context)
typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m) typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
@ -239,88 +263,159 @@ typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
typeToOut _ = Nothing typeToOut _ = Nothing
variableDefinition :: forall m 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 . Validation.Rule m
-> VariableDefinition -> Maybe In.Type
-> Validation.RuleT m -> Full.ConstValue
variableDefinition (Validation.ValueRule _ rule) (VariableDefinition _ _ value _) = -> Seq (Validation.RuleT m)
maybe (lift mempty) rule value constValue (Validation.ValueRule _ rule) valueType = go valueType
variableDefinition _ _ = lift mempty 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 fragmentDefinition :: forall m
. Validation.Rule m . Validation.Rule m
-> Validation m -> Validation m
-> FragmentDefinition -> Full.FragmentDefinition
-> Seq (Validation.RuleT m) -> Seq (Validation.RuleT m)
fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' = fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =
pure $ rule definition' pure $ rule definition'
fragmentDefinition rule context definition' fragmentDefinition rule context definition'
| FragmentDefinition _ typeCondition directives' selections _ <- definition' | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
, Validation.FragmentRule definitionRule _ <- rule , Validation.FragmentRule definitionRule _ <- rule
= applyToChildren typeCondition directives' selections = applyToChildren typeCondition directives' selections
|> definitionRule definition' |> definitionRule definition'
| FragmentDefinition _ typeCondition directives' selections _ <- definition' | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
= applyToChildren typeCondition directives' selections = applyToChildren typeCondition directives' selections
where where
types' = Validation.types context types' = Validation.types context
applyToChildren typeCondition directives' selections applyToChildren typeCondition directives' selections
= selectionSet types' rule (lookupType' typeCondition) selections = selectionSet context types' rule (lookupType' typeCondition) selections
>< directives rule directives' >< directives context rule directives'
lookupType' = flip lookupType types' lookupType' = flip lookupType types'
lookupType :: forall m lookupType :: forall m
. TypeCondition . Full.TypeCondition
-> HashMap Name (Schema.Type m) -> HashMap Full.Name (Schema.Type m)
-> Maybe (Out.Type m) -> Maybe (Out.Type m)
lookupType typeCondition types' = HashMap.lookup typeCondition types' lookupType typeCondition types' = HashMap.lookup typeCondition types'
>>= typeToOut >>= typeToOut
selectionSet :: Traversable t => forall m. ApplySelectionRule m (t Selection) selectionSet :: Traversable t
selectionSet types' rule = foldMap . selection types' rule => 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 :: forall m. Validation m -> ApplySelectionRule m Full.Selection
selection types' rule objectType selection' selection context types' rule objectType selection'
| Validation.SelectionRule selectionRule <- rule = | Validation.SelectionRule selectionRule <- rule =
applyToChildren |> selectionRule objectType selection' applyToChildren |> selectionRule objectType selection'
| otherwise = applyToChildren | otherwise = applyToChildren
where where
applyToChildren = applyToChildren =
case selection' of case selection' of
FieldSelection field' -> field types' rule objectType field' Full.FieldSelection field' ->
InlineFragmentSelection inlineFragment' -> field context types' rule objectType field'
inlineFragment types' rule objectType inlineFragment' Full.InlineFragmentSelection inlineFragment' ->
FragmentSpreadSelection fragmentSpread' -> inlineFragment context types' rule objectType inlineFragment'
fragmentSpread rule fragmentSpread' Full.FragmentSpreadSelection fragmentSpread' ->
fragmentSpread context rule fragmentSpread'
field :: forall m. ApplySelectionRule m Field field :: forall m. Validation m -> ApplySelectionRule m Full.Field
field types' rule objectType field' = go field' field context types' rule objectType field' = go field'
where where
go (Field _ fieldName _ _ _ _) go (Full.Field _ fieldName _ _ _ _)
| Validation.FieldRule fieldRule <- rule = | Validation.FieldRule fieldRule <- rule =
applyToChildren fieldName |> fieldRule objectType field' applyToChildren fieldName |> fieldRule objectType field'
| Validation.ArgumentsRule argumentsRule _ <- rule = | Validation.ArgumentsRule argumentsRule _ <- rule =
applyToChildren fieldName |> argumentsRule objectType field' applyToChildren fieldName |> argumentsRule objectType field'
| otherwise = applyToChildren fieldName | otherwise = applyToChildren fieldName
typeFieldType (Out.Field _ type' _) = type' typeFieldType (Out.Field _ type' _) = type'
typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes
applyToChildren fieldName = applyToChildren fieldName =
let Field _ _ arguments' directives' selections _ = field' let Full.Field _ _ arguments' directives' selections _ = field'
fieldType = objectType typeField = objectType >>= lookupTypeField fieldName
>>= fmap typeFieldType . lookupTypeField fieldName argumentTypes = maybe mempty typeFieldArguments typeField
in selectionSet types' rule fieldType selections in selectionSet context types' rule (typeFieldType <$> typeField) selections
>< directives rule directives' >< directives context rule directives'
>< arguments rule arguments' >< arguments rule argumentTypes arguments'
arguments :: forall m. ApplyRule m [Argument] arguments :: forall m
arguments = (.) Seq.fromList . fmap . argument . Validation.Rule m
-> In.Arguments
argument :: forall m. Validation.Rule m -> Argument -> Validation.RuleT m -> [Full.Argument]
argument (Validation.ValueRule rule _) (Argument _ (Node value _) _) = -> Seq (Validation.RuleT m)
rule value arguments rule argumentTypes = foldMap forEach . Seq.fromList
argument _ _ = lift mempty
inlineFragment :: forall m. ApplySelectionRule m InlineFragment
inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
where 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 | Validation.FragmentRule _ fragmentRule <- rule
= applyToChildren (refineTarget optionalType) directives' selections = applyToChildren (refineTarget optionalType) directives' selections
|> fragmentRule inlineFragment' |> fragmentRule inlineFragment'
@ -328,27 +423,35 @@ inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
refineTarget (Just typeCondition) = lookupType typeCondition types' refineTarget (Just typeCondition) = lookupType typeCondition types'
refineTarget Nothing = objectType refineTarget Nothing = objectType
applyToChildren objectType' directives' selections applyToChildren objectType' directives' selections
= selectionSet types' rule objectType' selections = selectionSet context types' rule objectType' selections
>< directives rule directives' >< directives context rule directives'
fragmentSpread :: forall m. ApplyRule m FragmentSpread fragmentSpread :: forall m. Validation m -> ApplyRule m Full.FragmentSpread
fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _) fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _)
| Validation.FragmentSpreadRule fragmentRule <- rule = | Validation.FragmentSpreadRule fragmentRule <- rule =
applyToChildren |> fragmentRule fragmentSpread' applyToChildren |> fragmentRule fragmentSpread'
| otherwise = applyToChildren | otherwise = applyToChildren
where where
applyToChildren = directives rule directives' applyToChildren = directives context rule directives'
directives :: Traversable t => forall m. ApplyRule m (t Directive) directives :: Traversable t
directives rule directives' => forall m
. Validation m
-> ApplyRule m (t Full.Directive)
directives context rule directives'
| Validation.DirectivesRule directivesRule <- rule = | Validation.DirectivesRule directivesRule <- rule =
applyToChildren |> directivesRule directiveList applyToChildren |> directivesRule directiveList
| otherwise = applyToChildren | otherwise = applyToChildren
where where
directiveList = toList directives' directiveList = toList directives'
applyToChildren = foldMap (directive rule) directiveList applyToChildren = foldMap (directive context rule) directiveList
directive :: forall m. ApplyRule m Directive directive :: forall m. Validation m -> ApplyRule m Full.Directive
directive (Validation.ArgumentsRule _ argumentsRule) directive' = directive _ (Validation.ArgumentsRule _ argumentsRule) directive' =
pure $ 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 LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
@ -17,6 +18,7 @@ module Language.GraphQL.Validate.Rules
, loneAnonymousOperationRule , loneAnonymousOperationRule
, knownArgumentNamesRule , knownArgumentNamesRule
, knownDirectiveNamesRule , knownDirectiveNamesRule
, knownInputFieldNamesRule
, noFragmentCyclesRule , noFragmentCyclesRule
, noUndefinedVariablesRule , noUndefinedVariablesRule
, noUnusedFragmentsRule , noUnusedFragmentsRule
@ -53,6 +55,7 @@ import qualified Data.Text as Text
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Definition as Definition
import Language.GraphQL.Type.Internal 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.Out as Out
import qualified Language.GraphQL.Type.Schema as Schema import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Validation import Language.GraphQL.Validate.Validation
@ -83,6 +86,7 @@ specifiedRules =
, fragmentSpreadTargetDefinedRule , fragmentSpreadTargetDefinedRule
, noFragmentCyclesRule , noFragmentCyclesRule
-- Values -- Values
, knownInputFieldNamesRule
, uniqueInputFieldNamesRule , uniqueInputFieldNamesRule
-- Directives. -- Directives.
, knownDirectiveNamesRule , knownDirectiveNamesRule
@ -98,19 +102,19 @@ specifiedRules =
executableDefinitionsRule :: forall m. Rule m executableDefinitionsRule :: forall m. Rule m
executableDefinitionsRule = DefinitionRule $ \case executableDefinitionsRule = DefinitionRule $ \case
ExecutableDefinition _ -> lift mempty ExecutableDefinition _ -> lift mempty
TypeSystemDefinition _ location -> pure $ error' location TypeSystemDefinition _ location' -> pure $ error' location'
TypeSystemExtension _ location -> pure $ error' location TypeSystemExtension _ location' -> pure $ error' location'
where where
error' location = Error error' location' = Error
{ message = { message =
"Definition must be OperationDefinition or FragmentDefinition." "Definition must be OperationDefinition or FragmentDefinition."
, locations = [location] , locations = [location']
} }
-- | Subscription operations must have exactly one root field. -- | Subscription operations must have exactly one root field.
singleFieldSubscriptionsRule :: forall m. Rule m singleFieldSubscriptionsRule :: forall m. Rule m
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
OperationDefinition Subscription name' _ _ rootFields location -> do OperationDefinition Subscription name' _ _ rootFields location' -> do
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
case HashSet.size groupedFieldSet of case HashSet.size groupedFieldSet of
1 -> lift mempty 1 -> lift mempty
@ -121,11 +125,11 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
, Text.unpack name , Text.unpack name
, "must select only one top level field." , "must select only one top level field."
] ]
, locations = [location] , locations = [location']
} }
| otherwise -> pure $ Error | otherwise -> pure $ Error
{ message = errorMessage { message = errorMessage
, locations = [location] , locations = [location']
} }
_ -> lift mempty _ -> lift mempty
where where
@ -203,10 +207,10 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case
SelectionSet _ thatLocation SelectionSet _ thatLocation
| thisLocation /= thatLocation -> pure $ error' thisLocation | thisLocation /= thatLocation -> pure $ error' thisLocation
_ -> mempty _ -> mempty
error' location = Error error' location' = Error
{ message = { message =
"This anonymous operation must be the only defined operation." "This anonymous operation must be the only defined operation."
, locations = [location] , locations = [location']
} }
-- | Each named operation definition must be unique within a document when -- | 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. -- It is a validation error if the target of a spread is not defined.
fragmentSpreadTargetDefinedRule :: forall m. Rule m fragmentSpreadTargetDefinedRule :: forall m. Rule m
fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case
FragmentSpread fragmentName _ location -> do FragmentSpread fragmentName _ location' -> do
ast' <- asks ast ast' <- asks ast
case find (isSpreadTarget fragmentName) ast' of case find (isSpreadTarget fragmentName) ast' of
Nothing -> pure $ Error Nothing -> pure $ Error
{ message = error' fragmentName { message = error' fragmentName
, locations = [location] , locations = [location']
} }
Just _ -> lift mempty Just _ -> lift mempty
where where
@ -310,7 +314,7 @@ isSpreadTarget _ _ = False
fragmentSpreadTypeExistenceRule :: forall m. Rule m fragmentSpreadTypeExistenceRule :: forall m. Rule m
fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
FragmentSpreadSelection fragmentSelection FragmentSpreadSelection fragmentSelection
| FragmentSpread fragmentName _ location <- fragmentSelection -> do | FragmentSpread fragmentName _ location' <- fragmentSelection -> do
ast' <- asks ast ast' <- asks ast
let target = find (isSpreadTarget fragmentName) ast' let target = find (isSpreadTarget fragmentName) ast'
typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition
@ -318,17 +322,17 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
case HashMap.lookup typeCondition types' of case HashMap.lookup typeCondition types' of
Nothing -> pure $ Error Nothing -> pure $ Error
{ message = spreadError fragmentName typeCondition { message = spreadError fragmentName typeCondition
, locations = [location] , locations = [location']
} }
Just _ -> lift mempty Just _ -> lift mempty
InlineFragmentSelection fragmentSelection InlineFragmentSelection fragmentSelection
| InlineFragment maybeType _ _ location <- fragmentSelection | InlineFragment maybeType _ _ location' <- fragmentSelection
, Just typeCondition <- maybeType -> do , Just typeCondition <- maybeType -> do
types' <- asks types types' <- asks types
case HashMap.lookup typeCondition types' of case HashMap.lookup typeCondition types' of
Nothing -> pure $ Error Nothing -> pure $ Error
{ message = inlineError typeCondition { message = inlineError typeCondition
, locations = [location] , locations = [location']
} }
Just _ -> lift mempty Just _ -> lift mempty
_ -> lift mempty _ -> lift mempty
@ -360,19 +364,19 @@ maybeToSeq Nothing = mempty
fragmentsOnCompositeTypesRule :: forall m. Rule m fragmentsOnCompositeTypesRule :: forall m. Rule m
fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
where where
inlineRule (InlineFragment (Just typeCondition) _ _ location) = inlineRule (InlineFragment (Just typeCondition) _ _ location') =
check typeCondition location check typeCondition location'
inlineRule _ = lift mempty inlineRule _ = lift mempty
definitionRule (FragmentDefinition _ typeCondition _ _ location) = definitionRule (FragmentDefinition _ typeCondition _ _ location') =
check typeCondition location check typeCondition location'
check typeCondition location = do check typeCondition location' = do
types' <- asks types types' <- asks types
-- Skip unknown types, they are checked by another rule. -- Skip unknown types, they are checked by another rule.
_ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types' _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types'
case lookupTypeCondition typeCondition types' of case lookupTypeCondition typeCondition types' of
Nothing -> pure $ Error Nothing -> pure $ Error
{ message = errorMessage typeCondition { message = errorMessage typeCondition
, locations = [location] , locations = [location']
} }
Just _ -> lift mempty Just _ -> lift mempty
errorMessage typeCondition = concat errorMessage typeCondition = concat
@ -384,19 +388,19 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
-- | Defined fragments must be used within a document. -- | Defined fragments must be used within a document.
noUnusedFragmentsRule :: forall m. Rule m noUnusedFragmentsRule :: forall m. Rule m
noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do
let FragmentDefinition fragmentName _ _ _ location = fragment let FragmentDefinition fragmentName _ _ _ location' = fragment
in mapReaderT (checkFragmentName fragmentName location) in mapReaderT (checkFragmentName fragmentName location')
$ asks ast $ asks ast
>>= flip evalStateT HashSet.empty >>= flip evalStateT HashSet.empty
. filterSelections evaluateSelection . filterSelections evaluateSelection
. foldMap definitionSelections . foldMap definitionSelections
where where
checkFragmentName fragmentName location elements checkFragmentName fragmentName location' elements
| fragmentName `elem` elements = mempty | fragmentName `elem` elements = mempty
| otherwise = pure $ makeError fragmentName location | otherwise = pure $ makeError fragmentName location'
makeError fragName location = Error makeError fragName location' = Error
{ message = errorMessage fragName { message = errorMessage fragName
, locations = [location] , locations = [location']
} }
errorMessage fragName = concat errorMessage fragName = concat
[ "Fragment \"" [ "Fragment \""
@ -440,7 +444,7 @@ filterSelections applyFilter selections
-- on cycles in the underlying data. -- on cycles in the underlying data.
noFragmentCyclesRule :: forall m. Rule m noFragmentCyclesRule :: forall m. Rule m
noFragmentCyclesRule = FragmentDefinitionRule $ \case noFragmentCyclesRule = FragmentDefinitionRule $ \case
FragmentDefinition fragmentName _ _ selections location -> do FragmentDefinition fragmentName _ _ selections location' -> do
state <- evalStateT (collectFields selections) state <- evalStateT (collectFields selections)
(0, fragmentName) (0, fragmentName)
let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state) let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)
@ -453,7 +457,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
, Text.unpack $ Text.intercalate " -> " $ fragmentName : spreadPath , Text.unpack $ Text.intercalate " -> " $ fragmentName : spreadPath
, ")." , ")."
] ]
, locations = [location] , locations = [location']
} }
_ -> lift mempty _ -> lift mempty
where where
@ -502,7 +506,7 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
lift $ filterDuplicates extract "argument" arguments lift $ filterDuplicates extract "argument" arguments
directiveRule (Directive _ arguments _) = directiveRule (Directive _ arguments _) =
lift $ filterDuplicates extract "argument" 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 -- | 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 -- 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 uniqueDirectiveNamesRule = DirectivesRule
$ lift . filterDuplicates extract "directive" $ lift . filterDuplicates extract "directive"
where where
extract (Directive directiveName _ location) = (directiveName, location) extract (Directive directiveName _ location') = (directiveName, location')
filterDuplicates :: (a -> (Text, Location)) -> String -> [a] -> Seq Error filterDuplicates :: (a -> (Text, Location)) -> String -> [a] -> Seq Error
filterDuplicates extract nodeType = Seq.fromList filterDuplicates extract nodeType = Seq.fromList
@ -542,8 +546,8 @@ uniqueVariableNamesRule :: forall m. Rule m
uniqueVariableNamesRule = VariablesRule uniqueVariableNamesRule = VariablesRule
$ lift . filterDuplicates extract "variable" $ lift . filterDuplicates extract "variable"
where where
extract (VariableDefinition variableName _ _ location) = extract (VariableDefinition variableName _ _ location') =
(variableName, location) (variableName, location')
-- | Variables can only be input types. Objects, unions and interfaces cannot be -- | Variables can only be input types. Objects, unions and interfaces cannot be
-- used as inputs. -- used as inputs.
@ -551,12 +555,12 @@ variablesAreInputTypesRule :: forall m. Rule m
variablesAreInputTypesRule = VariablesRule variablesAreInputTypesRule = VariablesRule
$ (traverse check . Seq.fromList) >=> lift $ (traverse check . Seq.fromList) >=> lift
where where
check (VariableDefinition name typeName _ location) check (VariableDefinition name typeName _ location')
= asks types = asks types
>>= lift >>= lift
. maybe (makeError name typeName location) (const mempty) . maybe (makeError name typeName location') (const mempty)
. lookupInputType typeName . lookupInputType typeName
makeError name typeName location = pure $ Error makeError name typeName location' = pure $ Error
{ message = concat { message = concat
[ "Variable \"$" [ "Variable \"$"
, Text.unpack name , Text.unpack name
@ -564,7 +568,7 @@ variablesAreInputTypesRule = VariablesRule
, Text.unpack $ getTypeName typeName , Text.unpack $ getTypeName typeName
, "\"." , "\"."
] ]
, locations = [location] , locations = [location']
} }
getTypeName (TypeNamed name) = name getTypeName (TypeNamed name) = name
getTypeName (TypeList name) = getTypeName name getTypeName (TypeList name) = getTypeName name
@ -610,8 +614,8 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
. difference variableNames' . difference variableNames'
. HashMap.fromListWith (++) . HashMap.fromListWith (++)
. toList . toList
getVariableName (VariableDefinition variableName _ _ location) = getVariableName (VariableDefinition variableName _ _ location') =
(variableName, [location]) (variableName, [location'])
filterSelections' :: Foldable t filterSelections' :: Foldable t
=> t Selection => t Selection
-> ValidationState m (Name, [Location]) -> ValidationState m (Name, [Location])
@ -638,8 +642,8 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
findDirectiveVariables (Directive _ arguments _) = mapArguments arguments findDirectiveVariables (Directive _ arguments _) = mapArguments arguments
mapArguments = Seq.fromList . mapMaybe findArgumentVariables mapArguments = Seq.fromList . mapMaybe findArgumentVariables
mapDirectives = foldMap findDirectiveVariables mapDirectives = foldMap findDirectiveVariables
findArgumentVariables (Argument _ (Node (Variable value) location) _) = findArgumentVariables (Argument _ Node{ value = Variable value', ..} _) =
Just (value, [location]) Just (value', [location])
findArgumentVariables _ = Nothing findArgumentVariables _ = Nothing
makeError operationName (variableName, locations') = Error makeError operationName (variableName, locations') = Error
{ message = errorMessage operationName variableName { message = errorMessage operationName variableName
@ -669,19 +673,15 @@ noUnusedVariablesRule = variableUsageDifference HashMap.difference errorMessage
-- otherwise an ambiguity would exist which includes an ignored portion of -- otherwise an ambiguity would exist which includes an ignored portion of
-- syntax. -- syntax.
uniqueInputFieldNamesRule :: forall m. Rule m uniqueInputFieldNamesRule :: forall m. Rule m
uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo) uniqueInputFieldNamesRule =
ValueRule (const $ lift . go) (const $ lift . constGo)
where where
go (Object fields) = foldMap (objectField go) fields go (Object fields) = filterFieldDuplicates fields
<> filterFieldDuplicates fields
go (List values) = foldMap go values
go _ = mempty go _ = mempty
objectField go' (ObjectField _ fieldValue _) = go' fieldValue
filterFieldDuplicates fields = filterFieldDuplicates fields =
filterDuplicates getFieldName "input field" fields filterDuplicates getFieldName "input field" fields
getFieldName (ObjectField fieldName _ location) = (fieldName, location) getFieldName (ObjectField fieldName _ location') = (fieldName, location')
constGo (ConstObject fields) = foldMap (objectField constGo) fields constGo (ConstObject fields) = filterFieldDuplicates fields
<> filterFieldDuplicates fields
constGo (ConstList values) = foldMap constGo values
constGo _ = mempty constGo _ = mempty
-- | The target field of a field selection must be defined on the scoped type of -- | 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 :: forall m. Rule m
fieldsOnCorrectTypeRule = FieldRule fieldRule fieldsOnCorrectTypeRule = FieldRule fieldRule
where where
fieldRule parentType (Field _ fieldName _ _ _ location) fieldRule parentType (Field _ fieldName _ _ _ location')
| Just objectType <- parentType | Just objectType <- parentType
, Nothing <- lookupTypeField fieldName objectType , Nothing <- lookupTypeField fieldName objectType
, Just typeName <- compositeTypeName objectType = pure $ Error , Just typeName <- compositeTypeName objectType = pure $ Error
{ message = errorMessage fieldName typeName { message = errorMessage fieldName typeName
, locations = [location] , locations = [location']
} }
| otherwise = lift mempty | otherwise = lift mempty
errorMessage fieldName typeName = concat errorMessage fieldName typeName = concat
@ -742,9 +742,9 @@ scalarLeafsRule = FieldRule fieldRule
check (Out.EnumBaseType (Definition.EnumType typeName _ _)) = check (Out.EnumBaseType (Definition.EnumType typeName _ _)) =
checkEmpty typeName checkEmpty typeName
check (Out.ListBaseType wrappedType) = check wrappedType check (Out.ListBaseType wrappedType) = check wrappedType
checkNotEmpty typeName (Field _ fieldName _ _ [] location) = checkNotEmpty typeName (Field _ fieldName _ _ [] location') =
let fieldName' = Text.unpack fieldName let fieldName' = Text.unpack fieldName
in makeError location $ concat in makeError location' $ concat
[ "Field \"" [ "Field \""
, fieldName' , fieldName'
, "\" of type \"" , "\" of type \""
@ -756,17 +756,17 @@ scalarLeafsRule = FieldRule fieldRule
checkNotEmpty _ _ = mempty checkNotEmpty _ _ = mempty
checkEmpty _ (Field _ _ _ _ [] _) = mempty checkEmpty _ (Field _ _ _ _ [] _) = mempty
checkEmpty typeName field' = checkEmpty typeName field' =
let Field _ fieldName _ _ _ location = field' let Field _ fieldName _ _ _ location' = field'
in makeError location $ concat in makeError location' $ concat
[ "Field \"" [ "Field \""
, Text.unpack fieldName , Text.unpack fieldName
, "\" must not have a selection since type \"" , "\" must not have a selection since type \""
, Text.unpack typeName , Text.unpack typeName
, "\" has no subfields." , "\" has no subfields."
] ]
makeError location errorMessage = pure $ Error makeError location' errorMessage = pure $ Error
{ message = errorMessage { message = errorMessage
, locations = [location] , locations = [location']
} }
-- | Every argument provided to a field or directive must be defined in the set -- | 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 = , Just typeName <- compositeTypeName objectType =
lift $ foldr (go typeName fieldName typeField) Seq.empty arguments lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
fieldRule _ _ = lift mempty fieldRule _ _ = lift mempty
go typeName fieldName fieldDefinition (Argument argumentName _ location) errors go typeName fieldName fieldDefinition (Argument argumentName _ location') errors
| Out.Field _ _ definitions <- fieldDefinition | Out.Field _ _ definitions <- fieldDefinition
, Just _ <- HashMap.lookup argumentName definitions = errors , Just _ <- HashMap.lookup argumentName definitions = errors
| otherwise = errors |> Error | otherwise = errors |> Error
{ message = fieldMessage argumentName fieldName typeName { message = fieldMessage argumentName fieldName typeName
, locations = [location] , locations = [location']
} }
fieldMessage argumentName fieldName typeName = concat fieldMessage argumentName fieldName typeName = concat
[ "Unknown argument \"" [ "Unknown argument \""
@ -797,15 +797,15 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
] ]
directiveRule (Directive directiveName arguments _) = do directiveRule (Directive directiveName arguments _) = do
available <- asks $ HashMap.lookup directiveName . directives available <- asks $ HashMap.lookup directiveName . directives
Argument argumentName _ location <- lift $ Seq.fromList arguments Argument argumentName _ location' <- lift $ Seq.fromList arguments
case available of case available of
Just (Schema.Directive _ _ definitions) Just (Schema.Directive _ _ definitions)
| not $ HashMap.member argumentName definitions -> | not $ HashMap.member argumentName definitions ->
pure $ makeError argumentName directiveName location pure $ makeError argumentName directiveName location'
_ -> lift mempty _ -> lift mempty
makeError argumentName directiveName location = Error makeError argumentName directiveName location' = Error
{ message = directiveMessage argumentName directiveName { message = directiveMessage argumentName directiveName
, locations = [location] , locations = [location']
} }
directiveMessage argumentName directiveName = concat directiveMessage argumentName directiveName = concat
[ "Unknown argument \"" [ "Unknown argument \""
@ -829,12 +829,41 @@ knownDirectiveNamesRule = DirectivesRule $ \directives' -> do
definitionFilter difference = flip HashSet.member difference definitionFilter difference = flip HashSet.member difference
. directiveName . directiveName
directiveName (Directive directiveName' _ _) = directiveName' directiveName (Directive directiveName' _ _) = directiveName'
makeError (Directive directiveName' _ location) = Error makeError (Directive directiveName' _ location') = Error
{ message = errorMessage directiveName' { message = errorMessage directiveName'
, locations = [location] , locations = [location']
} }
errorMessage directiveName' = concat errorMessage directiveName' = concat
[ "Unknown directive \"@" [ "Unknown directive \"@"
, Text.unpack directiveName' , 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.HashMap.Strict (HashMap)
import Data.Sequence (Seq) import Data.Sequence (Seq)
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema) import Language.GraphQL.Type.Schema (Schema)
import qualified Language.GraphQL.Type.Schema as Schema import 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) | ArgumentsRule (Maybe (Out.Type m) -> Field -> RuleT m) (Directive -> RuleT m)
| DirectivesRule ([Directive] -> RuleT m) | DirectivesRule ([Directive] -> RuleT m)
| VariablesRule ([VariableDefinition] -> 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. -- | Monad transformer used by the rules.
type RuleT m = ReaderT (Validation m) Seq Error 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 ( spec
) where ) where
import Language.GraphQL.AST import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.AST.Encoder import Language.GraphQL.AST.Encoder
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
import Test.QuickCheck (choose, oneof, forAll) import Test.QuickCheck (choose, oneof, forAll)
@ -15,52 +15,52 @@ spec :: Spec
spec = do spec = do
describe "value" $ do describe "value" $ do
context "null 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 "minified" $ testNull minified
it "pretty" $ testNull pretty it "pretty" $ testNull pretty
context "minified" $ do context "minified" $ do
it "escapes \\" $ it "escapes \\" $
value minified (String "\\") `shouldBe` "\"\\\\\"" value minified (Full.String "\\") `shouldBe` "\"\\\\\""
it "escapes double quotes" $ it "escapes double quotes" $
value minified (String "\"") `shouldBe` "\"\\\"\"" value minified (Full.String "\"") `shouldBe` "\"\\\"\""
it "escapes \\f" $ it "escapes \\f" $
value minified (String "\f") `shouldBe` "\"\\f\"" value minified (Full.String "\f") `shouldBe` "\"\\f\""
it "escapes \\n" $ it "escapes \\n" $
value minified (String "\n") `shouldBe` "\"\\n\"" value minified (Full.String "\n") `shouldBe` "\"\\n\""
it "escapes \\r" $ it "escapes \\r" $
value minified (String "\r") `shouldBe` "\"\\r\"" value minified (Full.String "\r") `shouldBe` "\"\\r\""
it "escapes \\t" $ it "escapes \\t" $
value minified (String "\t") `shouldBe` "\"\\t\"" value minified (Full.String "\t") `shouldBe` "\"\\t\""
it "escapes backspace" $ 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 context "escapes Unicode for chars less than 0010" $ do
it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\"" it "Null" $ value minified (Full.String "\x0000") `shouldBe` "\"\\u0000\""
it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\"" it "bell" $ value minified (Full.String "\x0007") `shouldBe` "\"\\u0007\""
context "escapes Unicode for char less than 0020" $ do context "escapes Unicode for char less than 0020" $ do
it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\"" it "DLE" $ value minified (Full.String "\x0010") `shouldBe` "\"\\u0010\""
it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\"" it "EM" $ value minified (Full.String "\x0019") `shouldBe` "\"\\u0019\""
context "encodes without escape" $ do context "encodes without escape" $ do
it "space" $ value minified (String "\x0020") `shouldBe` "\" \"" it "space" $ value minified (Full.String "\x0020") `shouldBe` "\" \""
it "~" $ value minified (String "\x007E") `shouldBe` "\"~\"" it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\""
context "pretty" $ do context "pretty" $ do
it "uses strings for short string values" $ 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" $ 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|""" `shouldBe` [r|"""
Line 1 Line 1
Line 2 Line 2
"""|] """|]
it "uses block strings for text with new lines, with CR symbol" $ 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|""" `shouldBe` [r|"""
Line 1 Line 1
Line 2 Line 2
"""|] """|]
it "uses block strings for text with new lines, with CR symbol followed by newline" $ 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|""" `shouldBe` [r|"""
Line 1 Line 1
Line 2 Line 2
@ -77,12 +77,12 @@ spec = do
forAll genNotAllowedSymbol $ \x -> do forAll genNotAllowedSymbol $ \x -> do
let let
rawValue = "Short \n" <> cons x "text" rawValue = "Short \n" <> cons x "text"
encoded = value pretty (String $ toStrict rawValue) encoded = value pretty (Full.String $ toStrict rawValue)
shouldStartWith (unpack encoded) "\"" shouldStartWith (unpack encoded) "\""
shouldEndWith (unpack encoded) "\"" shouldEndWith (unpack encoded) "\""
shouldNotContain (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|""" `shouldBe` [r|"""
Hello, Hello,
World! World!
@ -91,29 +91,29 @@ spec = do
GraphQL. 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" $ 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 a
"""|] """|]
it "has newlines and one symbol at the end" $ 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 a
"""|] """|]
it "has newlines and one symbol in the middle" $ 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 a
"""|] """|]
it "skip trailing whitespaces" $ value pretty (String " Short\ntext ") it "skip trailing whitespaces" $ value pretty (Full.String " Short\ntext ")
`shouldBe` [r|""" `shouldBe` [r|"""
Short Short
text text
@ -121,12 +121,13 @@ spec = do
describe "definition" $ describe "definition" $
it "indents block strings in arguments" $ it "indents block strings in arguments" $
let location = Location 0 0 let location = Full.Location 0 0
argumentValue = Node (String "line1\nline2") location argumentValue = Full.Node (Full.String "line1\nline2") location
arguments = [Argument "message" argumentValue location] arguments = [Full.Argument "message" argumentValue location]
field = Field Nothing "field" arguments [] [] location field = Full.Field Nothing "field" arguments [] [] location
operation = DefinitionOperation fieldSelection = pure $ Full.FieldSelection field
$ SelectionSet (pure $ FieldSelection field) location operation = Full.DefinitionOperation
$ Full.SelectionSet fieldSelection location
in definition pretty operation `shouldBe` [r|{ in definition pretty operation `shouldBe` [r|{
field(message: """ field(message: """
line1 line1

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

@ -590,3 +590,19 @@ spec =
, locations = [AST.Location 4 54] , locations = [AST.Location 4 54]
} }
in validate queryString `shouldBe` [expected] 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]