aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/AST/DirectiveLocation.hs36
-rw-r--r--src/Language/GraphQL/AST/Document.hs108
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs223
-rw-r--r--src/Language/GraphQL/AST/Lexer.hs8
-rw-r--r--src/Language/GraphQL/AST/Parser.hs368
-rw-r--r--src/Language/GraphQL/Error.hs24
-rw-r--r--src/Language/GraphQL/Execute.hs4
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs23
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs138
-rw-r--r--src/Language/GraphQL/Type.hs2
-rw-r--r--src/Language/GraphQL/Type/In.hs26
-rw-r--r--src/Language/GraphQL/Type/Internal.hs176
-rw-r--r--src/Language/GraphQL/Type/Out.hs2
-rw-r--r--src/Language/GraphQL/Type/Schema.hs164
-rw-r--r--src/Language/GraphQL/Validate.hs541
-rw-r--r--src/Language/GraphQL/Validate/Rules.hs938
-rw-r--r--src/Language/GraphQL/Validate/Validation.hs32
17 files changed, 2129 insertions, 684 deletions
diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs
index c38c9ff..511225f 100644
--- a/src/Language/GraphQL/AST/DirectiveLocation.hs
+++ b/src/Language/GraphQL/AST/DirectiveLocation.hs
@@ -2,6 +2,8 @@
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
+{-# LANGUAGE Safe #-}
+
-- | Various parts of a GraphQL document can be annotated with directives.
-- This module describes locations in a document where directives can appear.
module Language.GraphQL.AST.DirectiveLocation
@@ -16,7 +18,13 @@ module Language.GraphQL.AST.DirectiveLocation
data DirectiveLocation
= ExecutableDirectiveLocation ExecutableDirectiveLocation
| TypeSystemDirectiveLocation TypeSystemDirectiveLocation
- deriving (Eq, Show)
+ deriving Eq
+
+instance Show DirectiveLocation where
+ show (ExecutableDirectiveLocation directiveLocation) =
+ show directiveLocation
+ show (TypeSystemDirectiveLocation directiveLocation) =
+ show directiveLocation
-- | Where directives can appear in an executable definition, like a query.
data ExecutableDirectiveLocation
@@ -27,7 +35,16 @@ data ExecutableDirectiveLocation
| FragmentDefinition
| FragmentSpread
| InlineFragment
- deriving (Eq, Show)
+ deriving Eq
+
+instance Show ExecutableDirectiveLocation where
+ show Query = "QUERY"
+ show Mutation = "MUTATION"
+ show Subscription = "SUBSCRIPTION"
+ show Field = "FIELD"
+ show FragmentDefinition = "FRAGMENT_DEFINITION"
+ show FragmentSpread = "FRAGMENT_SPREAD"
+ show InlineFragment = "INLINE_FRAGMENT"
-- | Where directives can appear in a type system definition.
data TypeSystemDirectiveLocation
@@ -42,4 +59,17 @@ data TypeSystemDirectiveLocation
| EnumValue
| InputObject
| InputFieldDefinition
- deriving (Eq, Show)
+ deriving Eq
+
+instance Show TypeSystemDirectiveLocation where
+ show Schema = "SCHEMA"
+ show Scalar = "SCALAR"
+ show Object = "OBJECT"
+ show FieldDefinition = "FIELD_DEFINITION"
+ show ArgumentDefinition = "ARGUMENT_DEFINITION"
+ show Interface = "INTERFACE"
+ show Union = "UNION"
+ show Enum = "ENUM"
+ show EnumValue = "ENUM_VALUE"
+ show InputObject = "INPUT_OBJECT"
+ show InputFieldDefinition = "INPUT_FIELD_DEFINITION"
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index 72d39bb..b30271c 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -1,12 +1,15 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Safe #-}
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
-- follows closely the structure given in the specification. Please refer to
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
-- for more information.
module Language.GraphQL.AST.Document
- ( Alias
- , Argument(..)
+ ( Argument(..)
, ArgumentsDefinition(..)
, ConstValue(..)
, Definition(..)
@@ -15,13 +18,17 @@ module Language.GraphQL.AST.Document
, Document
, EnumValueDefinition(..)
, ExecutableDefinition(..)
+ , Field(..)
, FieldDefinition(..)
, FragmentDefinition(..)
+ , FragmentSpread(..)
, ImplementsInterfaces(..)
+ , InlineFragment(..)
, InputValueDefinition(..)
, Location(..)
, Name
, NamedType
+ , Node(..)
, NonNullType(..)
, ObjectField(..)
, OperationDefinition(..)
@@ -47,7 +54,7 @@ import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import qualified Data.Text as Text
-import Language.GraphQL.AST.DirectiveLocation
+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
-- * Language
@@ -68,6 +75,15 @@ instance Ord Location where
| thisLine > thatLine = GT
| otherwise = compare thisColumn thatColumn
+-- | Contains some tree node with a location.
+data Node a = Node
+ { node :: a
+ , location :: Location
+ } deriving (Eq, Show)
+
+instance Functor Node where
+ fmap f Node{..} = Node (f node) location
+
-- ** Document
-- | GraphQL document.
@@ -116,10 +132,15 @@ type SelectionSet = NonEmpty Selection
-- | Field selection.
type SelectionSetOpt = [Selection]
--- | Selection is a single entry in a selection set. It can be a single field,
--- fragment spread or inline fragment.
---
--- The only required property of a field is its name. Optionally it can also
+-- | Selection is a single entry in a selection set. It can be a single 'Field',
+-- 'FragmentSpread' or an 'InlineFragment'.
+data Selection
+ = FieldSelection Field
+ | FragmentSpreadSelection FragmentSpread
+ | InlineFragmentSelection InlineFragment
+ deriving (Eq, Show)
+
+-- | The only required property of a field is its name. Optionally it can also
-- have an alias, arguments, directives and a list of subfields.
--
-- In the following query "user" is a field with two subfields, "id" and "name":
@@ -132,8 +153,27 @@ type SelectionSetOpt = [Selection]
-- }
-- }
-- @
+data Field =
+ Field (Maybe Name) Name [Argument] [Directive] SelectionSetOpt Location
+ deriving (Eq, Show)
+
+-- | Inline fragments don't have any name and the type condition ("on UserType")
+-- is optional.
--
--- A fragment spread refers to a fragment defined outside the operation and is
+-- @
+-- {
+-- user {
+-- ... on UserType {
+-- id
+-- name
+-- }
+-- }
+-- @
+data InlineFragment = InlineFragment
+ (Maybe TypeCondition) [Directive] SelectionSet Location
+ deriving (Eq, Show)
+
+-- | A fragment spread refers to a fragment defined outside the operation and is
-- expanded at the execution time.
--
-- @
@@ -148,23 +188,7 @@ type SelectionSetOpt = [Selection]
-- name
-- }
-- @
---
--- Inline fragments are similar but they don't have any name and the type
--- condition ("on UserType") is optional.
---
--- @
--- {
--- user {
--- ... on UserType {
--- id
--- name
--- }
--- }
--- @
-data Selection
- = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
- | FragmentSpread Name [Directive]
- | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
+data FragmentSpread = FragmentSpread Name [Directive] Location
deriving (Eq, Show)
-- ** Arguments
@@ -180,23 +204,7 @@ data Selection
-- @
--
-- Here "id" is an argument for the field "user" and its value is 4.
-data Argument = Argument Name Value deriving (Eq,Show)
-
--- ** Field Alias
-
--- | Alternative field name.
---
--- @
--- {
--- smallPic: profilePic(size: 64)
--- bigPic: profilePic(size: 1024)
--- }
--- @
---
--- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
--- used to distinquish between profile pictures with different arguments
--- (sizes).
-type Alias = Name
+data Argument = Argument Name (Node Value) Location deriving (Eq, Show)
-- ** Fragments
@@ -238,8 +246,11 @@ data ConstValue
-- | Key-value pair.
--
-- A list of 'ObjectField's represents a GraphQL object type.
-data ObjectField a = ObjectField Name a
- deriving (Eq, Show)
+data ObjectField a = ObjectField
+ { name :: Name
+ , value :: Node a
+ , location :: Location
+ } deriving (Eq, Show)
-- ** Variables
@@ -259,7 +270,8 @@ data ObjectField a = ObjectField Name a
--
-- Variables are usually passed along with the query, but not in the query
-- itself. They make queries reusable.
-data VariableDefinition = VariableDefinition Name Type (Maybe ConstValue)
+data VariableDefinition =
+ VariableDefinition Name Type (Maybe (Node ConstValue)) Location
deriving (Eq, Show)
-- ** Type References
@@ -286,7 +298,7 @@ data NonNullType
--
-- Directives begin with "@", can accept arguments, and can be applied to the
-- most GraphQL elements, providing additional information.
-data Directive = Directive Name [Argument] deriving (Eq, Show)
+data Directive = Directive Name [Argument] Location deriving (Eq, Show)
-- * Type System
@@ -485,8 +497,8 @@ instance Monoid ArgumentsDefinition where
-- @
--
-- The input type "Point2D" contains two value definitions: "x" and "y".
-data InputValueDefinition
- = InputValueDefinition Description Name Type (Maybe ConstValue) [Directive]
+data InputValueDefinition = InputValueDefinition
+ Description Name Type (Maybe (Node ConstValue)) [Directive]
deriving (Eq, Show)
-- ** Unions
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index ba89d36..9ba51b8 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Safe #-}
-- | This module defines a minifier and a printer for the @GraphQL@ language.
module Language.GraphQL.AST.Encoder
@@ -25,7 +27,7 @@ import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Builder
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
-import Language.GraphQL.AST.Document
+import qualified Language.GraphQL.AST.Document as Full
-- | Instructs the encoder whether the GraphQL document should be minified or
-- pretty printed.
@@ -44,77 +46,78 @@ minified :: Formatter
minified = Minified
-- | Converts a Document' into a string.
-document :: Formatter -> Document -> Lazy.Text
+document :: Formatter -> Full.Document -> Lazy.Text
document formatter defs
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
where
encodeDocument = foldr executableDefinition [] defs
- executableDefinition (ExecutableDefinition executableDefinition') acc =
+ executableDefinition (Full.ExecutableDefinition executableDefinition') acc =
definition formatter executableDefinition' : acc
executableDefinition _ acc = acc
--- | Converts a t'ExecutableDefinition' into a string.
-definition :: Formatter -> ExecutableDefinition -> Lazy.Text
+-- | Converts a t'Full.ExecutableDefinition' into a string.
+definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
definition formatter x
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
| Minified <- formatter = encodeDefinition x
where
- encodeDefinition (DefinitionOperation operation)
+ encodeDefinition (Full.DefinitionOperation operation)
= operationDefinition formatter operation
- encodeDefinition (DefinitionFragment fragment)
+ encodeDefinition (Full.DefinitionFragment fragment)
= fragmentDefinition formatter fragment
--- | Converts a 'OperationDefinition into a string.
-operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
+-- | Converts a 'Full.OperationDefinition into a string.
+operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
operationDefinition formatter = \case
- SelectionSet sels _ -> selectionSet formatter sels
- OperationDefinition Query name vars dirs sels _ ->
- "query " <> node formatter name vars dirs sels
- OperationDefinition Mutation name vars dirs sels _ ->
- "mutation " <> node formatter name vars dirs sels
- OperationDefinition Subscription name vars dirs sels _ ->
- "subscription " <> node formatter name vars dirs sels
-
--- | Converts a Query or Mutation into a string.
-node :: Formatter ->
- Maybe Name ->
- [VariableDefinition] ->
- [Directive] ->
- SelectionSet ->
- Lazy.Text
-node formatter name vars dirs sels
- = Lazy.Text.fromStrict (fold name)
- <> optempty (variableDefinitions formatter) vars
- <> optempty (directives formatter) dirs
- <> eitherFormat formatter " " mempty
- <> selectionSet formatter sels
-
-variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text
+ Full.SelectionSet sels _ -> selectionSet formatter sels
+ Full.OperationDefinition Full.Query name vars dirs sels _ ->
+ "query " <> root name vars dirs sels
+ Full.OperationDefinition Full.Mutation name vars dirs sels _ ->
+ "mutation " <> root name vars dirs sels
+ Full.OperationDefinition Full.Subscription name vars dirs sels _ ->
+ "subscription " <> root name vars dirs sels
+ where
+ -- | Converts a Query or Mutation into a string.
+ root :: Maybe Full.Name ->
+ [Full.VariableDefinition] ->
+ [Full.Directive] ->
+ Full.SelectionSet ->
+ Lazy.Text
+ root name vars dirs sels
+ = Lazy.Text.fromStrict (fold name)
+ <> optempty (variableDefinitions formatter) vars
+ <> optempty (directives formatter) dirs
+ <> eitherFormat formatter " " mempty
+ <> selectionSet formatter sels
+
+variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
variableDefinitions formatter
= parensCommas formatter $ variableDefinition formatter
-variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text
-variableDefinition formatter (VariableDefinition var ty defaultValue')
- = variable var
+variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
+variableDefinition formatter variableDefinition' =
+ let Full.VariableDefinition variableName variableType defaultValue' _ =
+ variableDefinition'
+ in variable variableName
<> eitherFormat formatter ": " ":"
- <> type' ty
- <> maybe mempty (defaultValue formatter) defaultValue'
+ <> type' variableType
+ <> maybe mempty (defaultValue formatter) (Full.node <$> defaultValue')
-defaultValue :: Formatter -> ConstValue -> Lazy.Text
+defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text
defaultValue formatter val
= eitherFormat formatter " = " "="
<> value formatter (fromConstValue val)
-variable :: Name -> Lazy.Text
+variable :: Full.Name -> Lazy.Text
variable var = "$" <> Lazy.Text.fromStrict var
-selectionSet :: Formatter -> SelectionSet -> Lazy.Text
+selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
selectionSet formatter
= bracesList formatter (selection formatter)
. NonEmpty.toList
-selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text
+selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
selectionSetOpt formatter = bracesList formatter $ selection formatter
indentSymbol :: Lazy.Text
@@ -123,15 +126,15 @@ indentSymbol = " "
indent :: (Integral a) => a -> Lazy.Text
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
-selection :: Formatter -> Selection -> Lazy.Text
+selection :: Formatter -> Full.Selection -> Lazy.Text
selection formatter = Lazy.Text.append indent' . encodeSelection
where
- encodeSelection (Field alias name args directives' selections) =
- field incrementIndent alias name args directives' selections
- encodeSelection (InlineFragment typeCondition directives' selections) =
- inlineFragment incrementIndent typeCondition directives' selections
- encodeSelection (FragmentSpread name directives') =
- fragmentSpread incrementIndent name directives'
+ encodeSelection (Full.FieldSelection fieldSelection) =
+ field incrementIndent fieldSelection
+ encodeSelection (Full.InlineFragmentSelection fragmentSelection) =
+ inlineFragment incrementIndent fragmentSelection
+ encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =
+ fragmentSpread incrementIndent fragmentSelection
incrementIndent
| Pretty indentation <- formatter = Pretty $ indentation + 1
| otherwise = Minified
@@ -142,15 +145,9 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
colon :: Formatter -> Lazy.Text
colon formatter = eitherFormat formatter ": " ":"
--- | Converts Field into a string
-field :: Formatter ->
- Maybe Name ->
- Name ->
- [Argument] ->
- [Directive] ->
- [Selection] ->
- Lazy.Text
-field formatter alias name args dirs set
+-- | Converts Field into a string.
+field :: Formatter -> Full.Field -> Lazy.Text
+field formatter (Full.Field alias name args dirs set _)
= optempty prependAlias (fold alias)
<> Lazy.Text.fromStrict name
<> optempty (arguments formatter) args
@@ -161,36 +158,32 @@ field formatter alias name args dirs set
selectionSetOpt' = (eitherFormat formatter " " "" <>)
. selectionSetOpt formatter
-arguments :: Formatter -> [Argument] -> Lazy.Text
+arguments :: Formatter -> [Full.Argument] -> Lazy.Text
arguments formatter = parensCommas formatter $ argument formatter
-argument :: Formatter -> Argument -> Lazy.Text
-argument formatter (Argument name value')
+argument :: Formatter -> Full.Argument -> Lazy.Text
+argument formatter (Full.Argument name value' _)
= Lazy.Text.fromStrict name
<> colon formatter
- <> value formatter value'
+ <> value formatter (Full.node value')
-- * Fragments
-fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
-fragmentSpread formatter name directives'
+fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
+fragmentSpread formatter (Full.FragmentSpread name directives' _)
= "..." <> Lazy.Text.fromStrict name
<> optempty (directives formatter) directives'
-inlineFragment ::
- Formatter ->
- Maybe TypeCondition ->
- [Directive] ->
- SelectionSet ->
- Lazy.Text
-inlineFragment formatter tc dirs sels = "... on "
- <> Lazy.Text.fromStrict (fold tc)
- <> directives formatter dirs
+inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
+inlineFragment formatter (Full.InlineFragment typeCondition directives' selections _)
+ = "... on "
+ <> Lazy.Text.fromStrict (fold typeCondition)
+ <> directives formatter directives'
<> eitherFormat formatter " " mempty
- <> selectionSet formatter sels
+ <> selectionSet formatter selections
-fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
-fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
+fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
+fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels _)
= "fragment " <> Lazy.Text.fromStrict name
<> " on " <> Lazy.Text.fromStrict tc
<> optempty (directives formatter) dirs
@@ -199,39 +192,39 @@ fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
-- * Miscellaneous
--- | Converts a 'Directive' into a string.
-directive :: Formatter -> Directive -> Lazy.Text
-directive formatter (Directive name args)
+-- | Converts a 'Full.Directive' into a string.
+directive :: Formatter -> Full.Directive -> Lazy.Text
+directive formatter (Full.Directive name args _)
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
-directives :: Formatter -> [Directive] -> Lazy.Text
+directives :: Formatter -> [Full.Directive] -> Lazy.Text
directives Minified = spaces (directive Minified)
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
--- | Converts a 'Value' into a string.
-value :: Formatter -> Value -> Lazy.Text
-value _ (Variable x) = variable x
-value _ (Int x) = Builder.toLazyText $ decimal x
-value _ (Float x) = Builder.toLazyText $ realFloat x
-value _ (Boolean x) = booleanValue x
-value _ Null = "null"
-value formatter (String string) = stringValue formatter string
-value _ (Enum x) = Lazy.Text.fromStrict x
-value formatter (List x) = listValue formatter x
-value formatter (Object x) = objectValue formatter x
-
-fromConstValue :: ConstValue -> Value
-fromConstValue (ConstInt x) = Int x
-fromConstValue (ConstFloat x) = Float x
-fromConstValue (ConstBoolean x) = Boolean x
-fromConstValue ConstNull = Null
-fromConstValue (ConstString string) = String string
-fromConstValue (ConstEnum x) = Enum x
-fromConstValue (ConstList x) = List $ fromConstValue <$> x
-fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x
+-- | Converts a 'Full.Value' into a string.
+value :: Formatter -> Full.Value -> Lazy.Text
+value _ (Full.Variable x) = variable x
+value _ (Full.Int x) = Builder.toLazyText $ decimal x
+value _ (Full.Float x) = Builder.toLazyText $ realFloat x
+value _ (Full.Boolean x) = booleanValue x
+value _ Full.Null = "null"
+value formatter (Full.String string) = stringValue formatter string
+value _ (Full.Enum x) = Lazy.Text.fromStrict x
+value formatter (Full.List x) = listValue formatter x
+value formatter (Full.Object x) = objectValue formatter x
+
+fromConstValue :: Full.ConstValue -> Full.Value
+fromConstValue (Full.ConstInt x) = Full.Int x
+fromConstValue (Full.ConstFloat x) = Full.Float x
+fromConstValue (Full.ConstBoolean x) = Full.Boolean x
+fromConstValue Full.ConstNull = Full.Null
+fromConstValue (Full.ConstString string) = Full.String string
+fromConstValue (Full.ConstEnum x) = Full.Enum x
+fromConstValue (Full.ConstList x) = Full.List $ fromConstValue <$> x
+fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x
where
- fromConstObjectField (ObjectField key value') =
- ObjectField key $ fromConstValue value'
+ fromConstObjectField Full.ObjectField{value = value', ..} =
+ Full.ObjectField name (fromConstValue <$> value') location
booleanValue :: Bool -> Lazy.Text
booleanValue True = "true"
@@ -288,10 +281,10 @@ escape char'
where
unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
-listValue :: Formatter -> [Value] -> Lazy.Text
+listValue :: Formatter -> [Full.Value] -> Lazy.Text
listValue formatter = bracketsCommas formatter $ value formatter
-objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text
+objectValue :: Formatter -> [Full.ObjectField Full.Value] -> Lazy.Text
objectValue formatter = intercalate $ objectField formatter
where
intercalate f
@@ -299,22 +292,22 @@ objectValue formatter = intercalate $ objectField formatter
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
. fmap f
-objectField :: Formatter -> ObjectField Value -> Lazy.Text
-objectField formatter (ObjectField name value') =
+objectField :: Formatter -> Full.ObjectField Full.Value -> Lazy.Text
+objectField formatter (Full.ObjectField name (Full.Node value' _) _) =
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
--- | Converts a 'Type' a type into a string.
-type' :: Type -> Lazy.Text
-type' (TypeNamed x) = Lazy.Text.fromStrict x
-type' (TypeList x) = listType x
-type' (TypeNonNull x) = nonNullType x
+-- | Converts a 'Full.Type' a type into a string.
+type' :: Full.Type -> Lazy.Text
+type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
+type' (Full.TypeList x) = listType x
+type' (Full.TypeNonNull x) = nonNullType x
-listType :: Type -> Lazy.Text
+listType :: Full.Type -> Lazy.Text
listType x = brackets (type' x)
-nonNullType :: NonNullType -> Lazy.Text
-nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
-nonNullType (NonNullTypeList x) = listType x <> "!"
+nonNullType :: Full.NonNullType -> Lazy.Text
+nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
+nonNullType (Full.NonNullTypeList x) = listType x <> "!"
-- * Internal
diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs
index 17d3f9c..ecefaf6 100644
--- a/src/Language/GraphQL/AST/Lexer.hs
+++ b/src/Language/GraphQL/AST/Lexer.hs
@@ -92,16 +92,16 @@ dollar :: Parser T.Text
dollar = symbol "$"
-- | Parser for "@".
-at :: Parser Text
-at = symbol "@"
+at :: Parser ()
+at = symbol "@" >> pure ()
-- | Parser for "&".
amp :: Parser T.Text
amp = symbol "&"
-- | Parser for ":".
-colon :: Parser T.Text
-colon = symbol ":"
+colon :: Parser ()
+colon = symbol ":" >> pure ()
-- | Parser for "=".
equals :: Parser T.Text
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index 7bc51cb..46c8fa3 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@@ -18,7 +19,7 @@ import Language.GraphQL.AST.DirectiveLocation
, ExecutableDirectiveLocation
, TypeSystemDirectiveLocation
)
-import Language.GraphQL.AST.Document
+import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.AST.Lexer
import Text.Megaparsec
( MonadParsec(..)
@@ -32,13 +33,13 @@ import Text.Megaparsec
)
-- | Parser for the GraphQL documents.
-document :: Parser Document
+document :: Parser Full.Document
document = unicodeBOM
*> spaceConsumer
*> lexeme (NonEmpty.some definition)
-definition :: Parser Definition
-definition = ExecutableDefinition <$> executableDefinition
+definition :: Parser Full.Definition
+definition = Full.ExecutableDefinition <$> executableDefinition
<|> typeSystemDefinition'
<|> typeSystemExtension'
<?> "Definition"
@@ -46,41 +47,41 @@ definition = ExecutableDefinition <$> executableDefinition
typeSystemDefinition' = do
location <- getLocation
definition' <- typeSystemDefinition
- pure $ TypeSystemDefinition definition' location
+ pure $ Full.TypeSystemDefinition definition' location
typeSystemExtension' = do
location <- getLocation
definition' <- typeSystemExtension
- pure $ TypeSystemExtension definition' location
+ pure $ Full.TypeSystemExtension definition' location
-getLocation :: Parser Location
+getLocation :: Parser Full.Location
getLocation = fromSourcePosition <$> getSourcePos
where
fromSourcePosition SourcePos{..} =
- Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
+ Full.Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
wordFromPosition = fromIntegral . unPos
-executableDefinition :: Parser ExecutableDefinition
-executableDefinition = DefinitionOperation <$> operationDefinition
- <|> DefinitionFragment <$> fragmentDefinition
+executableDefinition :: Parser Full.ExecutableDefinition
+executableDefinition = Full.DefinitionOperation <$> operationDefinition
+ <|> Full.DefinitionFragment <$> fragmentDefinition
<?> "ExecutableDefinition"
-typeSystemDefinition :: Parser TypeSystemDefinition
+typeSystemDefinition :: Parser Full.TypeSystemDefinition
typeSystemDefinition = schemaDefinition
<|> typeSystemDefinitionWithDescription
<?> "TypeSystemDefinition"
where
typeSystemDefinitionWithDescription = description
>>= liftA2 (<|>) typeDefinition' directiveDefinition
- typeDefinition' description' = TypeDefinition
+ typeDefinition' description' = Full.TypeDefinition
<$> typeDefinition description'
-typeSystemExtension :: Parser TypeSystemExtension
-typeSystemExtension = SchemaExtension <$> schemaExtension
- <|> TypeExtension <$> typeExtension
+typeSystemExtension :: Parser Full.TypeSystemExtension
+typeSystemExtension = Full.SchemaExtension <$> schemaExtension
+ <|> Full.TypeExtension <$> typeExtension
<?> "TypeSystemExtension"
-directiveDefinition :: Description -> Parser TypeSystemDefinition
-directiveDefinition description' = DirectiveDefinition description'
+directiveDefinition :: Full.Description -> Parser Full.TypeSystemDefinition
+directiveDefinition description' = Full.DirectiveDefinition description'
<$ symbol "directive"
<* at
<*> name
@@ -124,7 +125,7 @@ typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
<|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
<?> "TypeSystemDirectiveLocation"
-typeDefinition :: Description -> Parser TypeDefinition
+typeDefinition :: Full.Description -> Parser Full.TypeDefinition
typeDefinition description' = scalarTypeDefinition description'
<|> objectTypeDefinition description'
<|> interfaceTypeDefinition description'
@@ -133,7 +134,7 @@ typeDefinition description' = scalarTypeDefinition description'
<|> inputObjectTypeDefinition description'
<?> "TypeDefinition"
-typeExtension :: Parser TypeExtension
+typeExtension :: Parser Full.TypeExtension
typeExtension = scalarTypeExtension
<|> objectTypeExtension
<|> interfaceTypeExtension
@@ -142,143 +143,143 @@ typeExtension = scalarTypeExtension
<|> inputObjectTypeExtension
<?> "TypeExtension"
-scalarTypeDefinition :: Description -> Parser TypeDefinition
-scalarTypeDefinition description' = ScalarTypeDefinition description'
+scalarTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
+scalarTypeDefinition description' = Full.ScalarTypeDefinition description'
<$ symbol "scalar"
<*> name
<*> directives
<?> "ScalarTypeDefinition"
-scalarTypeExtension :: Parser TypeExtension
+scalarTypeExtension :: Parser Full.TypeExtension
scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
- $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
+ $ (Full.ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
-objectTypeDefinition :: Description -> Parser TypeDefinition
-objectTypeDefinition description' = ObjectTypeDefinition description'
+objectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
+objectTypeDefinition description' = Full.ObjectTypeDefinition description'
<$ symbol "type"
<*> name
- <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
+ <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> directives
<*> braces (many fieldDefinition)
<?> "ObjectTypeDefinition"
-objectTypeExtension :: Parser TypeExtension
+objectTypeExtension :: Parser Full.TypeExtension
objectTypeExtension = extend "type" "ObjectTypeExtension"
$ fieldsDefinitionExtension :|
[ directivesExtension
, implementsInterfacesExtension
]
where
- fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension
+ fieldsDefinitionExtension = Full.ObjectTypeFieldsDefinitionExtension
<$> name
- <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
+ <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> directives
<*> braces (NonEmpty.some fieldDefinition)
- directivesExtension = ObjectTypeDirectivesExtension
+ directivesExtension = Full.ObjectTypeDirectivesExtension
<$> name
- <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
+ <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> NonEmpty.some directive
- implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension
+ implementsInterfacesExtension = Full.ObjectTypeImplementsInterfacesExtension
<$> name
<*> implementsInterfaces NonEmpty.sepBy1
-description :: Parser Description
-description = Description
+description :: Parser Full.Description
+description = Full.Description
<$> optional stringValue
<?> "Description"
-unionTypeDefinition :: Description -> Parser TypeDefinition
-unionTypeDefinition description' = UnionTypeDefinition description'
+unionTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
+unionTypeDefinition description' = Full.UnionTypeDefinition description'
<$ symbol "union"
<*> name
<*> directives
- <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)
+ <*> option (Full.UnionMemberTypes []) (unionMemberTypes sepBy1)
<?> "UnionTypeDefinition"
-unionTypeExtension :: Parser TypeExtension
+unionTypeExtension :: Parser Full.TypeExtension
unionTypeExtension = extend "union" "UnionTypeExtension"
$ unionMemberTypesExtension :| [directivesExtension]
where
- unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension
+ unionMemberTypesExtension = Full.UnionTypeUnionMemberTypesExtension
<$> name
<*> directives
<*> unionMemberTypes NonEmpty.sepBy1
- directivesExtension = UnionTypeDirectivesExtension
+ directivesExtension = Full.UnionTypeDirectivesExtension
<$> name
<*> NonEmpty.some directive
unionMemberTypes ::
Foldable t =>
- (Parser Text -> Parser Text -> Parser (t NamedType)) ->
- Parser (UnionMemberTypes t)
-unionMemberTypes sepBy' = UnionMemberTypes
+ (Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
+ Parser (Full.UnionMemberTypes t)
+unionMemberTypes sepBy' = Full.UnionMemberTypes
<$ equals
<* optional pipe
<*> name `sepBy'` pipe
<?> "UnionMemberTypes"
-interfaceTypeDefinition :: Description -> Parser TypeDefinition
-interfaceTypeDefinition description' = InterfaceTypeDefinition description'
+interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
+interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
<$ symbol "interface"
<*> name
<*> directives
<*> braces (many fieldDefinition)
<?> "InterfaceTypeDefinition"
-interfaceTypeExtension :: Parser TypeExtension
+interfaceTypeExtension :: Parser Full.TypeExtension
interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
$ fieldsDefinitionExtension :| [directivesExtension]
where
- fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension
+ fieldsDefinitionExtension = Full.InterfaceTypeFieldsDefinitionExtension
<$> name
<*> directives
<*> braces (NonEmpty.some fieldDefinition)
- directivesExtension = InterfaceTypeDirectivesExtension
+ directivesExtension = Full.InterfaceTypeDirectivesExtension
<$> name
<*> NonEmpty.some directive
-enumTypeDefinition :: Description -> Parser TypeDefinition
-enumTypeDefinition description' = EnumTypeDefinition description'
+enumTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
+enumTypeDefinition description' = Full.EnumTypeDefinition description'
<$ symbol "enum"
<*> name
<*> directives
<*> listOptIn braces enumValueDefinition
<?> "EnumTypeDefinition"
-enumTypeExtension :: Parser TypeExtension
+enumTypeExtension :: Parser Full.TypeExtension
enumTypeExtension = extend "enum" "EnumTypeExtension"
$ enumValuesDefinitionExtension :| [directivesExtension]
where
- enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension
+ enumValuesDefinitionExtension = Full.EnumTypeEnumValuesDefinitionExtension
<$> name
<*> directives
<*> braces (NonEmpty.some enumValueDefinition)
- directivesExtension = EnumTypeDirectivesExtension
+ directivesExtension = Full.EnumTypeDirectivesExtension
<$> name
<*> NonEmpty.some directive
-inputObjectTypeDefinition :: Description -> Parser TypeDefinition
-inputObjectTypeDefinition description' = InputObjectTypeDefinition description'
+inputObjectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
+inputObjectTypeDefinition description' = Full.InputObjectTypeDefinition description'
<$ symbol "input"
<*> name
<*> directives
<*> listOptIn braces inputValueDefinition
<?> "InputObjectTypeDefinition"
-inputObjectTypeExtension :: Parser TypeExtension
+inputObjectTypeExtension :: Parser Full.TypeExtension
inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
$ inputFieldsDefinitionExtension :| [directivesExtension]
where
- inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension
+ inputFieldsDefinitionExtension = Full.InputObjectTypeInputFieldsDefinitionExtension
<$> name
<*> directives
<*> braces (NonEmpty.some inputValueDefinition)
- directivesExtension = InputObjectTypeDirectivesExtension
+ directivesExtension = Full.InputObjectTypeDirectivesExtension
<$> name
<*> NonEmpty.some directive
-enumValueDefinition :: Parser EnumValueDefinition
-enumValueDefinition = EnumValueDefinition
+enumValueDefinition :: Parser Full.EnumValueDefinition
+enumValueDefinition = Full.EnumValueDefinition
<$> description
<*> enumValue
<*> directives
@@ -286,16 +287,16 @@ enumValueDefinition = EnumValueDefinition
implementsInterfaces ::
Foldable t =>
- (Parser Text -> Parser Text -> Parser (t NamedType)) ->
- Parser (ImplementsInterfaces t)
-implementsInterfaces sepBy' = ImplementsInterfaces
+ (Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
+ Parser (Full.ImplementsInterfaces t)
+implementsInterfaces sepBy' = Full.ImplementsInterfaces
<$ symbol "implements"
<* optional amp
<*> name `sepBy'` amp
<?> "ImplementsInterfaces"
-inputValueDefinition :: Parser InputValueDefinition
-inputValueDefinition = InputValueDefinition
+inputValueDefinition :: Parser Full.InputValueDefinition
+inputValueDefinition = Full.InputValueDefinition
<$> description
<*> name
<* colon
@@ -304,13 +305,13 @@ inputValueDefinition = InputValueDefinition
<*> directives
<?> "InputValueDefinition"
-argumentsDefinition :: Parser ArgumentsDefinition
-argumentsDefinition = ArgumentsDefinition
+argumentsDefinition :: Parser Full.ArgumentsDefinition
+argumentsDefinition = Full.ArgumentsDefinition
<$> listOptIn parens inputValueDefinition
<?> "ArgumentsDefinition"
-fieldDefinition :: Parser FieldDefinition
-fieldDefinition = FieldDefinition
+fieldDefinition :: Parser Full.FieldDefinition
+fieldDefinition = Full.FieldDefinition
<$> description
<*> name
<*> argumentsDefinition
@@ -319,33 +320,33 @@ fieldDefinition = FieldDefinition
<*> directives
<?> "FieldDefinition"
-schemaDefinition :: Parser TypeSystemDefinition
-schemaDefinition = SchemaDefinition
+schemaDefinition :: Parser Full.TypeSystemDefinition
+schemaDefinition = Full.SchemaDefinition
<$ symbol "schema"
<*> directives
<*> operationTypeDefinitions
<?> "SchemaDefinition"
-operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition)
+operationTypeDefinitions :: Parser (NonEmpty Full.OperationTypeDefinition)
operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
-schemaExtension :: Parser SchemaExtension
+schemaExtension :: Parser Full.SchemaExtension
schemaExtension = extend "schema" "SchemaExtension"
$ schemaOperationExtension :| [directivesExtension]
where
- directivesExtension = SchemaDirectivesExtension
+ directivesExtension = Full.SchemaDirectivesExtension
<$> NonEmpty.some directive
- schemaOperationExtension = SchemaOperationExtension
+ schemaOperationExtension = Full.SchemaOperationExtension
<$> directives
<*> operationTypeDefinitions
-operationTypeDefinition :: Parser OperationTypeDefinition
-operationTypeDefinition = OperationTypeDefinition
+operationTypeDefinition :: Parser Full.OperationTypeDefinition
+operationTypeDefinition = Full.OperationTypeDefinition
<$> operationType <* colon
<*> name
<?> "OperationTypeDefinition"
-operationDefinition :: Parser OperationDefinition
+operationDefinition :: Parser Full.OperationDefinition
operationDefinition = shorthand
<|> operationDefinition'
<?> "OperationDefinition"
@@ -353,7 +354,7 @@ operationDefinition = shorthand
shorthand = do
location <- getLocation
selectionSet' <- selectionSet
- pure $ SelectionSet selectionSet' location
+ pure $ Full.SelectionSet selectionSet' location
operationDefinition' = do
location <- getLocation
operationType' <- operationType
@@ -361,60 +362,74 @@ operationDefinition = shorthand
variableDefinitions' <- variableDefinitions
directives' <- directives
selectionSet' <- selectionSet
- pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location
-
-operationType :: Parser OperationType
-operationType = Query <$ symbol "query"
- <|> Mutation <$ symbol "mutation"
- <|> Subscription <$ symbol "subscription"
+ pure $ Full.OperationDefinition
+ operationType'
+ operationName
+ variableDefinitions'
+ directives'
+ selectionSet'
+ location
+
+operationType :: Parser Full.OperationType
+operationType = Full.Query <$ symbol "query"
+ <|> Full.Mutation <$ symbol "mutation"
+ <|> Full.Subscription <$ symbol "subscription"
<?> "OperationType"
-selectionSet :: Parser SelectionSet
+selectionSet :: Parser Full.SelectionSet
selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"
-selectionSetOpt :: Parser SelectionSetOpt
+selectionSetOpt :: Parser Full.SelectionSetOpt
selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
-selection :: Parser Selection
-selection = field
- <|> try fragmentSpread
- <|> inlineFragment
+selection :: Parser Full.Selection
+selection = Full.FieldSelection <$> field
+ <|> Full.FragmentSpreadSelection <$> try fragmentSpread
+ <|> Full.InlineFragmentSelection <$> inlineFragment
<?> "Selection"
-field :: Parser Selection
-field = Field
- <$> optional alias
- <*> name
- <*> arguments
- <*> directives
- <*> selectionSetOpt
- <?> "Field"
+field :: Parser Full.Field
+field = label "Field" $ do
+ location <- getLocation
+ alias' <- optional alias
+ name' <- name
+ arguments' <- arguments
+ directives' <- directives
+ selectionSetOpt' <- selectionSetOpt
+ pure $ Full.Field alias' name' arguments' directives' selectionSetOpt' location
-alias :: Parser Alias
+alias :: Parser Full.Name
alias = try (name <* colon) <?> "Alias"
-arguments :: Parser [Argument]
+arguments :: Parser [Full.Argument]
arguments = listOptIn parens argument <?> "Arguments"
-argument :: Parser Argument
-argument = Argument <$> name <* colon <*> value <?> "Argument"
+argument :: Parser Full.Argument
+argument = label "Argument" $ do
+ location <- getLocation
+ name' <- name
+ colon
+ value' <- valueNode value
+ pure $ Full.Argument name' value' location
-fragmentSpread :: Parser Selection
-fragmentSpread = FragmentSpread
- <$ spread
- <*> fragmentName
- <*> directives
- <?> "FragmentSpread"
+fragmentSpread :: Parser Full.FragmentSpread
+fragmentSpread = label "FragmentSpread" $ do
+ location <- getLocation
+ _ <- spread
+ fragmentName' <- fragmentName
+ directives' <- directives
+ pure $ Full.FragmentSpread fragmentName' directives' location
-inlineFragment :: Parser Selection
-inlineFragment = InlineFragment
- <$ spread
- <*> optional typeCondition
- <*> directives
- <*> selectionSet
- <?> "InlineFragment"
+inlineFragment :: Parser Full.InlineFragment
+inlineFragment = label "InlineFragment" $ do
+ location <- getLocation
+ _ <- spread
+ typeCondition' <- optional typeCondition
+ directives' <- directives
+ selectionSet' <- selectionSet
+ pure $ Full.InlineFragment typeCondition' directives' selectionSet' location
-fragmentDefinition :: Parser FragmentDefinition
+fragmentDefinition :: Parser Full.FragmentDefinition
fragmentDefinition = label "FragmentDefinition" $ do
location <- getLocation
_ <- symbol "fragment"
@@ -422,36 +437,42 @@ fragmentDefinition = label "FragmentDefinition" $ do
typeCondition' <- typeCondition
directives' <- directives
selectionSet' <- selectionSet
- pure $ FragmentDefinition
+ pure $ Full.FragmentDefinition
fragmentName' typeCondition' directives' selectionSet' location
-fragmentName :: Parser Name
+fragmentName :: Parser Full.Name
fragmentName = but (symbol "on") *> name <?> "FragmentName"
-typeCondition :: Parser TypeCondition
+typeCondition :: Parser Full.TypeCondition
typeCondition = symbol "on" *> name <?> "TypeCondition"
-value :: Parser Value
-value = Variable <$> variable
- <|> Float <$> try float
- <|> Int <$> integer
- <|> Boolean <$> booleanValue
- <|> Null <$ nullValue
- <|> String <$> stringValue
- <|> Enum <$> try enumValue
- <|> List <$> brackets (some value)
- <|> Object <$> braces (some $ objectField value)
+valueNode :: forall a. Parser a -> Parser (Full.Node a)
+valueNode valueParser = do
+ location <- getLocation
+ value' <- valueParser
+ pure $ Full.Node value' location
+
+value :: Parser Full.Value
+value = Full.Variable <$> variable
+ <|> Full.Float <$> try float
+ <|> Full.Int <$> integer
+ <|> Full.Boolean <$> booleanValue
+ <|> Full.Null <$ nullValue
+ <|> Full.String <$> stringValue
+ <|> Full.Enum <$> try enumValue
+ <|> Full.List <$> brackets (some value)
+ <|> Full.Object <$> braces (some $ objectField $ valueNode value)
<?> "Value"
-constValue :: Parser ConstValue
-constValue = ConstFloat <$> try float
- <|> ConstInt <$> integer
- <|> ConstBoolean <$> booleanValue
- <|> ConstNull <$ nullValue
- <|> ConstString <$> stringValue
- <|> ConstEnum <$> try enumValue
- <|> ConstList <$> brackets (some constValue)
- <|> ConstObject <$> braces (some $ objectField constValue)
+constValue :: Parser Full.ConstValue
+constValue = Full.ConstFloat <$> try float
+ <|> Full.ConstInt <$> integer
+ <|> Full.ConstBoolean <$> booleanValue
+ <|> Full.ConstNull <$ nullValue
+ <|> Full.ConstString <$> stringValue
+ <|> Full.ConstEnum <$> try enumValue
+ <|> Full.ConstList <$> brackets (some constValue)
+ <|> Full.ConstObject <$> braces (some $ objectField $ valueNode constValue)
<?> "Value"
booleanValue :: Parser Bool
@@ -459,7 +480,7 @@ booleanValue = True <$ symbol "true"
<|> False <$ symbol "false"
<?> "BooleanValue"
-enumValue :: Parser Name
+enumValue :: Parser Full.Name
enumValue = but (symbol "true")
*> but (symbol "false")
*> but (symbol "null")
@@ -472,51 +493,54 @@ stringValue = blockString <|> string <?> "StringValue"
nullValue :: Parser Text
nullValue = symbol "null" <?> "NullValue"
-objectField :: Parser a -> Parser (ObjectField a)
-objectField valueParser = ObjectField
- <$> name
- <* colon
- <*> valueParser
- <?> "ObjectField"
+objectField :: forall a. Parser (Full.Node a) -> Parser (Full.ObjectField a)
+objectField valueParser = label "ObjectField" $ do
+ location <- getLocation
+ fieldName <- name
+ colon
+ fieldValue <- valueParser
+ pure $ Full.ObjectField fieldName fieldValue location
-variableDefinitions :: Parser [VariableDefinition]
+variableDefinitions :: Parser [Full.VariableDefinition]
variableDefinitions = listOptIn parens variableDefinition
<?> "VariableDefinitions"
-variableDefinition :: Parser VariableDefinition
-variableDefinition = VariableDefinition
- <$> variable
- <* colon
- <*> type'
- <*> defaultValue
- <?> "VariableDefinition"
+variableDefinition :: Parser Full.VariableDefinition
+variableDefinition = label "VariableDefinition" $ do
+ location <- getLocation
+ variableName <- variable
+ colon
+ variableType <- type'
+ variableValue <- defaultValue
+ pure $ Full.VariableDefinition variableName variableType variableValue location
-variable :: Parser Name
+variable :: Parser Full.Name
variable = dollar *> name <?> "Variable"
-defaultValue :: Parser (Maybe ConstValue)
-defaultValue = optional (equals *> constValue) <?> "DefaultValue"
+defaultValue :: Parser (Maybe (Full.Node Full.ConstValue))
+defaultValue = optional (equals *> valueNode constValue) <?> "DefaultValue"
-type' :: Parser Type
-type' = try (TypeNonNull <$> nonNullType)
- <|> TypeList <$> brackets type'
- <|> TypeNamed <$> name
+type' :: Parser Full.Type
+type' = try (Full.TypeNonNull <$> nonNullType)
+ <|> Full.TypeList <$> brackets type'
+ <|> Full.TypeNamed <$> name
<?> "Type"
-nonNullType :: Parser NonNullType
-nonNullType = NonNullTypeNamed <$> name <* bang
- <|> NonNullTypeList <$> brackets type' <* bang
+nonNullType :: Parser Full.NonNullType
+nonNullType = Full.NonNullTypeNamed <$> name <* bang
+ <|> Full.NonNullTypeList <$> brackets type' <* bang
<?> "NonNullType"
-directives :: Parser [Directive]
+directives :: Parser [Full.Directive]
directives = many directive <?> "Directives"
-directive :: Parser Directive
-directive = Directive
- <$ at
- <*> name
- <*> arguments
- <?> "Directive"
+directive :: Parser Full.Directive
+directive = label "Directive" $ do
+ location <- getLocation
+ at
+ directiveName <- name
+ directiveArguments <- arguments
+ pure $ Full.Directive directiveName directiveArguments location
listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
listOptIn surround = option [] . surround . some
diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs
index 9df69de..b084c78 100644
--- a/src/Language/GraphQL/Error.hs
+++ b/src/Language/GraphQL/Error.hs
@@ -5,15 +5,16 @@
-- | Error handling.
module Language.GraphQL.Error
- ( parseError
- , CollectErrsT
+ ( CollectErrsT
, Error(..)
+ , Path(..)
, Resolution(..)
, ResolverException(..)
, Response(..)
, ResponseEventStream
, addErr
, addErrMsg
+ , parseError
, runCollectErrs
, singleError
) where
@@ -28,7 +29,7 @@ import Data.Text (Text)
import qualified Data.Text as Text
import Language.GraphQL.AST (Location(..), Name)
import Language.GraphQL.Execute.Coerce
-import Language.GraphQL.Type.Schema
+import qualified Language.GraphQL.Type.Schema as Schema
import Prelude hiding (null)
import Text.Megaparsec
( ParseErrorBundle(..)
@@ -43,7 +44,7 @@ import Text.Megaparsec
-- | Executor context.
data Resolution m = Resolution
{ errors :: Seq Error
- , types :: HashMap Name (Type m)
+ , types :: HashMap Name (Schema.Type m)
}
-- | Wraps a parse error into a list of errors.
@@ -57,6 +58,7 @@ parseError ParseErrorBundle{..} =
errorObject s SourcePos{..} = Error
{ message = Text.pack $ init $ parseErrorTextPretty s
, locations = [Location (unPos' sourceLine) (unPos' sourceColumn)]
+ , path = []
}
unPos' = fromIntegral . unPos
go (result, state) x =
@@ -75,7 +77,7 @@ addErr v = modify appender
appender resolution@Resolution{..} = resolution{ errors = errors |> v }
makeErrorMessage :: Text -> Error
-makeErrorMessage s = Error s []
+makeErrorMessage s = Error s [] []
-- | Constructs a response object containing only the error with the given
-- message.
@@ -86,10 +88,20 @@ singleError message = Response null $ Seq.singleton $ makeErrorMessage message
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
+-- | If an error can be associated to a particular field in the GraphQL result,
+-- it must contain an entry with the key path that details the path of the
+-- response field which experienced the error. This allows clients to identify
+-- whether a null result is intentional or caused by a runtime error.
+data Path
+ = Segment Text -- ^ Field name.
+ | Index Int -- ^ List index if a field returned a list.
+ deriving (Eq, Show)
+
-- | @GraphQL@ error.
data Error = Error
{ message :: Text
, locations :: [Location]
+ , path :: [Path]
} deriving (Eq, Show)
-- | The server\'s response describes the result of executing the requested
@@ -117,7 +129,7 @@ instance Exception ResolverException
-- | Runs the given query computation, but collects the errors into an error
-- list, which is then sent back with the data.
runCollectErrs :: (Monad m, Serialize a)
- => HashMap Name (Type m)
+ => HashMap Name (Schema.Type m)
-> CollectErrsT m a
-> m (Response a)
runCollectErrs types' res = do
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 2b615f4..283e56c 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -32,8 +32,8 @@ execute :: (MonadCatch m, VariableValue a, Serialize b)
-> HashMap Name a -- ^ Variable substitution function.
-> Document -- @GraphQL@ document.
-> m (Either (ResponseEventStream m b) (Response b))
-execute schema operationName subs document =
- case Transform.document schema operationName subs document of
+execute schema' operationName subs document =
+ case Transform.document schema' operationName subs document of
Left queryError -> pure
$ Right
$ singleError
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 71a2baa..9d588ca 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -27,8 +27,7 @@ import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Internal
-import Language.GraphQL.Type.Schema
+import qualified Language.GraphQL.Type.Internal as Internal
import Prelude hiding (null)
resolveFieldValue :: MonadCatch m
@@ -43,7 +42,7 @@ resolveFieldValue result args resolver =
=> ResolverException
-> CollectErrsT m Type.Value
handleFieldError e =
- addErr (Error (Text.pack $ displayException e) []) >> pure Type.Null
+ addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
@@ -60,7 +59,7 @@ collectFields objectType = foldl forEach Map.empty
in Map.insertWith (<>) responseKey (field :| []) groupedFields
forEach groupedFields (Transform.SelectionFragment selectionFragment)
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
- , doesFragmentTypeApply fragmentType objectType =
+ , Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
| otherwise = groupedFields
@@ -69,15 +68,15 @@ aliasOrName :: forall m. Transform.Field m -> Name
aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
resolveAbstractType :: Monad m
- => AbstractType m
+ => Internal.AbstractType m
-> Type.Subs
-> CollectErrsT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values'
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
types' <- gets types
case HashMap.lookup typeName types' of
- Just (ObjectType objectType) ->
- if instanceOf objectType abstractType
+ Just (Internal.ObjectType objectType) ->
+ if Internal.instanceOf objectType abstractType
then pure $ Just objectType
else pure Nothing
_ -> pure Nothing
@@ -124,25 +123,25 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers
then coerceResult outputType $ Enum enum
- else addErrMsg "Value completion failed."
+ else addErrMsg "Enum value completion failed."
completeValue (Out.ObjectBaseType objectType) fields result =
executeSelectionSet result objectType $ mergeSelectionSets fields
completeValue (Out.InterfaceBaseType interfaceType) fields result
| Type.Object objectMap <- result = do
- let abstractType = AbstractInterfaceType interfaceType
+ let abstractType = Internal.AbstractInterfaceType interfaceType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields
- Nothing -> addErrMsg "Value completion failed."
+ Nothing -> addErrMsg "Interface value completion failed."
completeValue (Out.UnionBaseType unionType) fields result
| Type.Object objectMap <- result = do
- let abstractType = AbstractUnionType unionType
+ let abstractType = Internal.AbstractUnionType unionType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields
- Nothing -> addErrMsg "Value completion failed."
+ Nothing -> addErrMsg "Union value completion failed."
completeValue _ _ _ = addErrMsg "Value completion failed."
mergeSelectionSets :: MonadCatch m
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 9c7ad0a..010899b 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -47,24 +47,23 @@ import Language.GraphQL.AST (Name)
import qualified Language.GraphQL.Execute.Coerce as Coerce
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
-import qualified Language.GraphQL.Type.In as In
-import Language.GraphQL.Type.Internal
+import qualified Language.GraphQL.Type.Internal as Type
import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Schema
+import qualified Language.GraphQL.Type.Schema as Schema
-- | Associates a fragment name with a list of 'Field's.
data Replacement m = Replacement
{ fragments :: HashMap Full.Name (Fragment m)
, fragmentDefinitions :: FragmentDefinitions
, variableValues :: Type.Subs
- , types :: HashMap Full.Name (Type m)
+ , types :: HashMap Full.Name (Schema.Type m)
}
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
-- | Represents fragments and inline fragments.
data Fragment m
- = Fragment (CompositeType m) (Seq (Selection m))
+ = Fragment (Type.CompositeType m) (Seq (Selection m))
-- | Single selection element.
data Selection m
@@ -85,7 +84,7 @@ data Field m = Field
-- | Contains the operation to be executed along with its root type.
data Document m = Document
- (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)
+ (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
data OperationDefinition = OperationDefinition
Full.OperationType
@@ -139,38 +138,9 @@ getOperation (Just operationName) operations
matchingName (OperationDefinition _ name _ _ _) =
name == Just operationName
-lookupInputType
- :: Full.Type
- -> HashMap.HashMap Full.Name (Type m)
- -> Maybe In.Type
-lookupInputType (Full.TypeNamed name) types =
- case HashMap.lookup name types of
- Just (ScalarType scalarType) ->
- Just $ In.NamedScalarType scalarType
- Just (EnumType enumType) ->
- Just $ In.NamedEnumType enumType
- Just (InputObjectType objectType) ->
- Just $ In.NamedInputObjectType objectType
- _ -> Nothing
-lookupInputType (Full.TypeList list) types
- = In.ListType
- <$> lookupInputType list types
-lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
- case HashMap.lookup nonNull types of
- Just (ScalarType scalarType) ->
- Just $ In.NonNullScalarType scalarType
- Just (EnumType enumType) ->
- Just $ In.NonNullEnumType enumType
- Just (InputObjectType objectType) ->
- Just $ In.NonNullInputObjectType objectType
- _ -> Nothing
-lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
- = In.NonNullListType
- <$> lookupInputType nonNull types
-
coerceVariableValues :: Coerce.VariableValue a
=> forall m
- . HashMap Full.Name (Type m)
+ . HashMap Full.Name (Schema.Type m)
-> OperationDefinition
-> HashMap.HashMap Full.Name a
-> Either QueryError Type.Subs
@@ -180,10 +150,10 @@ coerceVariableValues types operationDefinition variableValues =
$ foldr forEach (Just HashMap.empty) variableDefinitions
where
forEach variableDefinition coercedValues = do
- let Full.VariableDefinition variableName variableTypeName defaultValue =
+ let Full.VariableDefinition variableName variableTypeName defaultValue _ =
variableDefinition
- let defaultValue' = constValue <$> defaultValue
- variableType <- lookupInputType variableTypeName types
+ let defaultValue' = constValue . Full.node <$> defaultValue
+ variableType <- Type.lookupInputType variableTypeName types
Coerce.matchFieldValues
coerceVariableValue'
@@ -207,19 +177,20 @@ constValue (Full.ConstList l) = Type.List $ constValue <$> l
constValue (Full.ConstObject o) =
Type.Object $ HashMap.fromList $ constObjectField <$> o
where
- constObjectField (Full.ObjectField key value') = (key, constValue value')
+ constObjectField Full.ObjectField{value = value', ..} =
+ (name, constValue $ Full.node value')
-- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution.
document :: Coerce.VariableValue a
=> forall m
- . Schema m
+ . Type.Schema m
-> Maybe Full.Name
-> HashMap Full.Name a
-> Full.Document
-> Either QueryError (Document m)
document schema operationName subs ast = do
- let referencedTypes = collectReferencedTypes schema
+ let referencedTypes = Schema.types schema
(operations, fragmentTable) <- defragment ast
chosenOperation <- getOperation operationName operations
@@ -233,14 +204,14 @@ document schema operationName subs ast = do
}
case chosenOperation of
OperationDefinition Full.Query _ _ _ _ ->
- pure $ Document referencedTypes (query schema)
+ pure $ Document referencedTypes (Schema.query schema)
$ operation chosenOperation replacement
OperationDefinition Full.Mutation _ _ _ _
- | Just mutationType <- mutation schema ->
+ | Just mutationType <- Schema.mutation schema ->
pure $ Document referencedTypes mutationType
$ operation chosenOperation replacement
OperationDefinition Full.Subscription _ _ _ _
- | Just subscriptionType <- subscription schema ->
+ | Just subscriptionType <- Schema.subscription schema ->
pure $ Document referencedTypes subscriptionType
$ operation chosenOperation replacement
_ -> Left UnsupportedRootOperation
@@ -288,33 +259,47 @@ operation operationDefinition replacement
selection
:: Full.Selection
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
-selection (Full.Field alias name arguments' directives' selections) =
- maybe (Left mempty) (Right . SelectionField) <$> do
- fieldArguments <- foldM go HashMap.empty arguments'
- fieldSelections <- appendSelection selections
- fieldDirectives <- Definition.selection <$> directives directives'
- let field' = Field alias name fieldArguments fieldSelections
- pure $ field' <$ fieldDirectives
+selection (Full.FieldSelection fieldSelection) =
+ maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection
+selection (Full.FragmentSpreadSelection fragmentSelection)
+ = maybe (Left mempty) (Right . SelectionFragment)
+ <$> fragmentSpread fragmentSelection
+selection (Full.InlineFragmentSelection fragmentSelection) =
+ inlineFragment fragmentSelection
+
+field :: Full.Field -> State (Replacement m) (Maybe (Field m))
+field (Full.Field alias name arguments' directives' selections _) = do
+ fieldArguments <- foldM go HashMap.empty arguments'
+ fieldSelections <- appendSelection selections
+ fieldDirectives <- Definition.selection <$> directives directives'
+ let field' = Field alias name fieldArguments fieldSelections
+ pure $ field' <$ fieldDirectives
where
- go arguments (Full.Argument name' value') =
+ go arguments (Full.Argument name' (Full.Node value' _) _) =
inputField arguments name' value'
-selection (Full.FragmentSpread name directives') =
- maybe (Left mempty) (Right . SelectionFragment) <$> do
- spreadDirectives <- Definition.selection <$> directives directives'
- fragments' <- gets fragments
-
- fragmentDefinitions' <- gets fragmentDefinitions
- case HashMap.lookup name fragments' of
- Just definition -> lift $ pure $ definition <$ spreadDirectives
- Nothing
- | Just definition <- HashMap.lookup name fragmentDefinitions' -> do
- fragDef <- fragmentDefinition definition
- case fragDef of
- Just fragment -> lift $ pure $ fragment <$ spreadDirectives
- _ -> lift $ pure Nothing
- | otherwise -> lift $ pure Nothing
-selection (Full.InlineFragment type' directives' selections) = do
+fragmentSpread
+ :: Full.FragmentSpread
+ -> State (Replacement m) (Maybe (Fragment m))
+fragmentSpread (Full.FragmentSpread name directives' _) = do
+ spreadDirectives <- Definition.selection <$> directives directives'
+ fragments' <- gets fragments
+
+ fragmentDefinitions' <- gets fragmentDefinitions
+ case HashMap.lookup name fragments' of
+ Just definition -> lift $ pure $ definition <$ spreadDirectives
+ Nothing
+ | Just definition <- HashMap.lookup name fragmentDefinitions' -> do
+ fragDef <- fragmentDefinition definition
+ case fragDef of
+ Just fragment -> lift $ pure $ fragment <$ spreadDirectives
+ _ -> lift $ pure Nothing
+ | otherwise -> lift $ pure Nothing
+
+inlineFragment
+ :: Full.InlineFragment
+ -> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
+inlineFragment (Full.InlineFragment type' directives' selections _) = do
fragmentDirectives <- Definition.selection <$> directives directives'
case fragmentDirectives of
Nothing -> pure $ Left mempty
@@ -325,7 +310,7 @@ selection (Full.InlineFragment type' directives' selections) = do
Nothing -> pure $ Left fragmentSelectionSet
Just typeName -> do
types' <- gets types
- case lookupTypeCondition typeName types' of
+ case Type.lookupTypeCondition typeName types' of
Just typeCondition -> pure $
selectionFragment typeCondition fragmentSelectionSet
Nothing -> pure $ Left mempty
@@ -346,10 +331,10 @@ appendSelection = foldM go mempty
directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
directives = traverse directive
where
- directive (Full.Directive directiveName directiveArguments)
+ directive (Full.Directive directiveName directiveArguments _)
= Definition.Directive directiveName . Type.Arguments
<$> foldM go HashMap.empty directiveArguments
- go arguments (Full.Argument name value') = do
+ go arguments (Full.Argument name (Full.Node value' _) _) = do
substitutedValue <- value value'
return $ HashMap.insert name substitutedValue arguments
@@ -372,7 +357,7 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do
fragmentSelection <- appendSelection selections
types' <- gets types
- case lookupTypeCondition type' types' of
+ case Type.lookupTypeCondition type' types' of
Just compositeType -> do
let newValue = Fragment compositeType fragmentSelection
modify $ insertFragment newValue
@@ -399,7 +384,8 @@ value (Full.List list) = Type.List <$> traverse value list
value (Full.Object object) =
Type.Object . HashMap.fromList <$> traverse objectField object
where
- objectField (Full.ObjectField name value') = (name,) <$> value value'
+ objectField Full.ObjectField{value = value', ..} =
+ (name,) <$> value (Full.node value')
input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
input (Full.Variable name) =
@@ -415,8 +401,8 @@ input (Full.Object object) = do
objectFields <- foldM objectField HashMap.empty object
pure $ pure $ Object objectFields
where
- objectField resultMap (Full.ObjectField name value') =
- inputField resultMap name value'
+ objectField resultMap Full.ObjectField{value = value', ..} =
+ inputField resultMap name $ Full.node value'
inputField :: forall m
. HashMap Full.Name Input
diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs
index e84fc03..3ed8bb9 100644
--- a/src/Language/GraphQL/Type.hs
+++ b/src/Language/GraphQL/Type.hs
@@ -21,6 +21,6 @@ module Language.GraphQL.Type
) where
import Language.GraphQL.Type.Definition
-import Language.GraphQL.Type.Schema (Schema(..))
+import Language.GraphQL.Type.Schema (Schema, schema)
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs
index 8b08041..59a6d59 100644
--- a/src/Language/GraphQL/Type/In.hs
+++ b/src/Language/GraphQL/Type/In.hs
@@ -11,6 +11,7 @@
-- with 'Language.GraphQL.Type.Out'.
module Language.GraphQL.Type.In
( Argument(..)
+ , Arguments
, InputField(..)
, InputObjectType(..)
, Type(..)
@@ -24,10 +25,10 @@ module Language.GraphQL.Type.In
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Language.GraphQL.AST.Document (Name)
-import Language.GraphQL.Type.Definition
+import qualified Language.GraphQL.Type.Definition as Definition
-- | Single field of an 'InputObjectType'.
-data InputField = InputField (Maybe Text) Type (Maybe Value)
+data InputField = InputField (Maybe Text) Type (Maybe Definition.Value)
-- | Input object type definition.
--
@@ -45,25 +46,28 @@ instance Eq InputObjectType where
-- type can wrap other wrapping or named types. Wrapping types are lists and
-- Non-Null types (named types are nullable by default).
data Type
- = NamedScalarType ScalarType
- | NamedEnumType EnumType
+ = NamedScalarType Definition.ScalarType
+ | NamedEnumType Definition.EnumType
| NamedInputObjectType InputObjectType
| ListType Type
- | NonNullScalarType ScalarType
- | NonNullEnumType EnumType
+ | NonNullScalarType Definition.ScalarType
+ | NonNullEnumType Definition.EnumType
| NonNullInputObjectType InputObjectType
| NonNullListType Type
deriving Eq
-- | Field argument definition.
-data Argument = Argument (Maybe Text) Type (Maybe Value)
+data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
+
+-- | Field argument definitions.
+type Arguments = HashMap Name Argument
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
-pattern ScalarBaseType :: ScalarType -> Type
+pattern ScalarBaseType :: Definition.ScalarType -> Type
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
-pattern EnumBaseType :: EnumType -> Type
+pattern EnumBaseType :: Definition.EnumType -> Type
pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.
@@ -76,7 +80,7 @@ pattern ListBaseType listType <- (isListType -> Just listType)
{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}
-isScalarType :: Type -> Maybe ScalarType
+isScalarType :: Type -> Maybe Definition.ScalarType
isScalarType (NamedScalarType inputType) = Just inputType
isScalarType (NonNullScalarType inputType) = Just inputType
isScalarType _ = Nothing
@@ -86,7 +90,7 @@ isInputObjectType (NamedInputObjectType inputType) = Just inputType
isInputObjectType (NonNullInputObjectType inputType) = Just inputType
isInputObjectType _ = Nothing
-isEnumType :: Type -> Maybe EnumType
+isEnumType :: Type -> Maybe Definition.EnumType
isEnumType (NamedEnumType inputType) = Just inputType
isEnumType (NonNullEnumType inputType) = Just inputType
isEnumType _ = Nothing
diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs
index 6f25777..eb8489c 100644
--- a/src/Language/GraphQL/Type/Internal.hs
+++ b/src/Language/GraphQL/Type/Internal.hs
@@ -3,23 +3,85 @@
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE LambdaCase #-}
module Language.GraphQL.Type.Internal
( AbstractType(..)
, CompositeType(..)
- , collectReferencedTypes
+ , Directive(..)
+ , Directives
+ , Schema(..)
+ , Type(..)
+ , directives
, doesFragmentTypeApply
, instanceOf
+ , lookupInputType
, lookupTypeCondition
+ , lookupTypeField
+ , mutation
+ , subscription
+ , query
+ , types
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST (Name)
+import Data.Text (Text)
+import qualified Language.GraphQL.AST as Full
+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Schema
+
+-- | These are all of the possible kinds of types.
+data Type m
+ = ScalarType Definition.ScalarType
+ | EnumType Definition.EnumType
+ | ObjectType (Out.ObjectType m)
+ | InputObjectType In.InputObjectType
+ | InterfaceType (Out.InterfaceType m)
+ | UnionType (Out.UnionType m)
+ deriving Eq
+
+-- | Directive definition.
+data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments
+
+-- | Directive definitions.
+type Directives = HashMap Full.Name Directive
+
+-- | A Schema is created by supplying the root types of each type of operation,
+-- query and mutation (optional). A schema definition is then supplied to the
+-- validator and executor.
+--
+-- __Note:__ When the schema is constructed, by default only the types that
+-- are reachable by traversing the root types are included, other types must
+-- be explicitly referenced.
+data Schema m = Schema
+ (Out.ObjectType m)
+ (Maybe (Out.ObjectType m))
+ (Maybe (Out.ObjectType m))
+ Directives
+ (HashMap Full.Name (Type m))
+
+-- | Schema query type.
+query :: forall m. Schema m -> Out.ObjectType m
+query (Schema query' _ _ _ _) = query'
+
+-- | Schema mutation type.
+mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
+mutation (Schema _ mutation' _ _ _) = mutation'
+
+-- | Schema subscription type.
+subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
+subscription (Schema _ _ subscription' _ _) = subscription'
+
+-- | Schema directive definitions.
+directives :: forall m. Schema m -> Directives
+directives (Schema _ _ _ directives' _) = directives'
+
+-- | Types referenced by the schema.
+types :: forall m. Schema m -> HashMap Full.Name (Type m)
+types (Schema _ _ _ _ types') = types'
-- | These types may describe the parent context of a selection set.
data CompositeType m
@@ -34,65 +96,6 @@ data AbstractType m
| AbstractInterfaceType (Out.InterfaceType m)
deriving Eq
--- | Traverses the schema and finds all referenced types.
-collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
-collectReferencedTypes schema =
- let queryTypes = traverseObjectType (query schema) HashMap.empty
- in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
- where
- collect traverser typeName element foundTypes
- | HashMap.member typeName foundTypes = foundTypes
- | otherwise = traverser $ HashMap.insert typeName element foundTypes
- visitFields (Out.Field _ outputType arguments) foundTypes
- = traverseOutputType outputType
- $ foldr visitArguments foundTypes arguments
- visitArguments (In.Argument _ inputType _) = traverseInputType inputType
- visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
- getField (Out.ValueResolver field _) = field
- getField (Out.EventStreamResolver field _ _) = field
- traverseInputType (In.InputObjectBaseType objectType) =
- let (In.InputObjectType typeName _ inputFields) = objectType
- element = InputObjectType objectType
- traverser = flip (foldr visitInputFields) inputFields
- in collect traverser typeName element
- traverseInputType (In.ListBaseType listType) =
- traverseInputType listType
- traverseInputType (In.ScalarBaseType scalarType) =
- let (Definition.ScalarType typeName _) = scalarType
- in collect Prelude.id typeName (ScalarType scalarType)
- traverseInputType (In.EnumBaseType enumType) =
- let (Definition.EnumType typeName _ _) = enumType
- in collect Prelude.id typeName (EnumType enumType)
- traverseOutputType (Out.ObjectBaseType objectType) =
- traverseObjectType objectType
- traverseOutputType (Out.InterfaceBaseType interfaceType) =
- traverseInterfaceType interfaceType
- traverseOutputType (Out.UnionBaseType unionType) =
- let (Out.UnionType typeName _ types) = unionType
- traverser = flip (foldr traverseObjectType) types
- in collect traverser typeName (UnionType unionType)
- traverseOutputType (Out.ListBaseType listType) =
- traverseOutputType listType
- traverseOutputType (Out.ScalarBaseType scalarType) =
- let (Definition.ScalarType typeName _) = scalarType
- in collect Prelude.id typeName (ScalarType scalarType)
- traverseOutputType (Out.EnumBaseType enumType) =
- let (Definition.EnumType typeName _ _) = enumType
- in collect Prelude.id typeName (EnumType enumType)
- traverseObjectType objectType foundTypes =
- let (Out.ObjectType typeName _ interfaces fields) = objectType
- element = ObjectType objectType
- traverser = polymorphicTraverser interfaces (getField <$> fields)
- in collect traverser typeName element foundTypes
- traverseInterfaceType interfaceType foundTypes =
- let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
- element = InterfaceType interfaceType
- traverser = polymorphicTraverser interfaces fields
- in collect traverser typeName element foundTypes
- polymorphicTraverser interfaces fields
- = flip (foldr visitFields) fields
- . flip (foldr traverseInterfaceType) interfaces
-
doesFragmentTypeApply :: forall m
. CompositeType m
-> Out.ObjectType m
@@ -118,13 +121,56 @@ instanceOf objectType (AbstractUnionType unionType) =
go unionMemberType acc = acc || objectType == unionMemberType
lookupTypeCondition :: forall m
- . Name
- -> HashMap Name (Type m)
+ . Full.Name
+ -> HashMap Full.Name (Type m)
-> Maybe (CompositeType m)
lookupTypeCondition type' types' =
case HashMap.lookup type' types' of
- Just (ObjectType objectType) -> Just $ CompositeObjectType objectType
+ Just (ObjectType objectType) ->
+ Just $ CompositeObjectType objectType
Just (UnionType unionType) -> Just $ CompositeUnionType unionType
Just (InterfaceType interfaceType) ->
Just $ CompositeInterfaceType interfaceType
_ -> Nothing
+
+lookupInputType :: Full.Type -> HashMap Full.Name (Type m) -> Maybe In.Type
+lookupInputType (Full.TypeNamed name) types' =
+ case HashMap.lookup name types' of
+ Just (ScalarType scalarType) ->
+ Just $ In.NamedScalarType scalarType
+ Just (EnumType enumType) ->
+ Just $ In.NamedEnumType enumType
+ Just (InputObjectType objectType) ->
+ Just $ In.NamedInputObjectType objectType
+ _ -> Nothing
+lookupInputType (Full.TypeList list) types'
+ = In.ListType
+ <$> lookupInputType list types'
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types' =
+ case HashMap.lookup nonNull types' of
+ Just (ScalarType scalarType) ->
+ Just $ In.NonNullScalarType scalarType
+ Just (EnumType enumType) ->
+ Just $ In.NonNullEnumType enumType
+ Just (InputObjectType objectType) ->
+ Just $ In.NonNullInputObjectType objectType
+ _ -> Nothing
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types'
+ = In.NonNullListType
+ <$> lookupInputType nonNull types'
+
+lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)
+lookupTypeField fieldName = \case
+ Out.ObjectBaseType objectType ->
+ objectChild objectType
+ Out.InterfaceBaseType interfaceType ->
+ interfaceChild interfaceType
+ Out.ListBaseType listType -> lookupTypeField fieldName listType
+ _ -> Nothing
+ where
+ objectChild (Out.ObjectType _ _ _ resolvers) =
+ resolverType <$> HashMap.lookup fieldName resolvers
+ interfaceChild (Out.InterfaceType _ _ _ fields) =
+ HashMap.lookup fieldName fields
+ resolverType (Out.ValueResolver objectField _) = objectField
+ resolverType (Out.EventStreamResolver objectField _ _) = objectField
diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs
index 89bbf1d..b0668f5 100644
--- a/src/Language/GraphQL/Type/Out.hs
+++ b/src/Language/GraphQL/Type/Out.hs
@@ -76,7 +76,7 @@ instance forall a. Eq (UnionType a) where
data Field m = Field
(Maybe Text) -- ^ Description.
(Type m) -- ^ Field type.
- (HashMap Name In.Argument) -- ^ Arguments.
+ In.Arguments -- ^ Arguments.
-- | These types may be used as output types as the result of fields.
--
diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs
index 581d9b2..099c256 100644
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@@ -2,36 +2,154 @@
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas.
module Language.GraphQL.Type.Schema
- ( Schema(..)
- , Type(..)
+ ( schema
+ , module Language.GraphQL.Type.Internal
) where
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
+import qualified Language.GraphQL.AST as Full
+import Language.GraphQL.Type.Internal
+ ( Directive(..)
+ , Directives
+ , Schema
+ , Type(..)
+ , directives
+ , mutation
+ , subscription
+ , query
+ , types
+ )
import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.Type.Internal as Internal
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
--- | These are all of the possible kinds of types.
-data Type m
- = ScalarType Definition.ScalarType
- | EnumType Definition.EnumType
- | ObjectType (Out.ObjectType m)
- | InputObjectType In.InputObjectType
- | InterfaceType (Out.InterfaceType m)
- | UnionType (Out.UnionType m)
- deriving Eq
+-- | Schema constructor.
+schema :: forall m
+ . Out.ObjectType m -- ^ Query type.
+ -> Maybe (Out.ObjectType m) -- ^ Mutation type.
+ -> Maybe (Out.ObjectType m) -- ^ Subscription type.
+ -> Directives -- ^ Directive definitions.
+ -> Schema m -- ^ Schema.
+schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
+ Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes
+ where
+ collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot
+ allDirectives = HashMap.union directiveDefinitions defaultDirectives
+ defaultDirectives = HashMap.fromList
+ [ ("skip", skipDirective)
+ , ("include", includeDirective)
+ , ("deprecated", deprecatedDirective)
+ ]
+ includeDirective =
+ Directive includeDescription skipIncludeLocations includeArguments
+ includeArguments = HashMap.singleton "if"
+ $ In.Argument (Just "Included when true.") ifType Nothing
+ includeDescription = Just
+ "Directs the executor to include this field or fragment only when the \
+ \`if` argument is true."
+ skipDirective = Directive skipDescription skipIncludeLocations skipArguments
+ skipArguments = HashMap.singleton "if"
+ $ In.Argument (Just "skipped when true.") ifType Nothing
+ ifType = In.NonNullScalarType Definition.boolean
+ skipDescription = Just
+ "Directs the executor to skip this field or fragment when the `if` \
+ \argument is true."
+ skipIncludeLocations =
+ [ ExecutableDirectiveLocation DirectiveLocation.Field
+ , ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
+ , ExecutableDirectiveLocation DirectiveLocation.InlineFragment
+ ]
+ deprecatedDirective =
+ Directive deprecatedDescription deprecatedLocations deprecatedArguments
+ reasonDescription = Just
+ "Explains why this element was deprecated, usually also including a \
+ \suggestion for how to access supported similar data. Formatted using \
+ \the Markdown syntax, as specified by \
+ \[CommonMark](https://commonmark.org/).'"
+ deprecatedArguments = HashMap.singleton "reason"
+ $ In.Argument reasonDescription reasonType
+ $ Just "No longer supported"
+ reasonType = In.NamedScalarType Definition.string
+ deprecatedDescription = Just
+ "Marks an element of a GraphQL schema as no longer supported."
+ deprecatedLocations =
+ [ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
+ , TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
+ , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
+ , TypeSystemDirectiveLocation DirectiveLocation.EnumValue
+ ]
--- | A Schema is created by supplying the root types of each type of operation,
--- query and mutation (optional). A schema definition is then supplied to the
--- validator and executor.
---
--- __Note:__ When the schema is constructed, by default only the types that
--- are reachable by traversing the root types are included, other types must
--- be explicitly referenced.
-data Schema m = Schema
- { query :: Out.ObjectType m
- , mutation :: Maybe (Out.ObjectType m)
- , subscription :: Maybe (Out.ObjectType m)
- }
+-- | Traverses the schema and finds all referenced types.
+collectReferencedTypes :: forall m
+ . Out.ObjectType m
+ -> Maybe (Out.ObjectType m)
+ -> Maybe (Out.ObjectType m)
+ -> HashMap Full.Name (Type m)
+collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
+ let queryTypes = traverseObjectType queryRoot HashMap.empty
+ mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
+ mutationRoot
+ in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot
+ where
+ collect traverser typeName element foundTypes
+ | HashMap.member typeName foundTypes = foundTypes
+ | otherwise = traverser $ HashMap.insert typeName element foundTypes
+ visitFields (Out.Field _ outputType arguments) foundTypes
+ = traverseOutputType outputType
+ $ foldr visitArguments foundTypes arguments
+ visitArguments (In.Argument _ inputType _) = traverseInputType inputType
+ visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
+ getField (Out.ValueResolver field _) = field
+ getField (Out.EventStreamResolver field _ _) = field
+ traverseInputType (In.InputObjectBaseType objectType) =
+ let In.InputObjectType typeName _ inputFields = objectType
+ element = InputObjectType objectType
+ traverser = flip (foldr visitInputFields) inputFields
+ in collect traverser typeName element
+ traverseInputType (In.ListBaseType listType) =
+ traverseInputType listType
+ traverseInputType (In.ScalarBaseType scalarType) =
+ let Definition.ScalarType typeName _ = scalarType
+ in collect Prelude.id typeName (ScalarType scalarType)
+ traverseInputType (In.EnumBaseType enumType) =
+ let Definition.EnumType typeName _ _ = enumType
+ in collect Prelude.id typeName (EnumType enumType)
+ traverseOutputType (Out.ObjectBaseType objectType) =
+ traverseObjectType objectType
+ traverseOutputType (Out.InterfaceBaseType interfaceType) =
+ traverseInterfaceType interfaceType
+ traverseOutputType (Out.UnionBaseType unionType) =
+ let Out.UnionType typeName _ types' = unionType
+ traverser = flip (foldr traverseObjectType) types'
+ in collect traverser typeName (UnionType unionType)
+ traverseOutputType (Out.ListBaseType listType) =
+ traverseOutputType listType
+ traverseOutputType (Out.ScalarBaseType scalarType) =
+ let Definition.ScalarType typeName _ = scalarType
+ in collect Prelude.id typeName (ScalarType scalarType)
+ traverseOutputType (Out.EnumBaseType enumType) =
+ let Definition.EnumType typeName _ _ = enumType
+ in collect Prelude.id typeName (EnumType enumType)
+ traverseObjectType objectType foundTypes =
+ let Out.ObjectType typeName _ interfaces fields = objectType
+ element = ObjectType objectType
+ traverser = polymorphicTraverser interfaces (getField <$> fields)
+ in collect traverser typeName element foundTypes
+ traverseInterfaceType interfaceType foundTypes =
+ let Out.InterfaceType typeName _ interfaces fields = interfaceType
+ element = InterfaceType interfaceType
+ traverser = polymorphicTraverser interfaces fields
+ in collect traverser typeName element foundTypes
+ polymorphicTraverser interfaces fields
+ = flip (foldr visitFields) fields
+ . flip (foldr traverseInterfaceType) interfaces
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index 53dc6f9..277f84d 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@@ -2,80 +2,505 @@
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
-{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | GraphQL validator.
module Language.GraphQL.Validate
- ( Error(..)
- , Path(..)
+ ( Validation.Error(..)
, document
, module Language.GraphQL.Validate.Rules
) where
-import Control.Monad (foldM)
-import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
-import Data.Foldable (foldrM)
+import Control.Monad (join)
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Reader (runReaderT)
+import Data.Foldable (toList)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq
-import Language.GraphQL.AST.Document
-import Language.GraphQL.Type.Internal
-import Language.GraphQL.Type.Schema (Schema(..))
+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
+import qualified Language.GraphQL.AST.Document as Full
+import qualified Language.GraphQL.Type.Internal as Type
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Type.Schema (Schema)
+import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Rules
-import Language.GraphQL.Validate.Validation
+import Language.GraphQL.Validate.Validation (Validation(Validation))
+import qualified Language.GraphQL.Validate.Validation as Validation
-type ValidateT m = Reader (Validation m) (Seq Error)
+type ApplySelectionRule m a
+ = HashMap Full.Name (Schema.Type m)
+ -> Validation.Rule m
+ -> Maybe (Out.Type m)
+ -> a
+ -> Seq (Validation.RuleT m)
+
+type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.RuleT m)
-- | Validates a document and returns a list of found errors. If the returned
-- list is empty, the document is valid.
-document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
+document :: forall m
+ . Schema m
+ -> [Validation.Rule m]
+ -> Full.Document
+ -> Seq Validation.Error
document schema' rules' document' =
- runReader (foldrM go Seq.empty document') context
+ runReaderT reader context
where
context = Validation
- { ast = document'
- , schema = schema'
- , types = collectReferencedTypes schema'
- , rules = rules'
+ { Validation.ast = document'
+ , Validation.schema = schema'
}
- go definition' accumulator = (accumulator ><) <$> definition definition'
-
-definition :: forall m. Definition -> ValidateT m
-definition = \case
- definition'@(ExecutableDefinition executableDefinition') -> do
- applied <- applyRules definition'
- children <- executableDefinition executableDefinition'
- pure $ children >< applied
- definition' -> applyRules definition'
- where
- applyRules definition' =
- asks rules >>= foldM (ruleFilter definition') Seq.empty
- ruleFilter definition' accumulator (DefinitionRule rule) =
- mapReaderT (runRule accumulator) $ rule definition'
- ruleFilter _ accumulator _ = pure accumulator
-
-runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
-runRule accumulator (Just error') = pure $ accumulator |> error'
-runRule accumulator Nothing = pure accumulator
-
-executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
-executableDefinition (DefinitionOperation definition') =
- operationDefinition definition'
-executableDefinition (DefinitionFragment definition') =
- fragmentDefinition definition'
-
-operationDefinition :: forall m. OperationDefinition -> ValidateT m
-operationDefinition operation =
- asks rules >>= foldM ruleFilter Seq.empty
- where
- ruleFilter accumulator (OperationDefinitionRule rule) =
- mapReaderT (runRule accumulator) $ rule operation
- ruleFilter accumulator _ = pure accumulator
-
-fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
-fragmentDefinition fragment =
- asks rules >>= foldM ruleFilter Seq.empty
- where
- ruleFilter accumulator (FragmentDefinitionRule rule) =
- mapReaderT (runRule accumulator) $ rule fragment
- ruleFilter accumulator _ = pure accumulator
+ reader = do
+ rule' <- lift $ Seq.fromList rules'
+ join $ lift $ foldr (definition rule' context) Seq.empty document'
+
+definition :: Validation.Rule m
+ -> Validation m
+ -> Full.Definition
+ -> Seq (Validation.RuleT m)
+ -> Seq (Validation.RuleT m)
+definition (Validation.DefinitionRule rule) _ definition' accumulator =
+ accumulator |> rule definition'
+definition rule context (Full.ExecutableDefinition definition') accumulator =
+ accumulator >< executableDefinition rule context definition'
+definition rule context (Full.TypeSystemDefinition typeSystemDefinition' _) accumulator =
+ accumulator >< typeSystemDefinition context rule typeSystemDefinition'
+definition rule context (Full.TypeSystemExtension extension _) accumulator =
+ accumulator >< typeSystemExtension context rule extension
+
+typeSystemExtension :: forall m
+ . Validation m
+ -> ApplyRule m Full.TypeSystemExtension
+typeSystemExtension context rule = \case
+ Full.SchemaExtension extension -> schemaExtension context rule extension
+ Full.TypeExtension extension -> typeExtension context rule extension
+
+typeExtension :: forall m. Validation m -> ApplyRule m Full.TypeExtension
+typeExtension context rule = \case
+ Full.ScalarTypeExtension _ directives' ->
+ directives context rule scalarLocation directives'
+ Full.ObjectTypeFieldsDefinitionExtension _ _ directives' fields
+ -> directives context rule objectLocation directives'
+ >< foldMap (fieldDefinition context rule) fields
+ Full.ObjectTypeDirectivesExtension _ _ directives' ->
+ directives context rule objectLocation directives'
+ Full.ObjectTypeImplementsInterfacesExtension _ _ -> mempty
+ Full.InterfaceTypeFieldsDefinitionExtension _ directives' fields
+ -> directives context rule interfaceLocation directives'
+ >< foldMap (fieldDefinition context rule) fields
+ Full.InterfaceTypeDirectivesExtension _ directives' ->
+ directives context rule interfaceLocation directives'
+ Full.UnionTypeUnionMemberTypesExtension _ directives' _ ->
+ directives context rule unionLocation directives'
+ Full.UnionTypeDirectivesExtension _ directives' ->
+ directives context rule unionLocation directives'
+ Full.EnumTypeEnumValuesDefinitionExtension _ directives' values
+ -> directives context rule enumLocation directives'
+ >< foldMap (enumValueDefinition context rule) values
+ Full.EnumTypeDirectivesExtension _ directives' ->
+ directives context rule enumLocation directives'
+ Full.InputObjectTypeInputFieldsDefinitionExtension _ directives' fields
+ -> directives context rule inputObjectLocation directives'
+ >< foldMap forEachInputFieldDefinition fields
+ Full.InputObjectTypeDirectivesExtension _ directives' ->
+ directives context rule inputObjectLocation directives'
+ where
+ forEachInputFieldDefinition =
+ inputValueDefinition context rule inputFieldDefinitionLocation
+
+schemaExtension :: forall m. Validation m -> ApplyRule m Full.SchemaExtension
+schemaExtension context rule = \case
+ Full.SchemaOperationExtension directives' _ ->
+ directives context rule schemaLocation directives'
+ Full.SchemaDirectivesExtension directives' ->
+ directives context rule schemaLocation directives'
+
+schemaLocation :: DirectiveLocation
+schemaLocation = TypeSystemDirectiveLocation DirectiveLocation.Schema
+
+interfaceLocation :: DirectiveLocation
+interfaceLocation = TypeSystemDirectiveLocation DirectiveLocation.Interface
+
+objectLocation :: DirectiveLocation
+objectLocation = TypeSystemDirectiveLocation DirectiveLocation.Object
+
+unionLocation :: DirectiveLocation
+unionLocation = TypeSystemDirectiveLocation DirectiveLocation.Union
+
+enumLocation :: DirectiveLocation
+enumLocation = TypeSystemDirectiveLocation DirectiveLocation.Enum
+
+inputObjectLocation :: DirectiveLocation
+inputObjectLocation = TypeSystemDirectiveLocation DirectiveLocation.InputObject
+
+scalarLocation :: DirectiveLocation
+scalarLocation = TypeSystemDirectiveLocation DirectiveLocation.Scalar
+
+enumValueLocation :: DirectiveLocation
+enumValueLocation = TypeSystemDirectiveLocation DirectiveLocation.EnumValue
+
+fieldDefinitionLocation :: DirectiveLocation
+fieldDefinitionLocation =
+ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
+
+inputFieldDefinitionLocation :: DirectiveLocation
+inputFieldDefinitionLocation =
+ TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
+
+argumentDefinitionLocation :: DirectiveLocation
+argumentDefinitionLocation =
+ TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
+
+queryLocation :: DirectiveLocation
+queryLocation = ExecutableDirectiveLocation DirectiveLocation.Query
+
+mutationLocation :: DirectiveLocation
+mutationLocation = ExecutableDirectiveLocation DirectiveLocation.Mutation
+
+subscriptionLocation :: DirectiveLocation
+subscriptionLocation =
+ ExecutableDirectiveLocation DirectiveLocation.Subscription
+
+fieldLocation :: DirectiveLocation
+fieldLocation = ExecutableDirectiveLocation DirectiveLocation.Field
+
+fragmentDefinitionLocation :: DirectiveLocation
+fragmentDefinitionLocation =
+ ExecutableDirectiveLocation DirectiveLocation.FragmentDefinition
+
+fragmentSpreadLocation :: DirectiveLocation
+fragmentSpreadLocation =
+ ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
+
+inlineFragmentLocation :: DirectiveLocation
+inlineFragmentLocation =
+ ExecutableDirectiveLocation DirectiveLocation.InlineFragment
+
+executableDefinition :: forall m
+ . Validation.Rule m
+ -> Validation m
+ -> Full.ExecutableDefinition
+ -> Seq (Validation.RuleT m)
+executableDefinition rule context (Full.DefinitionOperation operation) =
+ operationDefinition rule context operation
+executableDefinition rule context (Full.DefinitionFragment fragment) =
+ fragmentDefinition rule context fragment
+
+typeSystemDefinition :: forall m
+ . Validation m
+ -> ApplyRule m Full.TypeSystemDefinition
+typeSystemDefinition context rule = \case
+ Full.SchemaDefinition directives' _ ->
+ directives context rule schemaLocation directives'
+ Full.TypeDefinition typeDefinition' ->
+ typeDefinition context rule typeDefinition'
+ Full.DirectiveDefinition _ _ arguments' _ ->
+ argumentsDefinition context rule arguments'
+
+typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
+typeDefinition context rule = \case
+ Full.ScalarTypeDefinition _ _ directives' ->
+ directives context rule scalarLocation directives'
+ Full.ObjectTypeDefinition _ _ _ directives' fields
+ -> directives context rule objectLocation directives'
+ >< foldMap (fieldDefinition context rule) fields
+ Full.InterfaceTypeDefinition _ _ directives' fields
+ -> directives context rule interfaceLocation directives'
+ >< foldMap (fieldDefinition context rule) fields
+ Full.UnionTypeDefinition _ _ directives' _ ->
+ directives context rule unionLocation directives'
+ Full.EnumTypeDefinition _ _ directives' values
+ -> directives context rule enumLocation directives'
+ >< foldMap (enumValueDefinition context rule) values
+ Full.InputObjectTypeDefinition _ _ directives' fields
+ -> directives context rule inputObjectLocation directives'
+ <> foldMap forEachInputFieldDefinition fields
+ where
+ forEachInputFieldDefinition =
+ inputValueDefinition context rule inputFieldDefinitionLocation
+
+enumValueDefinition :: forall m
+ . Validation m
+ -> ApplyRule m Full.EnumValueDefinition
+enumValueDefinition context rule (Full.EnumValueDefinition _ _ directives') =
+ directives context rule enumValueLocation directives'
+
+fieldDefinition :: forall m. Validation m -> ApplyRule m Full.FieldDefinition
+fieldDefinition context rule (Full.FieldDefinition _ _ arguments' _ directives')
+ = directives context rule fieldDefinitionLocation directives'
+ >< argumentsDefinition context rule arguments'
+
+argumentsDefinition :: forall m
+ . Validation m
+ -> ApplyRule m Full.ArgumentsDefinition
+argumentsDefinition context rule (Full.ArgumentsDefinition definitions) =
+ foldMap forEachArgument definitions
+ where
+ forEachArgument =
+ inputValueDefinition context rule argumentDefinitionLocation
+
+inputValueDefinition :: forall m
+ . Validation m
+ -> Validation.Rule m
+ -> DirectiveLocation
+ -> Full.InputValueDefinition
+ -> Seq (Validation.RuleT m)
+inputValueDefinition context rule directiveLocation definition' =
+ let Full.InputValueDefinition _ _ _ _ directives' = definition'
+ in directives context rule directiveLocation directives'
+
+operationDefinition :: forall m
+ . Validation.Rule m
+ -> Validation m
+ -> Full.OperationDefinition
+ -> Seq (Validation.RuleT m)
+operationDefinition rule context operation
+ | Validation.OperationDefinitionRule operationRule <- rule =
+ pure $ operationRule operation
+ | Validation.VariablesRule variablesRule <- rule
+ , Full.OperationDefinition _ _ variables _ _ _ <- operation =
+ foldMap (variableDefinition context rule) variables |> variablesRule variables
+ | Full.SelectionSet selections _ <- operation =
+ selectionSet context types' rule queryRoot selections
+ | Full.OperationDefinition Full.Query _ _ directives' selections _ <- operation
+ = selectionSet context types' rule queryRoot selections
+ >< directives context rule queryLocation directives'
+ | Full.OperationDefinition Full.Mutation _ _ directives' selections _ <- operation =
+ let root = Out.NamedObjectType <$> Schema.mutation schema'
+ in selectionSet context types' rule root selections
+ >< directives context rule mutationLocation directives'
+ | Full.OperationDefinition Full.Subscription _ _ directives' selections _ <- operation =
+ let root = Out.NamedObjectType <$> Schema.subscription schema'
+ in selectionSet context types' rule root selections
+ >< directives context rule subscriptionLocation directives'
+ where
+ schema' = Validation.schema context
+ queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'
+ types' = Schema.types schema'
+
+typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
+typeToOut (Schema.ObjectType objectType) =
+ Just $ Out.NamedObjectType objectType
+typeToOut (Schema.InterfaceType interfaceType) =
+ Just $ Out.NamedInterfaceType interfaceType
+typeToOut (Schema.UnionType unionType) = Just $ Out.NamedUnionType unionType
+typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType
+typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
+typeToOut _ = Nothing
+
+variableDefinition :: forall m
+ . Validation m
+ -> ApplyRule m Full.VariableDefinition
+variableDefinition context rule (Full.VariableDefinition _ typeName value' _)
+ | Just defaultValue' <- value'
+ , types <- Schema.types $ Validation.schema context
+ , variableType <- Type.lookupInputType typeName types =
+ constValue rule variableType defaultValue'
+variableDefinition _ _ _ = mempty
+
+constValue :: forall m
+ . Validation.Rule m
+ -> Maybe In.Type
+ -> Full.Node Full.ConstValue
+ -> Seq (Validation.RuleT m)
+constValue (Validation.ValueRule _ rule) valueType = go valueType
+ where
+ go inputObjectType value'@(Full.Node (Full.ConstObject fields) _)
+ = foldMap (forEach inputObjectType) (Seq.fromList fields)
+ |> rule inputObjectType value'
+ go listType value'@(Full.Node (Full.ConstList values) location')
+ = embedListLocation go listType values location'
+ |> rule listType value'
+ go anotherValue value' = pure $ rule anotherValue value'
+ forEach inputObjectType Full.ObjectField{value = value', ..} =
+ go (valueTypeByName name inputObjectType) value'
+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
+
+fragmentDefinition :: forall m
+ . Validation.Rule m
+ -> Validation m
+ -> Full.FragmentDefinition
+ -> Seq (Validation.RuleT m)
+fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =
+ pure $ rule definition'
+fragmentDefinition rule context definition'
+ | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
+ , Validation.FragmentRule definitionRule _ <- rule
+ = applyToChildren typeCondition directives' selections
+ |> definitionRule definition'
+ | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
+ = applyToChildren typeCondition directives' selections
+ where
+ types' = Schema.types $ Validation.schema context
+ applyToChildren typeCondition directives' selections
+ = selectionSet context types' rule (lookupType' typeCondition) selections
+ >< directives context rule fragmentDefinitionLocation directives'
+ lookupType' = flip lookupType types'
+
+lookupType :: forall m
+ . Full.TypeCondition
+ -> HashMap Full.Name (Schema.Type m)
+ -> Maybe (Out.Type m)
+lookupType typeCondition types' = HashMap.lookup typeCondition types'
+ >>= typeToOut
+
+selectionSet :: Traversable t
+ => forall m
+ . Validation m
+ -> ApplySelectionRule m (t Full.Selection)
+selectionSet context types' rule = foldMap . selection context types' rule
+
+selection :: forall m. Validation m -> ApplySelectionRule m Full.Selection
+selection context types' rule objectType selection'
+ | Validation.SelectionRule selectionRule <- rule =
+ applyToChildren |> selectionRule objectType selection'
+ | otherwise = applyToChildren
+ where
+ applyToChildren =
+ case selection' of
+ Full.FieldSelection field' ->
+ field context types' rule objectType field'
+ Full.InlineFragmentSelection inlineFragment' ->
+ inlineFragment context types' rule objectType inlineFragment'
+ Full.FragmentSpreadSelection fragmentSpread' ->
+ fragmentSpread context rule fragmentSpread'
+
+field :: forall m. Validation m -> ApplySelectionRule m Full.Field
+field context types' rule objectType field' = go field'
+ where
+ go (Full.Field _ fieldName _ _ _ _)
+ | Validation.FieldRule fieldRule <- rule =
+ applyToChildren fieldName |> fieldRule objectType field'
+ | Validation.ArgumentsRule argumentsRule _ <- rule =
+ applyToChildren fieldName |> argumentsRule objectType field'
+ | otherwise = applyToChildren fieldName
+ typeFieldType (Out.Field _ type' _) = type'
+ typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes
+ applyToChildren fieldName =
+ let Full.Field _ _ arguments' directives' selections _ = field'
+ typeField = objectType >>= Type.lookupTypeField fieldName
+ argumentTypes = maybe mempty typeFieldArguments typeField
+ in selectionSet context types' rule (typeFieldType <$> typeField) selections
+ >< directives context rule fieldLocation directives'
+ >< arguments rule argumentTypes arguments'
+
+arguments :: forall m
+ . Validation.Rule m
+ -> In.Arguments
+ -> [Full.Argument]
+ -> Seq (Validation.RuleT m)
+arguments rule argumentTypes = foldMap forEach . Seq.fromList
+ where
+ 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) value'
+ where
+ valueType (In.Argument _ valueType' _) = valueType'
+
+-- valueTypeFromList :: Maybe In.Type -> Maybe In.Type
+embedListLocation :: forall a m
+ . (Maybe In.Type -> Full.Node a -> Seq m)
+ -> Maybe In.Type
+ -> [a]
+ -> Full.Location
+ -> Seq m
+embedListLocation go listType values location'
+ = foldMap (go $ valueTypeFromList listType)
+ $ flip Full.Node location' <$> Seq.fromList values
+ where
+ valueTypeFromList (Just (In.ListBaseType baseType)) = Just baseType
+ valueTypeFromList _ = Nothing
+
+value :: forall m
+ . Validation.Rule m
+ -> Maybe In.Type
+ -> Full.Node Full.Value
+ -> Seq (Validation.RuleT m)
+value (Validation.ValueRule rule _) valueType = go valueType
+ where
+ go inputObjectType value'@(Full.Node (Full.Object fields) _)
+ = foldMap (forEach inputObjectType) (Seq.fromList fields)
+ |> rule inputObjectType value'
+ go listType value'@(Full.Node (Full.List values) location')
+ = embedListLocation go listType values location'
+ |> rule listType value'
+ go anotherValue value' = pure $ rule anotherValue value'
+ forEach inputObjectType Full.ObjectField{value = value', ..} =
+ go (valueTypeByName name inputObjectType) value'
+value _ _ = const mempty
+
+inlineFragment :: forall m
+ . Validation m
+ -> ApplySelectionRule m Full.InlineFragment
+inlineFragment context types' rule objectType inlineFragment' =
+ go inlineFragment'
+ where
+ go (Full.InlineFragment optionalType directives' selections _)
+ | Validation.FragmentRule _ fragmentRule <- rule
+ = applyToChildren (refineTarget optionalType) directives' selections
+ |> fragmentRule inlineFragment'
+ | otherwise = applyToChildren (refineTarget optionalType) directives' selections
+ refineTarget (Just typeCondition) = lookupType typeCondition types'
+ refineTarget Nothing = objectType
+ applyToChildren objectType' directives' selections
+ = selectionSet context types' rule objectType' selections
+ >< directives context rule inlineFragmentLocation directives'
+
+fragmentSpread :: forall m. Validation m -> ApplyRule m Full.FragmentSpread
+fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _)
+ | Validation.FragmentSpreadRule fragmentRule <- rule =
+ applyToChildren |> fragmentRule fragmentSpread'
+ | otherwise = applyToChildren
+ where
+ applyToChildren = directives context rule fragmentSpreadLocation directives'
+
+directives :: Traversable t
+ => forall m
+ . Validation m
+ -> Validation.Rule m
+ -> DirectiveLocation
+ -> t Full.Directive
+ -> Seq (Validation.RuleT m)
+directives context rule directiveLocation directives'
+ | Validation.DirectivesRule directivesRule <- rule =
+ applyToChildren |> directivesRule directiveLocation directiveList
+ | otherwise = applyToChildren
+ where
+ directiveList = toList directives'
+ applyToChildren = foldMap (directive context rule) directiveList
+
+directive :: forall m. Validation m -> ApplyRule m Full.Directive
+directive _ (Validation.ArgumentsRule _ argumentsRule) directive' =
+ pure $ argumentsRule directive'
+directive context rule (Full.Directive directiveName arguments' _) =
+ let argumentTypes = maybe HashMap.empty directiveArguments
+ $ HashMap.lookup directiveName
+ $ Schema.directives
+ $ Validation.schema context
+ in arguments rule argumentTypes arguments'
+ where
+ directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 690631e..c67df1c 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -2,160 +2,229 @@
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
-{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
-- | This module contains default rules defined in the GraphQL specification.
module Language.GraphQL.Validate.Rules
- ( executableDefinitionsRule
+ ( directivesInValidLocationsRule
+ , executableDefinitionsRule
+ , fieldsOnCorrectTypeRule
+ , fragmentsOnCompositeTypesRule
+ , fragmentSpreadTargetDefinedRule
+ , fragmentSpreadTypeExistenceRule
, loneAnonymousOperationRule
+ , knownArgumentNamesRule
+ , knownDirectiveNamesRule
+ , knownInputFieldNamesRule
+ , noFragmentCyclesRule
+ , noUndefinedVariablesRule
+ , noUnusedFragmentsRule
+ , noUnusedVariablesRule
+ , providedRequiredInputFieldsRule
+ , providedRequiredArgumentsRule
+ , scalarLeafsRule
, singleFieldSubscriptionsRule
, specifiedRules
+ , uniqueArgumentNamesRule
+ , uniqueDirectiveNamesRule
, uniqueFragmentNamesRule
+ , uniqueInputFieldNamesRule
, uniqueOperationNamesRule
+ , uniqueVariableNamesRule
+ , variablesAreInputTypesRule
) where
-import Control.Monad (foldM)
+import Control.Monad ((>=>), foldM)
import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.Reader (asks)
-import Control.Monad.Trans.State (evalStateT, gets, modify)
+import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT)
+import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
+import Data.Bifunctor (first)
+import Data.Foldable (find, toList)
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict (HashMap)
+import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
+import Data.List (groupBy, sortBy, sortOn)
+import Data.Maybe (isNothing, mapMaybe)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Ord (comparing)
+import Data.Sequence (Seq(..), (|>))
+import qualified Data.Sequence as Seq
+import Data.Text (Text)
import qualified Data.Text as Text
-import Language.GraphQL.AST.Document
-import Language.GraphQL.Type.Internal
+import qualified Language.GraphQL.AST.Document as Full
+import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.Type.Internal as Type
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Validation
+-- Local help type that contains a hash set to track visited fragments.
+type ValidationState m a =
+ StateT (HashSet Full.Name) (ReaderT (Validation m) Seq) a
+
-- | Default rules given in the specification.
specifiedRules :: forall m. [Rule m]
specifiedRules =
+ -- Documents.
[ executableDefinitionsRule
+ -- Operations.
, singleFieldSubscriptionsRule
, loneAnonymousOperationRule
, uniqueOperationNamesRule
+ -- Fields
+ , fieldsOnCorrectTypeRule
+ , scalarLeafsRule
+ -- Arguments.
+ , knownArgumentNamesRule
+ , uniqueArgumentNamesRule
+ , providedRequiredArgumentsRule
+ -- Fragments.
, uniqueFragmentNamesRule
+ , fragmentSpreadTypeExistenceRule
+ , fragmentsOnCompositeTypesRule
+ , noUnusedFragmentsRule
+ , fragmentSpreadTargetDefinedRule
+ , noFragmentCyclesRule
+ -- Values
+ , knownInputFieldNamesRule
+ , uniqueInputFieldNamesRule
+ , providedRequiredInputFieldsRule
+ -- Directives.
+ , knownDirectiveNamesRule
+ , directivesInValidLocationsRule
+ , uniqueDirectiveNamesRule
+ -- Variables.
+ , uniqueVariableNamesRule
+ , variablesAreInputTypesRule
+ , noUndefinedVariablesRule
+ , noUnusedVariablesRule
]
-- | Definition must be OperationDefinition or FragmentDefinition.
executableDefinitionsRule :: forall m. Rule m
executableDefinitionsRule = DefinitionRule $ \case
- ExecutableDefinition _ -> lift Nothing
- TypeSystemDefinition _ location -> pure $ error' location
- TypeSystemExtension _ location -> pure $ error' location
+ Full.ExecutableDefinition _ -> lift mempty
+ Full.TypeSystemDefinition _ location' -> pure $ error' location'
+ Full.TypeSystemExtension _ location' -> pure $ error' location'
where
- error' location = Error
+ error' location' = Error
{ message =
"Definition must be OperationDefinition or FragmentDefinition."
- , locations = [location]
- , path = []
+ , locations = [location']
}
-- | Subscription operations must have exactly one root field.
singleFieldSubscriptionsRule :: forall m. Rule m
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
- OperationDefinition Subscription name' _ _ rootFields location -> do
+ Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
case HashSet.size groupedFieldSet of
- 1 -> lift Nothing
+ 1 -> lift mempty
_
| Just name <- name' -> pure $ Error
- { message = unwords
- [ "Subscription"
+ { message = concat
+ [ "Subscription \""
, Text.unpack name
- , "must select only one top level field."
+ , "\" must select only one top level field."
]
- , locations = [location]
- , path = []
+ , locations = [location']
}
| otherwise -> pure $ Error
{ message = errorMessage
- , locations = [location]
- , path = []
+ , locations = [location']
}
- _ -> lift Nothing
+ _ -> lift mempty
where
errorMessage =
"Anonymous Subscription must select only one top level field."
collectFields selectionSet = foldM forEach HashSet.empty selectionSet
- forEach accumulator (Field alias name _ directives _)
- | any skip directives = pure accumulator
+ forEach accumulator = \case
+ Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
+ Full.FragmentSpreadSelection fragmentSelection ->
+ forSpread accumulator fragmentSelection
+ Full.InlineFragmentSelection fragmentSelection ->
+ forInline accumulator fragmentSelection
+ forField accumulator (Full.Field alias name _ directives' _ _)
+ | any skip directives' = pure accumulator
| Just aliasedName <- alias = pure
$ HashSet.insert aliasedName accumulator
| otherwise = pure $ HashSet.insert name accumulator
- forEach accumulator (FragmentSpread fragmentName directives)
- | any skip directives = pure accumulator
+ forSpread accumulator (Full.FragmentSpread fragmentName directives' _)
+ | any skip directives' = pure accumulator
| otherwise = do
inVisitetFragments <- gets $ HashSet.member fragmentName
if inVisitetFragments
then pure accumulator
else collectFromSpread fragmentName accumulator
- forEach accumulator (InlineFragment typeCondition' directives selectionSet)
- | any skip directives = pure accumulator
- | Just typeCondition <- typeCondition' =
- collectFromFragment typeCondition selectionSet accumulator
+ forInline accumulator (Full.InlineFragment maybeType directives' selections _)
+ | any skip directives' = pure accumulator
+ | Just typeCondition <- maybeType =
+ collectFromFragment typeCondition selections accumulator
| otherwise = HashSet.union accumulator
- <$> collectFields selectionSet
- skip (Directive "skip" [Argument "if" (Boolean True)]) = True
- skip (Directive "include" [Argument "if" (Boolean False)]) = True
+ <$> collectFields selections
+ skip (Full.Directive "skip" [Full.Argument "if" (Full.Node argumentValue _) _] _) =
+ Full.Boolean True == argumentValue
+ skip (Full.Directive "include" [Full.Argument "if" (Full.Node argumentValue _) _] _) =
+ Full.Boolean False == argumentValue
skip _ = False
- findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing
- | DefinitionFragment fragmentDefinition <- executableDefinition =
- Just fragmentDefinition
- findFragmentDefinition _ accumulator = accumulator
collectFromFragment typeCondition selectionSet accumulator = do
- types' <- lift $ asks types
+ types' <- lift $ asks $ Schema.types . schema
schema' <- lift $ asks schema
- case lookupTypeCondition typeCondition types' of
+ case Type.lookupTypeCondition typeCondition types' of
Nothing -> pure accumulator
Just compositeType
| Just objectType <- Schema.subscription schema'
- , True <- doesFragmentTypeApply compositeType objectType ->
- HashSet.union accumulator<$> collectFields selectionSet
+ , True <- Type.doesFragmentTypeApply compositeType objectType ->
+ HashSet.union accumulator <$> collectFields selectionSet
| otherwise -> pure accumulator
collectFromSpread fragmentName accumulator = do
modify $ HashSet.insert fragmentName
ast' <- lift $ asks ast
- case foldr findFragmentDefinition Nothing ast' of
+ case findFragmentDefinition fragmentName ast' of
Nothing -> pure accumulator
- Just (FragmentDefinition _ typeCondition _ selectionSet _) ->
+ Just (Full.FragmentDefinition _ typeCondition _ selectionSet _) ->
collectFromFragment typeCondition selectionSet accumulator
-- | GraphQL allows a short‐hand form for defining query operations when only
-- that one operation exists in the document.
loneAnonymousOperationRule :: forall m. Rule m
loneAnonymousOperationRule = OperationDefinitionRule $ \case
- SelectionSet _ thisLocation -> check thisLocation
- OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation
- _ -> lift Nothing
+ Full.SelectionSet _ thisLocation -> check thisLocation
+ Full.OperationDefinition _ Nothing _ _ _ thisLocation ->
+ check thisLocation
+ _ -> lift mempty
where
check thisLocation = asks ast
- >>= lift . foldr (filterAnonymousOperations thisLocation) Nothing
- filterAnonymousOperations thisLocation definition Nothing
+ >>= lift . foldr (filterAnonymousOperations thisLocation) mempty
+ filterAnonymousOperations thisLocation definition Empty
| (viewOperation -> Just operationDefinition) <- definition =
compareAnonymousOperations thisLocation operationDefinition
filterAnonymousOperations _ _ accumulator = accumulator
compareAnonymousOperations thisLocation = \case
- OperationDefinition _ _ _ _ _ thatLocation
+ Full.OperationDefinition _ _ _ _ _ thatLocation
| thisLocation /= thatLocation -> pure $ error' thisLocation
- SelectionSet _ thatLocation
+ Full.SelectionSet _ thatLocation
| thisLocation /= thatLocation -> pure $ error' thisLocation
- _ -> Nothing
- error' location = Error
+ _ -> mempty
+ error' location' = Error
{ message =
"This anonymous operation must be the only defined operation."
- , locations = [location]
- , path = []
+ , locations = [location']
}
-- | Each named operation definition must be unique within a document when
-- referred to by its name.
uniqueOperationNamesRule :: forall m. Rule m
uniqueOperationNamesRule = OperationDefinitionRule $ \case
- OperationDefinition _ (Just thisName) _ _ _ thisLocation ->
+ Full.OperationDefinition _ (Just thisName) _ _ _ thisLocation ->
findDuplicates (filterByName thisName) thisLocation (error' thisName)
- _ -> lift Nothing
+ _ -> lift mempty
where
error' operationName = concat
[ "There can be only one operation named \""
@@ -164,12 +233,12 @@ uniqueOperationNamesRule = OperationDefinitionRule $ \case
]
filterByName thisName definition' accumulator
| (viewOperation -> Just operationDefinition) <- definition'
- , OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition
+ , Full.OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition
, thisName == thatName = thatLocation : accumulator
| otherwise = accumulator
-findDuplicates :: (Definition -> [Location] -> [Location])
- -> Location
+findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])
+ -> Full.Location
-> String
-> RuleT m
findDuplicates filterByName thisLocation errorMessage = do
@@ -177,21 +246,27 @@ findDuplicates filterByName thisLocation errorMessage = do
let locations' = foldr filterByName [] ast'
if length locations' > 1 && head locations' == thisLocation
then pure $ error' locations'
- else lift Nothing
+ else lift mempty
where
error' locations' = Error
{ message = errorMessage
, locations = locations'
- , path = []
}
-viewOperation :: Definition -> Maybe OperationDefinition
+viewOperation :: Full.Definition -> Maybe Full.OperationDefinition
viewOperation definition
- | ExecutableDefinition executableDefinition <- definition
- , DefinitionOperation operationDefinition <- executableDefinition =
+ | Full.ExecutableDefinition executableDefinition <- definition
+ , Full.DefinitionOperation operationDefinition <- executableDefinition =
Just operationDefinition
viewOperation _ = Nothing
+viewFragment :: Full.Definition -> Maybe Full.FragmentDefinition
+viewFragment definition
+ | Full.ExecutableDefinition executableDefinition <- definition
+ , Full.DefinitionFragment fragmentDefinition <- executableDefinition =
+ Just fragmentDefinition
+viewFragment _ = Nothing
+
-- | Fragment definitions are referenced in fragment spreads by name. To avoid
-- ambiguity, each fragment’s name must be unique within a document.
--
@@ -199,7 +274,7 @@ viewOperation _ = Nothing
-- by this validation rule.
uniqueFragmentNamesRule :: forall m. Rule m
uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
- FragmentDefinition thisName _ _ _ thisLocation ->
+ Full.FragmentDefinition thisName _ _ _ thisLocation ->
findDuplicates (filterByName thisName) thisLocation (error' thisName)
where
error' fragmentName = concat
@@ -208,8 +283,733 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
, "\"."
]
filterByName thisName definition accumulator
- | ExecutableDefinition executableDefinition <- definition
- , DefinitionFragment fragmentDefinition <- executableDefinition
- , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition
+ | Just fragmentDefinition <- viewFragment definition
+ , Full.FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition
, thisName == thatName = thatLocation : accumulator
| otherwise = accumulator
+
+-- | Named fragment spreads must refer to fragments defined within the document.
+-- It is a validation error if the target of a spread is not defined.
+fragmentSpreadTargetDefinedRule :: forall m. Rule m
+fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case
+ Full.FragmentSpread fragmentName _ location' -> do
+ ast' <- asks ast
+ case find (isSpreadTarget fragmentName) ast' of
+ Nothing -> pure $ Error
+ { message = error' fragmentName
+ , locations = [location']
+ }
+ Just _ -> lift mempty
+ where
+ error' fragmentName = concat
+ [ "Fragment target \""
+ , Text.unpack fragmentName
+ , "\" is undefined."
+ ]
+
+isSpreadTarget :: Text -> Full.Definition -> Bool
+isSpreadTarget thisName (viewFragment -> Just fragmentDefinition)
+ | Full.FragmentDefinition thatName _ _ _ _ <- fragmentDefinition
+ , thisName == thatName = True
+isSpreadTarget _ _ = False
+
+-- | Fragments must be specified on types that exist in the schema. This applies
+-- for both named and inline fragments. If they are not defined in the schema,
+-- the query does not validate.
+fragmentSpreadTypeExistenceRule :: forall m. Rule m
+fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
+ Full.FragmentSpreadSelection fragmentSelection
+ | Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do
+ ast' <- asks ast
+ let target = find (isSpreadTarget fragmentName) ast'
+ typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition
+ types' <- asks $ Schema.types . schema
+ case HashMap.lookup typeCondition types' of
+ Nothing -> pure $ Error
+ { message = spreadError fragmentName typeCondition
+ , locations = [location']
+ }
+ Just _ -> lift mempty
+ Full.InlineFragmentSelection fragmentSelection
+ | Full.InlineFragment maybeType _ _ location' <- fragmentSelection
+ , Just typeCondition <- maybeType -> do
+ types' <- asks $ Schema.types . schema
+ case HashMap.lookup typeCondition types' of
+ Nothing -> pure $ Error
+ { message = inlineError typeCondition
+ , locations = [location']
+ }
+ Just _ -> lift mempty
+ _ -> lift mempty
+ where
+ extractTypeCondition (viewFragment -> Just fragmentDefinition) =
+ let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition
+ in Just typeCondition
+ extractTypeCondition _ = Nothing
+ spreadError fragmentName typeCondition = concat
+ [ "Fragment \""
+ , Text.unpack fragmentName
+ , "\" is specified on type \""
+ , Text.unpack typeCondition
+ , "\" which doesn't exist in the schema."
+ ]
+ inlineError typeCondition = concat
+ [ "Inline fragment is specified on type \""
+ , Text.unpack typeCondition
+ , "\" which doesn't exist in the schema."
+ ]
+
+maybeToSeq :: forall a. Maybe a -> Seq a
+maybeToSeq (Just x) = pure x
+maybeToSeq Nothing = mempty
+
+-- | Fragments can only be declared on unions, interfaces, and objects. They are
+-- invalid on scalars. They can only be applied on non‐leaf fields. This rule
+-- applies to both inline and named fragments.
+fragmentsOnCompositeTypesRule :: forall m. Rule m
+fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
+ where
+ inlineRule (Full.InlineFragment (Just typeCondition) _ _ location') =
+ check typeCondition location'
+ inlineRule _ = lift mempty
+ definitionRule (Full.FragmentDefinition _ typeCondition _ _ location') =
+ check typeCondition location'
+ check typeCondition location' = do
+ types' <- asks $ Schema.types . schema
+ -- Skip unknown types, they are checked by another rule.
+ _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types'
+ case Type.lookupTypeCondition typeCondition types' of
+ Nothing -> pure $ Error
+ { message = errorMessage typeCondition
+ , locations = [location']
+ }
+ Just _ -> lift mempty
+ errorMessage typeCondition = concat
+ [ "Fragment cannot condition on non composite type \""
+ , Text.unpack typeCondition,
+ "\"."
+ ]
+
+-- | Defined fragments must be used within a document.
+noUnusedFragmentsRule :: forall m. Rule m
+noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do
+ let Full.FragmentDefinition fragmentName _ _ _ location' = fragment
+ in mapReaderT (checkFragmentName fragmentName location')
+ $ asks ast
+ >>= flip evalStateT HashSet.empty
+ . filterSelections evaluateSelection
+ . foldMap definitionSelections
+ where
+ checkFragmentName fragmentName location' elements
+ | fragmentName `elem` elements = mempty
+ | otherwise = pure $ makeError fragmentName location'
+ makeError fragName location' = Error
+ { message = errorMessage fragName
+ , locations = [location']
+ }
+ errorMessage fragName = concat
+ [ "Fragment \""
+ , Text.unpack fragName
+ , "\" is never used."
+ ]
+ evaluateSelection selection
+ | Full.FragmentSpreadSelection spreadSelection <- selection
+ , Full.FragmentSpread spreadName _ _ <- spreadSelection =
+ lift $ pure spreadName
+ evaluateSelection _ = lift $ lift mempty
+
+definitionSelections :: Full.Definition -> Full.SelectionSetOpt
+definitionSelections (viewOperation -> Just operation)
+ | Full.OperationDefinition _ _ _ _ selections _ <- operation =
+ toList selections
+ | Full.SelectionSet selections _ <- operation = toList selections
+definitionSelections (viewFragment -> Just fragment)
+ | Full.FragmentDefinition _ _ _ selections _ <- fragment = toList selections
+definitionSelections _ = []
+
+filterSelections :: Foldable t
+ => forall a m
+ . (Full.Selection -> ValidationState m a)
+ -> t Full.Selection
+ -> ValidationState m a
+filterSelections applyFilter selections
+ = (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections)
+ >>= applyFilter
+ where
+ evaluateSelection selection accumulator
+ | Full.FragmentSpreadSelection{} <- selection = selection : accumulator
+ | Full.FieldSelection fieldSelection <- selection
+ , Full.Field _ _ _ _ subselections _ <- fieldSelection =
+ selection : foldr evaluateSelection accumulator subselections
+ | Full.InlineFragmentSelection inlineSelection <- selection
+ , Full.InlineFragment _ _ subselections _ <- inlineSelection =
+ selection : foldr evaluateSelection accumulator subselections
+
+-- | The graph of fragment spreads must not form any cycles including spreading
+-- itself. Otherwise an operation could infinitely spread or infinitely execute
+-- on cycles in the underlying data.
+noFragmentCyclesRule :: forall m. Rule m
+noFragmentCyclesRule = FragmentDefinitionRule $ \case
+ Full.FragmentDefinition fragmentName _ _ selections location' -> do
+ state <- evalStateT (collectFields selections)
+ (0, fragmentName)
+ let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)
+ case reverse spreadPath of
+ x : _ | x == fragmentName -> pure $ Error
+ { message = concat
+ [ "Cannot spread fragment \""
+ , Text.unpack fragmentName
+ , "\" within itself (via "
+ , Text.unpack $ Text.intercalate " -> " $ fragmentName : spreadPath
+ , ")."
+ ]
+ , locations = [location']
+ }
+ _ -> lift mempty
+ where
+ collectFields :: Traversable t
+ => t Full.Selection
+ -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
+ collectFields selectionSet = foldM forEach HashMap.empty selectionSet
+ forEach accumulator = \case
+ Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
+ Full.InlineFragmentSelection fragmentSelection ->
+ forInline accumulator fragmentSelection
+ Full.FragmentSpreadSelection fragmentSelection ->
+ forSpread accumulator fragmentSelection
+ forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do
+ firstFragmentName <- gets snd
+ modify $ first (+ 1)
+ lastIndex <- gets fst
+ let newAccumulator = HashMap.insert fragmentName lastIndex accumulator
+ let inVisitetFragment = HashMap.member fragmentName accumulator
+ if fragmentName == firstFragmentName || inVisitetFragment
+ then pure newAccumulator
+ else collectFromSpread fragmentName newAccumulator
+ forInline accumulator (Full.InlineFragment _ _ selections _) =
+ (accumulator <>) <$> collectFields selections
+ forField accumulator (Full.Field _ _ _ _ selections _) =
+ (accumulator <>) <$> collectFields selections
+ collectFromSpread fragmentName accumulator = do
+ ast' <- lift $ asks ast
+ case findFragmentDefinition fragmentName ast' of
+ Nothing -> pure accumulator
+ Just (Full.FragmentDefinition _ _ _ selections _) ->
+ (accumulator <>) <$> collectFields selections
+
+findFragmentDefinition :: Text
+ -> NonEmpty Full.Definition
+ -> Maybe Full.FragmentDefinition
+findFragmentDefinition fragmentName = foldr compareDefinition Nothing
+ where
+ compareDefinition (Full.ExecutableDefinition executableDefinition) Nothing
+ | Full.DefinitionFragment fragmentDefinition <- executableDefinition
+ , Full.FragmentDefinition anotherName _ _ _ _ <- fragmentDefinition
+ , anotherName == fragmentName = Just fragmentDefinition
+ compareDefinition _ accumulator = accumulator
+
+-- | Fields and directives treat arguments as a mapping of argument name to
+-- value. More than one argument with the same name in an argument set is
+-- ambiguous and invalid.
+uniqueArgumentNamesRule :: forall m. Rule m
+uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
+ where
+ fieldRule _ (Full.Field _ _ arguments _ _ _) =
+ lift $ filterDuplicates extract "argument" arguments
+ directiveRule (Full.Directive _ arguments _) =
+ lift $ filterDuplicates extract "argument" arguments
+ extract (Full.Argument argumentName _ location') = (argumentName, location')
+
+-- | Directives are used to describe some metadata or behavioral change on the
+-- definition they apply to. When more than one directive of the same name is
+-- used, the expected metadata or behavior becomes ambiguous, therefore only one
+-- of each directive is allowed per location.
+uniqueDirectiveNamesRule :: forall m. Rule m
+uniqueDirectiveNamesRule = DirectivesRule
+ $ const $ lift . filterDuplicates extract "directive"
+ where
+ extract (Full.Directive directiveName _ location') =
+ (directiveName, location')
+
+filterDuplicates :: (a -> (Text, Full.Location)) -> String -> [a] -> Seq Error
+filterDuplicates extract nodeType = Seq.fromList
+ . fmap makeError
+ . filter ((> 1) . length)
+ . groupBy equalByName
+ . sortOn getName
+ where
+ getName = fst . extract
+ equalByName lhs rhs = getName lhs == getName rhs
+ makeError directives' = Error
+ { message = makeMessage $ head directives'
+ , locations = snd . extract <$> directives'
+ }
+ makeMessage directive = concat
+ [ "There can be only one "
+ , nodeType
+ , " named \""
+ , Text.unpack $ fst $ extract directive
+ , "\"."
+ ]
+
+-- | If any operation defines more than one variable with the same name, it is
+-- ambiguous and invalid. It is invalid even if the type of the duplicate
+-- variable is the same.
+uniqueVariableNamesRule :: forall m. Rule m
+uniqueVariableNamesRule = VariablesRule
+ $ lift . filterDuplicates extract "variable"
+ where
+ extract (Full.VariableDefinition variableName _ _ location') =
+ (variableName, location')
+
+-- | Variables can only be input types. Objects, unions and interfaces cannot be
+-- used as inputs.
+variablesAreInputTypesRule :: forall m. Rule m
+variablesAreInputTypesRule = VariablesRule
+ $ (traverse check . Seq.fromList) >=> lift
+ where
+ check (Full.VariableDefinition name typeName _ location')
+ = asks (Schema.types . schema)
+ >>= lift
+ . maybe (makeError name typeName location') (const mempty)
+ . Type.lookupInputType typeName
+ makeError name typeName location' = pure $ Error
+ { message = concat
+ [ "Variable \"$"
+ , Text.unpack name
+ , "\" cannot be non-input type \""
+ , Text.unpack $ getTypeName typeName
+ , "\"."
+ ]
+ , locations = [location']
+ }
+ getTypeName (Full.TypeNamed name) = name
+ getTypeName (Full.TypeList name) = getTypeName name
+ getTypeName (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) = nonNull
+ getTypeName (Full.TypeNonNull (Full.NonNullTypeList nonNull)) =
+ getTypeName nonNull
+
+-- | Variables are scoped on a per‐operation basis. That means that any variable
+-- used within the context of an operation must be defined at the top level of
+-- that operation.
+noUndefinedVariablesRule :: forall m. Rule m
+noUndefinedVariablesRule =
+ variableUsageDifference (flip HashMap.difference) errorMessage
+ where
+ errorMessage Nothing variableName = concat
+ [ "Variable \"$"
+ , Text.unpack variableName
+ , "\" is not defined."
+ ]
+ errorMessage (Just operationName) variableName = concat
+ [ "Variable \"$"
+ , Text.unpack variableName
+ , "\" is not defined by operation \""
+ , Text.unpack operationName
+ , "\"."
+ ]
+
+type UsageDifference
+ = HashMap Full.Name [Full.Location]
+ -> HashMap Full.Name [Full.Location]
+ -> HashMap Full.Name [Full.Location]
+
+variableUsageDifference :: forall m. UsageDifference
+ -> (Maybe Full.Name -> Full.Name -> String)
+ -> Rule m
+variableUsageDifference difference errorMessage = OperationDefinitionRule $ \case
+ Full.SelectionSet _ _ -> lift mempty
+ Full.OperationDefinition _ operationName variables _ selections _ ->
+ let variableNames = HashMap.fromList $ getVariableName <$> variables
+ in mapReaderT (readerMapper operationName variableNames)
+ $ flip evalStateT HashSet.empty
+ $ filterSelections'
+ $ toList selections
+ where
+ readerMapper operationName variableNames' = Seq.fromList
+ . fmap (makeError operationName)
+ . HashMap.toList
+ . difference variableNames'
+ . HashMap.fromListWith (++)
+ . toList
+ getVariableName (Full.VariableDefinition variableName _ _ location') =
+ (variableName, [location'])
+ filterSelections' :: Foldable t
+ => t Full.Selection
+ -> ValidationState m (Full.Name, [Full.Location])
+ filterSelections' = filterSelections variableFilter
+ variableFilter :: Full.Selection -> ValidationState m (Full.Name, [Full.Location])
+ variableFilter (Full.InlineFragmentSelection inline)
+ | Full.InlineFragment _ directives' _ _ <- inline =
+ lift $ lift $ mapDirectives directives'
+ variableFilter (Full.FieldSelection fieldSelection)
+ | Full.Field _ _ arguments directives' _ _ <- fieldSelection =
+ lift $ lift $ mapArguments arguments <> mapDirectives directives'
+ variableFilter (Full.FragmentSpreadSelection spread)
+ | Full.FragmentSpread fragmentName _ _ <- spread = do
+ definitions <- lift $ asks ast
+ visited <- gets (HashSet.member fragmentName)
+ modify (HashSet.insert fragmentName)
+ case find (isSpreadTarget fragmentName) definitions of
+ Just (viewFragment -> Just fragmentDefinition)
+ | not visited -> diveIntoSpread fragmentDefinition
+ _ -> lift $ lift mempty
+ diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _)
+ = filterSelections' selections
+ >>= lift . mapReaderT (<> mapDirectives directives') . pure
+ findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments
+ mapArguments = Seq.fromList . mapMaybe findArgumentVariables
+ mapDirectives = foldMap findDirectiveVariables
+ findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) =
+ Just (value', [location])
+ findArgumentVariables _ = Nothing
+ makeError operationName (variableName, locations') = Error
+ { message = errorMessage operationName variableName
+ , locations = locations'
+ }
+
+-- | All variables defined by an operation must be used in that operation or a
+-- fragment transitively included by that operation. Unused variables cause a
+-- validation error.
+noUnusedVariablesRule :: forall m. Rule m
+noUnusedVariablesRule = variableUsageDifference HashMap.difference errorMessage
+ where
+ errorMessage Nothing variableName = concat
+ [ "Variable \"$"
+ , Text.unpack variableName
+ , "\" is never used."
+ ]
+ errorMessage (Just operationName) variableName = concat
+ [ "Variable \"$"
+ , Text.unpack variableName
+ , "\" is never used in operation \""
+ , Text.unpack operationName
+ , "\"."
+ ]
+
+-- | Input objects must not contain more than one field of the same name,
+-- otherwise an ambiguity would exist which includes an ignored portion of
+-- syntax.
+uniqueInputFieldNamesRule :: forall m. Rule m
+uniqueInputFieldNamesRule =
+ ValueRule (const $ lift . go) (const $ lift . constGo)
+ where
+ go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields
+ go _ = mempty
+ filterFieldDuplicates fields =
+ filterDuplicates getFieldName "input field" fields
+ getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location')
+ constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields
+ constGo _ = mempty
+
+-- | The target field of a field selection must be defined on the scoped type of
+-- the selection set. There are no limitations on alias names.
+fieldsOnCorrectTypeRule :: forall m. Rule m
+fieldsOnCorrectTypeRule = FieldRule fieldRule
+ where
+ fieldRule parentType (Full.Field _ fieldName _ _ _ location')
+ | Just objectType <- parentType
+ , Nothing <- Type.lookupTypeField fieldName objectType
+ , Just typeName <- compositeTypeName objectType = pure $ Error
+ { message = errorMessage fieldName typeName
+ , locations = [location']
+ }
+ | otherwise = lift mempty
+ errorMessage fieldName typeName = concat
+ [ "Cannot query field \""
+ , Text.unpack fieldName
+ , "\" on type \""
+ , Text.unpack typeName
+ , "\"."
+ ]
+
+compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name
+compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
+ Just typeName
+compositeTypeName (Out.InterfaceBaseType interfaceType) =
+ let Out.InterfaceType typeName _ _ _ = interfaceType
+ in Just typeName
+compositeTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) =
+ Just typeName
+compositeTypeName (Out.ScalarBaseType _) =
+ Nothing
+compositeTypeName (Out.EnumBaseType _) =
+ Nothing
+compositeTypeName (Out.ListBaseType wrappedType) =
+ compositeTypeName wrappedType
+
+-- | Field selections on scalars or enums are never allowed, because they are
+-- the leaf nodes of any GraphQL query.
+scalarLeafsRule :: forall m. Rule m
+scalarLeafsRule = FieldRule fieldRule
+ where
+ fieldRule parentType selectionField@(Full.Field _ fieldName _ _ _ _)
+ | Just objectType <- parentType
+ , Just field <- Type.lookupTypeField fieldName objectType =
+ let Out.Field _ fieldType _ = field
+ in lift $ check fieldType selectionField
+ | otherwise = lift mempty
+ check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
+ checkNotEmpty typeName
+ check (Out.InterfaceBaseType (Out.InterfaceType typeName _ _ _)) =
+ checkNotEmpty typeName
+ check (Out.UnionBaseType (Out.UnionType typeName _ _)) =
+ checkNotEmpty typeName
+ check (Out.ScalarBaseType (Definition.ScalarType typeName _)) =
+ checkEmpty typeName
+ check (Out.EnumBaseType (Definition.EnumType typeName _ _)) =
+ checkEmpty typeName
+ check (Out.ListBaseType wrappedType) = check wrappedType
+ checkNotEmpty typeName (Full.Field _ fieldName _ _ [] location') =
+ let fieldName' = Text.unpack fieldName
+ in makeError location' $ concat
+ [ "Field \""
+ , fieldName'
+ , "\" of type \""
+ , Text.unpack typeName
+ , "\" must have a selection of subfields. Did you mean \""
+ , fieldName'
+ , " { ... }\"?"
+ ]
+ checkNotEmpty _ _ = mempty
+ checkEmpty _ (Full.Field _ _ _ _ [] _) = mempty
+ checkEmpty typeName field' =
+ let Full.Field _ fieldName _ _ _ location' = field'
+ in makeError location' $ concat
+ [ "Field \""
+ , Text.unpack fieldName
+ , "\" must not have a selection since type \""
+ , Text.unpack typeName
+ , "\" has no subfields."
+ ]
+ makeError location' errorMessage = pure $ Error
+ { message = errorMessage
+ , locations = [location']
+ }
+
+-- | Every argument provided to a field or directive must be defined in the set
+-- of possible arguments of that field or directive.
+knownArgumentNamesRule :: forall m. Rule m
+knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
+ where
+ fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ _)
+ | Just typeField <- Type.lookupTypeField fieldName objectType
+ , Just typeName <- compositeTypeName objectType =
+ lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
+ fieldRule _ _ = lift mempty
+ go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors
+ | Out.Field _ _ definitions <- fieldDefinition
+ , Just _ <- HashMap.lookup argumentName definitions = errors
+ | otherwise = errors |> Error
+ { message = fieldMessage argumentName fieldName typeName
+ , locations = [location']
+ }
+ fieldMessage argumentName fieldName typeName = concat
+ [ "Unknown argument \""
+ , Text.unpack argumentName
+ , "\" on field \""
+ , Text.unpack typeName
+ , "."
+ , Text.unpack fieldName
+ , "\"."
+ ]
+ directiveRule (Full.Directive directiveName arguments _) = do
+ available <- asks $ HashMap.lookup directiveName
+ . Schema.directives . schema
+ Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments
+ case available of
+ Just (Schema.Directive _ _ definitions)
+ | not $ HashMap.member argumentName definitions ->
+ pure $ makeError argumentName directiveName location'
+ _ -> lift mempty
+ makeError argumentName directiveName location' = Error
+ { message = directiveMessage argumentName directiveName
+ , locations = [location']
+ }
+ directiveMessage argumentName directiveName = concat
+ [ "Unknown argument \""
+ , Text.unpack argumentName
+ , "\" on directive \"@"
+ , Text.unpack directiveName
+ , "\"."
+ ]
+
+-- | GraphQL servers define what directives they support. For each usage of a
+-- directive, the directive must be available on that server.
+knownDirectiveNamesRule :: Rule m
+knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
+ definitions' <- asks $ Schema.directives . schema
+ let directiveSet = HashSet.fromList $ fmap directiveName directives'
+ let definitionSet = HashSet.fromList $ HashMap.keys definitions'
+ let difference = HashSet.difference directiveSet definitionSet
+ let undefined' = filter (definitionFilter difference) directives'
+ lift $ Seq.fromList $ makeError <$> undefined'
+ where
+ definitionFilter difference = flip HashSet.member difference
+ . directiveName
+ directiveName (Full.Directive directiveName' _ _) = directiveName'
+ makeError (Full.Directive directiveName' _ location') = Error
+ { message = errorMessage directiveName'
+ , locations = [location']
+ }
+ errorMessage directiveName' = concat
+ [ "Unknown directive \"@"
+ , Text.unpack directiveName'
+ , "\"."
+ ]
+
+-- | Every input field provided in an input object value must be defined in the
+-- set of possible fields of that input object’s expected type.
+knownInputFieldNamesRule :: Rule m
+knownInputFieldNamesRule = ValueRule go constGo
+ where
+ go (Just valueType) (Full.Node (Full.Object inputFields) _)
+ | In.InputObjectBaseType objectType <- valueType =
+ lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields
+ go _ _ = lift mempty
+ constGo (Just valueType) (Full.Node (Full.ConstObject inputFields) _)
+ | In.InputObjectBaseType objectType <- valueType =
+ lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields
+ constGo _ _ = lift mempty
+ forEach objectType (Full.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
+ , "\"."
+ ]
+
+-- | GraphQL servers define what directives they support and where they support
+-- them. For each usage of a directive, the directive must be used in a location
+-- that the server has declared support for.
+directivesInValidLocationsRule :: Rule m
+directivesInValidLocationsRule = DirectivesRule directivesRule
+ where
+ directivesRule directiveLocation directives' = do
+ Full.Directive directiveName _ location <- lift $ Seq.fromList directives'
+ maybeDefinition <- asks
+ $ HashMap.lookup directiveName . Schema.directives . schema
+ case maybeDefinition of
+ Just (Schema.Directive _ allowedLocations _)
+ | directiveLocation `notElem` allowedLocations -> pure $ Error
+ { message = errorMessage directiveName directiveLocation
+ , locations = [location]
+ }
+ _ -> lift mempty
+ errorMessage directiveName directiveLocation = concat
+ [ "Directive \"@"
+ , Text.unpack directiveName
+ , "\" may not be used on "
+ , show directiveLocation
+ , "."
+ ]
+
+-- | Arguments can be required. An argument is required if the argument type is
+-- non‐null and does not have a default value. Otherwise, the argument is
+-- optional.
+providedRequiredArgumentsRule :: Rule m
+providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule
+ where
+ fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ location')
+ | Just typeField <- Type.lookupTypeField fieldName objectType
+ , Out.Field _ _ definitions <- typeField =
+ let forEach = go (fieldMessage fieldName) arguments location'
+ in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
+ fieldRule _ _ = lift mempty
+ directiveRule (Full.Directive directiveName arguments location') = do
+ available <- asks
+ $ HashMap.lookup directiveName . Schema.directives . schema
+ case available of
+ Just (Schema.Directive _ _ definitions) ->
+ let forEach = go (directiveMessage directiveName) arguments location'
+ in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
+ _ -> lift mempty
+ go makeMessage arguments location' argumentName argumentType errors
+ | In.Argument _ type' optionalValue <- argumentType
+ , In.isNonNullType type'
+ , typeName <- inputTypeName type'
+ , isNothing optionalValue
+ , isNothingOrNull $ find (lookupArgument argumentName) arguments
+ = errors
+ |> makeError (makeMessage argumentName typeName) location'
+ | otherwise = errors
+ makeError errorMessage location' = Error
+ { message = errorMessage
+ , locations = [location']
+ }
+ isNothingOrNull (Just (Full.Argument _ (Full.Node Full.Null _) _)) = True
+ isNothingOrNull x = isNothing x
+ lookupArgument needle (Full.Argument argumentName _ _) =
+ needle == argumentName
+ fieldMessage fieldName argumentName typeName = concat
+ [ "Field \""
+ , Text.unpack fieldName
+ , "\" argument \""
+ , Text.unpack argumentName
+ , "\" of type \""
+ , Text.unpack typeName
+ , "\" is required, but it was not provided."
+ ]
+ directiveMessage directiveName argumentName typeName = concat
+ [ "Directive \"@"
+ , Text.unpack directiveName
+ , "\" argument \""
+ , Text.unpack argumentName
+ , "\" of type \""
+ , Text.unpack typeName
+ , "\" is required, but it was not provided."
+ ]
+
+inputTypeName :: In.Type -> Text
+inputTypeName (In.ScalarBaseType (Definition.ScalarType typeName _)) = typeName
+inputTypeName (In.EnumBaseType (Definition.EnumType typeName _ _)) = typeName
+inputTypeName (In.InputObjectBaseType (In.InputObjectType typeName _ _)) =
+ typeName
+inputTypeName (In.ListBaseType listType) = inputTypeName listType
+
+-- | Input object fields may be required. Much like a field may have required
+-- arguments, an input object may have required fields. An input field is
+-- required if it has a non‐null type and does not have a default value.
+-- Otherwise, the input object field is optional.
+providedRequiredInputFieldsRule :: Rule m
+providedRequiredInputFieldsRule = ValueRule go constGo
+ where
+ go (Just valueType) (Full.Node (Full.Object inputFields) location')
+ | In.InputObjectBaseType objectType <- valueType
+ , In.InputObjectType objectTypeName _ fieldDefinitions <- objectType
+ = lift
+ $ Seq.fromList
+ $ HashMap.elems
+ $ flip HashMap.mapMaybeWithKey fieldDefinitions
+ $ forEach inputFields objectTypeName location'
+ go _ _ = lift mempty
+ constGo _ _ = lift mempty
+ forEach inputFields typeName location' definitionName fieldDefinition
+ | In.InputField _ inputType optionalValue <- fieldDefinition
+ , In.isNonNullType inputType
+ , isNothing optionalValue
+ , isNothingOrNull $ find (lookupField definitionName) inputFields =
+ Just $ makeError definitionName typeName location'
+ | otherwise = Nothing
+ isNothingOrNull (Just (Full.ObjectField _ (Full.Node Full.Null _) _)) = True
+ isNothingOrNull x = isNothing x
+ lookupField needle (Full.ObjectField fieldName _ _) = needle == fieldName
+ makeError fieldName typeName location' = Error
+ { message = errorMessage fieldName typeName
+ , locations = [location']
+ }
+ errorMessage fieldName typeName = concat
+ [ "Input field \""
+ , Text.unpack fieldName
+ , "\" of type \""
+ , Text.unpack typeName
+ , "\" is required, but it was not provided."
+ ]
diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs
index 03bbf33..0432a1a 100644
--- a/src/Language/GraphQL/Validate/Validation.hs
+++ b/src/Language/GraphQL/Validate/Validation.hs
@@ -5,41 +5,29 @@
-- | Definitions used by the validation rules and the validator itself.
module Language.GraphQL.Validate.Validation
( Error(..)
- , Path(..)
, Rule(..)
, RuleT
, Validation(..)
) where
-import Control.Monad.Trans.Reader (ReaderT(..))
-import Data.HashMap.Strict (HashMap)
-import Data.Text (Text)
+import Control.Monad.Trans.Reader (ReaderT)
+import Data.Sequence (Seq)
+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
import Language.GraphQL.AST.Document
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema)
-import qualified Language.GraphQL.Type.Schema as Schema
-
--- | If an error can be associated to a particular field in the GraphQL result,
--- it must contain an entry with the key path that details the path of the
--- response field which experienced the error. This allows clients to identify
--- whether a null result is intentional or caused by a runtime error.
-data Path
- = Segment Text -- ^ Field name.
- | Index Int -- ^ List index if a field returned a list.
- deriving (Eq, Show)
-- | Validation error.
data Error = Error
{ message :: String
, locations :: [Location]
- , path :: [Path]
} deriving (Eq, Show)
-- | Validation rule context.
data Validation m = Validation
{ ast :: Document
, schema :: Schema m
- , types :: HashMap Name (Schema.Type m)
- , rules :: [Rule m]
}
-- | 'Rule' assigns a function to each AST node that can be validated. If the
@@ -49,6 +37,14 @@ data Rule m
= DefinitionRule (Definition -> RuleT m)
| OperationDefinitionRule (OperationDefinition -> RuleT m)
| FragmentDefinitionRule (FragmentDefinition -> RuleT m)
+ | SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)
+ | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
+ | FragmentSpreadRule (FragmentSpread -> RuleT m)
+ | FieldRule (Maybe (Out.Type m) -> Field -> RuleT m)
+ | ArgumentsRule (Maybe (Out.Type m) -> Field -> RuleT m) (Directive -> RuleT m)
+ | DirectivesRule (DirectiveLocation -> [Directive] -> RuleT m)
+ | VariablesRule ([VariableDefinition] -> RuleT m)
+ | ValueRule (Maybe In.Type -> Node Value -> RuleT m) (Maybe In.Type -> Node ConstValue -> RuleT m)
-- | Monad transformer used by the rules.
-type RuleT m = ReaderT (Validation m) Maybe Error
+type RuleT m = ReaderT (Validation m) Seq Error
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:51:54 +0000