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