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