Compare commits
15 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | 2839b28590 | |
Eugen Wissner | ed725ea514 | |
Eugen Wissner | b27da54bf4 | |
Eugen Wissner | a034f2ce4d | |
Eugen Wissner | ebf4f4d24e | |
Eugen Wissner | 1c7554c328 | |
Eugen Wissner | c018657e25 | |
Eugen Wissner | 71a5964c27 | |
Eugen Wissner | 22abf7ca58 | |
Eugen Wissner | 5a6709030c | |
Eugen Wissner | 2bcae9e0a7 | |
Eugen Wissner | 2dbc985dfc | |
Eugen Wissner | 86a0e00f7e | |
Eugen Wissner | 1f4eb6fb9b | |
Eugen Wissner | f5209481aa |
14
CHANGELOG.md
14
CHANGELOG.md
|
@ -6,6 +6,19 @@ The format is based on
|
|||
and this project adheres to
|
||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||
|
||||
## [0.11.1.0] - 2021-02-07
|
||||
### Added
|
||||
- `Validate.Rules`:
|
||||
- `overlappingFieldsCanBeMergedRule`
|
||||
- `possibleFragmentSpreadsRule`
|
||||
- `variablesInAllowedPositionRule`
|
||||
- `valuesOfCorrectTypeRule`
|
||||
- `Type.Schema.implementations` contains a map from interfaces and objects to
|
||||
interfaces they implement.
|
||||
- Show instances for GraphQL type definitions in the `Type` modules.
|
||||
- Custom Show instances for type and value representations in the AST.
|
||||
- `AST.Document.escape` escapes a single character in a `StringValue`.
|
||||
|
||||
## [0.11.0.0] - 2020-11-07
|
||||
### Changed
|
||||
- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
|
||||
|
@ -400,6 +413,7 @@ and this project adheres to
|
|||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[0.11.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.1.0&rev_to=v0.11.0.0
|
||||
[0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0
|
||||
[0.10.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.10.0.0&rev_to=v0.9.0.0
|
||||
[0.9.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.9.0.0&rev_to=v0.8.0.0
|
||||
|
|
25
README.md
25
README.md
|
@ -3,29 +3,10 @@
|
|||
[![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org)
|
||||
[![CI/CD](https://img.shields.io/badge/CI-CD-brightgreen)](https://build.caraus.tech/go/pipelines)
|
||||
|
||||
This implementation is relatively low-level by design, it doesn't provide any
|
||||
mappings between the GraphQL types and Haskell's type system and avoids
|
||||
compile-time magic. It focuses on flexibility instead, so other solutions can
|
||||
be built on top of it.
|
||||
See https://www.caraus.tech/projects/pub-graphql.
|
||||
|
||||
## State of the work
|
||||
|
||||
For now this library provides:
|
||||
|
||||
- Parser for the query and schema languages, as well as a printer for the query
|
||||
language (minimizer and pretty-printer).
|
||||
- Data structures to define a type system.
|
||||
- Executor (queries, mutations and subscriptions are supported).
|
||||
- Validation is work in progress.
|
||||
- Introspection isn't available yet.
|
||||
|
||||
But the idea is to be a Haskell port of
|
||||
[`graphql-js`](https://github.com/graphql/graphql-js).
|
||||
|
||||
For a more precise list of currently missing features see
|
||||
[issues](https://www.caraus.tech/projects/pub-graphql/issues).
|
||||
|
||||
## Documentation
|
||||
Report issues on the
|
||||
[bug tracker](https://www.caraus.tech/projects/pub-graphql/issues).
|
||||
|
||||
API documentation is available through
|
||||
[Hackage](https://hackage.haskell.org/package/graphql).
|
||||
|
|
|
@ -4,10 +4,10 @@ cabal-version: 2.2
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: c89b0164372b6e02e4f338d3865dd6bb9dfd1a4475f25d808450480d73f94f91
|
||||
-- hash: 15a0880180192f918ba0bd3b3e955c57232f1efe8993745d505fcb6e1aab1451
|
||||
|
||||
name: graphql
|
||||
version: 0.11.0.0
|
||||
version: 0.11.1.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
category: Language
|
||||
|
@ -17,7 +17,7 @@ author: Danny Navarro <j@dannynavarro.net>,
|
|||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
maintainer: belka@caraus.de
|
||||
copyright: (c) 2019-2020 Eugen Wissner,
|
||||
copyright: (c) 2019-2021 Eugen Wissner,
|
||||
(c) 2015-2017 J. Daniel Navarro
|
||||
license: MPL-2.0 AND BSD-3-Clause
|
||||
license-files: LICENSE,
|
||||
|
@ -78,6 +78,7 @@ test-suite graphql-test
|
|||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Language.GraphQL.AST.DocumentSpec
|
||||
Language.GraphQL.AST.EncoderSpec
|
||||
Language.GraphQL.AST.LexerSpec
|
||||
Language.GraphQL.AST.ParserSpec
|
||||
|
@ -85,7 +86,7 @@ test-suite graphql-test
|
|||
Language.GraphQL.Execute.CoerceSpec
|
||||
Language.GraphQL.ExecuteSpec
|
||||
Language.GraphQL.Type.OutSpec
|
||||
Language.GraphQL.ValidateSpec
|
||||
Language.GraphQL.Validate.RulesSpec
|
||||
Test.DirectiveSpec
|
||||
Test.FragmentSpec
|
||||
Test.RootOperationSpec
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
name: graphql
|
||||
version: 0.11.0.0
|
||||
version: 0.11.1.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description:
|
||||
Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
|
@ -11,7 +11,7 @@ category: Language
|
|||
license: MPL-2.0 AND BSD-3-Clause
|
||||
|
||||
copyright:
|
||||
- (c) 2019-2020 Eugen Wissner
|
||||
- (c) 2019-2021 Eugen Wissner
|
||||
- (c) 2015-2017 J. Daniel Navarro
|
||||
author:
|
||||
- Danny Navarro <j@dannynavarro.net>
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
@ -47,11 +48,15 @@ module Language.GraphQL.AST.Document
|
|||
, UnionMemberTypes(..)
|
||||
, Value(..)
|
||||
, VariableDefinition(..)
|
||||
, escape
|
||||
) where
|
||||
|
||||
import Data.Char (ord)
|
||||
import Data.Foldable (toList)
|
||||
import Data.Int (Int32)
|
||||
import Data.List (intercalate)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Numeric (showFloat, showHex)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
|
||||
|
@ -79,7 +84,10 @@ instance Ord Location where
|
|||
data Node a = Node
|
||||
{ node :: a
|
||||
, location :: Location
|
||||
} deriving (Eq, Show)
|
||||
} deriving Eq
|
||||
|
||||
instance Show a => Show (Node a) where
|
||||
show Node{ node } = show node
|
||||
|
||||
instance Functor Node where
|
||||
fmap f Node{..} = Node (f node) location
|
||||
|
@ -218,6 +226,28 @@ type TypeCondition = Name
|
|||
|
||||
-- ** Input Values
|
||||
|
||||
escape :: Char -> String
|
||||
escape char'
|
||||
| char' == '\\' = "\\\\"
|
||||
| char' == '\"' = "\\\""
|
||||
| char' == '\b' = "\\b"
|
||||
| char' == '\f' = "\\f"
|
||||
| char' == '\n' = "\\n"
|
||||
| char' == '\r' = "\\r"
|
||||
| char' == '\t' = "\\t"
|
||||
| char' < '\x0010' = unicode "\\u000" char'
|
||||
| char' < '\x0020' = unicode "\\u00" char'
|
||||
| otherwise = [char']
|
||||
where
|
||||
unicode prefix uchar = prefix <> (showHex $ ord uchar) ""
|
||||
|
||||
showList' :: Show a => [a] -> String
|
||||
showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"
|
||||
|
||||
showObject :: Show a => [ObjectField a] -> String
|
||||
showObject fields =
|
||||
"{ " ++ intercalate ", " (show <$> fields) ++ " }"
|
||||
|
||||
-- | Input value (literal or variable).
|
||||
data Value
|
||||
= Variable Name
|
||||
|
@ -229,7 +259,19 @@ data Value
|
|||
| Enum Name
|
||||
| List [Value]
|
||||
| Object [ObjectField Value]
|
||||
deriving (Eq, Show)
|
||||
deriving Eq
|
||||
|
||||
instance Show Value where
|
||||
showList = mappend . showList'
|
||||
show (Variable variableName) = '$' : Text.unpack variableName
|
||||
show (Int integer) = show integer
|
||||
show (Float float) = show $ ConstFloat float
|
||||
show (String text) = show $ ConstString text
|
||||
show (Boolean boolean) = show boolean
|
||||
show Null = "null"
|
||||
show (Enum name) = Text.unpack name
|
||||
show (List list) = show list
|
||||
show (Object fields) = showObject fields
|
||||
|
||||
-- | Constant input value.
|
||||
data ConstValue
|
||||
|
@ -241,7 +283,18 @@ data ConstValue
|
|||
| ConstEnum Name
|
||||
| ConstList [ConstValue]
|
||||
| ConstObject [ObjectField ConstValue]
|
||||
deriving (Eq, Show)
|
||||
deriving Eq
|
||||
|
||||
instance Show ConstValue where
|
||||
showList = mappend . showList'
|
||||
show (ConstInt integer) = show integer
|
||||
show (ConstFloat float) = showFloat float mempty
|
||||
show (ConstString text) = "\"" <> Text.foldr (mappend . escape) "\"" text
|
||||
show (ConstBoolean boolean) = show boolean
|
||||
show ConstNull = "null"
|
||||
show (ConstEnum name) = Text.unpack name
|
||||
show (ConstList list) = show list
|
||||
show (ConstObject fields) = showObject fields
|
||||
|
||||
-- | Key-value pair.
|
||||
--
|
||||
|
@ -250,7 +303,13 @@ data ObjectField a = ObjectField
|
|||
{ name :: Name
|
||||
, value :: Node a
|
||||
, location :: Location
|
||||
} deriving (Eq, Show)
|
||||
} deriving Eq
|
||||
|
||||
instance Show a => Show (ObjectField a) where
|
||||
show ObjectField{..} = Text.unpack name ++ ": " ++ show value
|
||||
|
||||
instance Functor ObjectField where
|
||||
fmap f ObjectField{..} = ObjectField name (f <$> value) location
|
||||
|
||||
-- ** Variables
|
||||
|
||||
|
@ -281,7 +340,12 @@ data Type
|
|||
= TypeNamed Name
|
||||
| TypeList Type
|
||||
| TypeNonNull NonNullType
|
||||
deriving (Eq, Show)
|
||||
deriving Eq
|
||||
|
||||
instance Show Type where
|
||||
show (TypeNamed typeName) = Text.unpack typeName
|
||||
show (TypeList listType) = concat ["[", show listType, "]"]
|
||||
show (TypeNonNull nonNullType) = show nonNullType
|
||||
|
||||
-- | Represents type names.
|
||||
type NamedType = Name
|
||||
|
@ -290,7 +354,11 @@ type NamedType = Name
|
|||
data NonNullType
|
||||
= NonNullTypeNamed Name
|
||||
| NonNullTypeList Type
|
||||
deriving (Eq, Show)
|
||||
deriving Eq
|
||||
|
||||
instance Show NonNullType where
|
||||
show (NonNullTypeNamed typeName) = '!' : Text.unpack typeName
|
||||
show (NonNullTypeList listType) = concat ["![", show listType, "]"]
|
||||
|
||||
-- ** Directives
|
||||
|
||||
|
|
|
@ -16,7 +16,6 @@ module Language.GraphQL.AST.Encoder
|
|||
, value
|
||||
) where
|
||||
|
||||
import Data.Char (ord)
|
||||
import Data.Foldable (fold)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Text (Text)
|
||||
|
@ -25,7 +24,7 @@ import qualified Data.Text.Lazy as Lazy (Text)
|
|||
import qualified Data.Text.Lazy as Lazy.Text
|
||||
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.Int (decimal)
|
||||
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
|
||||
|
@ -234,11 +233,12 @@ quote :: Builder.Builder
|
|||
quote = Builder.singleton '\"'
|
||||
|
||||
oneLine :: Text -> Builder
|
||||
oneLine string = quote <> Text.foldr (mappend . escape) quote string
|
||||
oneLine string = quote <> Text.foldr merge quote string
|
||||
where
|
||||
merge = mappend . Builder.fromString . Full.escape
|
||||
|
||||
stringValue :: Formatter -> Text -> Lazy.Text
|
||||
stringValue Minified string = Builder.toLazyText
|
||||
$ quote <> Text.foldr (mappend . escape) quote string
|
||||
stringValue Minified string = Builder.toLazyText $ oneLine string
|
||||
stringValue (Pretty indentation) string =
|
||||
if hasEscaped string
|
||||
then stringValue Minified string
|
||||
|
@ -266,21 +266,6 @@ stringValue (Pretty indentation) string =
|
|||
= Builder.fromLazyText (indent (indentation + 1))
|
||||
<> line' <> newline <> acc
|
||||
|
||||
escape :: Char -> Builder
|
||||
escape char'
|
||||
| char' == '\\' = Builder.fromString "\\\\"
|
||||
| char' == '\"' = Builder.fromString "\\\""
|
||||
| char' == '\b' = Builder.fromString "\\b"
|
||||
| char' == '\f' = Builder.fromString "\\f"
|
||||
| char' == '\n' = Builder.fromString "\\n"
|
||||
| char' == '\r' = Builder.fromString "\\r"
|
||||
| char' == '\t' = Builder.fromString "\\t"
|
||||
| char' < '\x0010' = unicode "\\u000" char'
|
||||
| char' < '\x0020' = unicode "\\u00" char'
|
||||
| otherwise = Builder.singleton char'
|
||||
where
|
||||
unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
|
||||
|
||||
listValue :: Formatter -> [Full.Value] -> Lazy.Text
|
||||
listValue formatter = bracketsCommas formatter $ value formatter
|
||||
|
||||
|
|
|
@ -22,6 +22,7 @@ import Data.HashMap.Strict (HashMap)
|
|||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.String (IsString(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Prelude hiding (id)
|
||||
|
||||
|
@ -63,6 +64,9 @@ data ScalarType = ScalarType Name (Maybe Text)
|
|||
instance Eq ScalarType where
|
||||
(ScalarType this _) == (ScalarType that _) = this == that
|
||||
|
||||
instance Show ScalarType where
|
||||
show (ScalarType typeName _) = Text.unpack typeName
|
||||
|
||||
-- | Enum type definition.
|
||||
--
|
||||
-- Some leaf values of requests and input values are Enums. GraphQL serializes
|
||||
|
@ -73,6 +77,9 @@ data EnumType = EnumType Name (Maybe Text) (HashMap Name EnumValue)
|
|||
instance Eq EnumType where
|
||||
(EnumType this _ _) == (EnumType that _ _) = this == that
|
||||
|
||||
instance Show EnumType where
|
||||
show (EnumType typeName _ _) = Text.unpack typeName
|
||||
|
||||
-- | Enum value is a single member of an 'EnumType'.
|
||||
newtype EnumValue = EnumValue (Maybe Text)
|
||||
|
||||
|
|
|
@ -24,6 +24,7 @@ module Language.GraphQL.Type.In
|
|||
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.Document (Name)
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
|
||||
|
@ -40,6 +41,9 @@ data InputObjectType = InputObjectType
|
|||
instance Eq InputObjectType where
|
||||
(InputObjectType this _ _) == (InputObjectType that _ _) = this == that
|
||||
|
||||
instance Show InputObjectType where
|
||||
show (InputObjectType typeName _ _) = Text.unpack typeName
|
||||
|
||||
-- | These types may be used as input types for arguments and directives.
|
||||
--
|
||||
-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
|
||||
|
@ -56,6 +60,16 @@ data Type
|
|||
| NonNullListType Type
|
||||
deriving Eq
|
||||
|
||||
instance Show Type where
|
||||
show (NamedScalarType scalarType) = show scalarType
|
||||
show (NamedEnumType enumType) = show enumType
|
||||
show (NamedInputObjectType inputObjectType) = show inputObjectType
|
||||
show (ListType baseType) = concat ["[", show baseType, "]"]
|
||||
show (NonNullScalarType scalarType) = '!' : show scalarType
|
||||
show (NonNullEnumType enumType) = '!' : show enumType
|
||||
show (NonNullInputObjectType inputObjectType) = '!' : show inputObjectType
|
||||
show (NonNullListType baseType) = concat ["![", show baseType, "]"]
|
||||
|
||||
-- | Field argument definition.
|
||||
data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
|
||||
|
||||
|
|
|
@ -14,11 +14,14 @@ module Language.GraphQL.Type.Internal
|
|||
, Type(..)
|
||||
, directives
|
||||
, doesFragmentTypeApply
|
||||
, implementations
|
||||
, instanceOf
|
||||
, lookupCompositeField
|
||||
, lookupInputType
|
||||
, lookupTypeCondition
|
||||
, lookupTypeField
|
||||
, mutation
|
||||
, outToComposite
|
||||
, subscription
|
||||
, query
|
||||
, types
|
||||
|
@ -62,26 +65,31 @@ data Schema m = Schema
|
|||
(Maybe (Out.ObjectType m))
|
||||
Directives
|
||||
(HashMap Full.Name (Type m))
|
||||
(HashMap Full.Name [Type m])
|
||||
|
||||
-- | Schema query type.
|
||||
query :: forall m. Schema m -> Out.ObjectType m
|
||||
query (Schema query' _ _ _ _) = query'
|
||||
query (Schema query' _ _ _ _ _) = query'
|
||||
|
||||
-- | Schema mutation type.
|
||||
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||
mutation (Schema _ mutation' _ _ _) = mutation'
|
||||
mutation (Schema _ mutation' _ _ _ _) = mutation'
|
||||
|
||||
-- | Schema subscription type.
|
||||
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||
subscription (Schema _ _ subscription' _ _) = subscription'
|
||||
subscription (Schema _ _ subscription' _ _ _) = subscription'
|
||||
|
||||
-- | Schema directive definitions.
|
||||
directives :: forall m. Schema m -> Directives
|
||||
directives (Schema _ _ _ directives' _) = directives'
|
||||
directives (Schema _ _ _ directives' _ _) = directives'
|
||||
|
||||
-- | Types referenced by the schema.
|
||||
types :: forall m. Schema m -> HashMap Full.Name (Type m)
|
||||
types (Schema _ _ _ _ types') = types'
|
||||
types (Schema _ _ _ _ types' _) = types'
|
||||
|
||||
-- | Interface implementations.
|
||||
implementations :: forall m. Schema m -> HashMap Full.Name [Type m]
|
||||
implementations (Schema _ _ _ _ _ implementations') = implementations'
|
||||
|
||||
-- | These types may describe the parent context of a selection set.
|
||||
data CompositeType m
|
||||
|
@ -160,12 +168,16 @@ lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types'
|
|||
<$> 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
|
||||
lookupTypeField fieldName outputType =
|
||||
outToComposite outputType >>= lookupCompositeField fieldName
|
||||
|
||||
lookupCompositeField :: forall a
|
||||
. Full.Name
|
||||
-> CompositeType a
|
||||
-> Maybe (Out.Field a)
|
||||
lookupCompositeField fieldName = \case
|
||||
CompositeObjectType objectType -> objectChild objectType
|
||||
CompositeInterfaceType interfaceType -> interfaceChild interfaceType
|
||||
_ -> Nothing
|
||||
where
|
||||
objectChild (Out.ObjectType _ _ _ resolvers) =
|
||||
|
@ -174,3 +186,12 @@ lookupTypeField fieldName = \case
|
|||
HashMap.lookup fieldName fields
|
||||
resolverType (Out.ValueResolver objectField _) = objectField
|
||||
resolverType (Out.EventStreamResolver objectField _ _) = objectField
|
||||
|
||||
outToComposite :: forall a. Out.Type a -> Maybe (CompositeType a)
|
||||
outToComposite = \case
|
||||
Out.ObjectBaseType objectType -> Just $ CompositeObjectType objectType
|
||||
Out.InterfaceBaseType interfaceType ->
|
||||
Just $ CompositeInterfaceType interfaceType
|
||||
Out.UnionBaseType unionType -> Just $ CompositeUnionType unionType
|
||||
Out.ListBaseType listType -> outToComposite listType
|
||||
_ -> Nothing
|
||||
|
|
|
@ -38,6 +38,7 @@ import Data.HashMap.Strict (HashMap)
|
|||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.Type.Definition
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
|
@ -52,6 +53,9 @@ data ObjectType m = ObjectType
|
|||
instance forall a. Eq (ObjectType a) where
|
||||
(ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
|
||||
|
||||
instance forall a. Show (ObjectType a) where
|
||||
show (ObjectType typeName _ _ _) = Text.unpack typeName
|
||||
|
||||
-- | Interface Type Definition.
|
||||
--
|
||||
-- When a field can return one of a heterogeneous set of types, a Interface type
|
||||
|
@ -63,6 +67,9 @@ data InterfaceType m = InterfaceType
|
|||
instance forall a. Eq (InterfaceType a) where
|
||||
(InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that
|
||||
|
||||
instance forall a. Show (InterfaceType a) where
|
||||
show (InterfaceType typeName _ _ _) = Text.unpack typeName
|
||||
|
||||
-- | Union Type Definition.
|
||||
--
|
||||
-- When a field can return one of a heterogeneous set of types, a Union type is
|
||||
|
@ -72,6 +79,9 @@ data UnionType m = UnionType Name (Maybe Text) [ObjectType m]
|
|||
instance forall a. Eq (UnionType a) where
|
||||
(UnionType this _ _) == (UnionType that _ _) = this == that
|
||||
|
||||
instance forall a. Show (UnionType a) where
|
||||
show (UnionType typeName _ _) = Text.unpack typeName
|
||||
|
||||
-- | Output object field definition.
|
||||
data Field m = Field
|
||||
(Maybe Text) -- ^ Description.
|
||||
|
@ -98,6 +108,20 @@ data Type m
|
|||
| NonNullListType (Type m)
|
||||
deriving Eq
|
||||
|
||||
instance forall a. Show (Type a) where
|
||||
show (NamedScalarType scalarType) = show scalarType
|
||||
show (NamedEnumType enumType) = show enumType
|
||||
show (NamedObjectType inputObjectType) = show inputObjectType
|
||||
show (NamedInterfaceType interfaceType) = show interfaceType
|
||||
show (NamedUnionType unionType) = show unionType
|
||||
show (ListType baseType) = concat ["[", show baseType, "]"]
|
||||
show (NonNullScalarType scalarType) = '!' : show scalarType
|
||||
show (NonNullEnumType enumType) = '!' : show enumType
|
||||
show (NonNullObjectType inputObjectType) = '!' : show inputObjectType
|
||||
show (NonNullInterfaceType interfaceType) = '!' : show interfaceType
|
||||
show (NonNullUnionType unionType) = '!' : show unionType
|
||||
show (NonNullListType baseType) = concat ["![", show baseType, "]"]
|
||||
|
||||
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
|
||||
pattern ScalarBaseType :: forall m. ScalarType -> Type m
|
||||
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
|
||||
|
|
|
@ -23,6 +23,7 @@ import Language.GraphQL.Type.Internal
|
|||
, Schema
|
||||
, Type(..)
|
||||
, directives
|
||||
, implementations
|
||||
, mutation
|
||||
, subscription
|
||||
, query
|
||||
|
@ -41,9 +42,11 @@ schema :: forall m
|
|||
-> Directives -- ^ Directive definitions.
|
||||
-> Schema m -- ^ Schema.
|
||||
schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
|
||||
Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes
|
||||
Internal.Schema queryRoot mutationRoot subscriptionRoot
|
||||
allDirectives collectedTypes collectedImplementations
|
||||
where
|
||||
collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot
|
||||
collectedImplementations = collectImplementations collectedTypes
|
||||
allDirectives = HashMap.union directiveDefinitions defaultDirectives
|
||||
defaultDirectives = HashMap.fromList
|
||||
[ ("skip", skipDirective)
|
||||
|
@ -153,3 +156,20 @@ collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
|
|||
polymorphicTraverser interfaces fields
|
||||
= flip (foldr visitFields) fields
|
||||
. flip (foldr traverseInterfaceType) interfaces
|
||||
|
||||
-- | Looks for objects and interfaces under the schema types and collects the
|
||||
-- interfaces they implement.
|
||||
collectImplementations :: forall m
|
||||
. HashMap Full.Name (Type m)
|
||||
-> HashMap Full.Name [Type m]
|
||||
collectImplementations = HashMap.foldr go HashMap.empty
|
||||
where
|
||||
go implementation@(InterfaceType interfaceType) accumulator =
|
||||
let Out.InterfaceType _ _ interfaces _ = interfaceType
|
||||
in foldr (add implementation) accumulator interfaces
|
||||
go implementation@(ObjectType objectType) accumulator =
|
||||
let Out.ObjectType _ _ interfaces _ = objectType
|
||||
in foldr (add implementation) accumulator interfaces
|
||||
go _ accumulator = accumulator
|
||||
add implementation (Out.InterfaceType typeName _ _ _) accumulator =
|
||||
HashMap.insertWith (++) typeName [implementation] accumulator
|
||||
|
|
|
@ -210,7 +210,7 @@ typeDefinition context rule = \case
|
|||
directives context rule scalarLocation directives'
|
||||
Full.ObjectTypeDefinition _ _ _ directives' fields
|
||||
-> directives context rule objectLocation directives'
|
||||
>< foldMap (fieldDefinition context rule) fields
|
||||
>< foldMap (fieldDefinition context rule) fields
|
||||
Full.InterfaceTypeDefinition _ _ directives' fields
|
||||
-> directives context rule interfaceLocation directives'
|
||||
>< foldMap (fieldDefinition context rule) fields
|
||||
|
|
|
@ -3,6 +3,7 @@
|
|||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
@ -24,6 +25,8 @@ module Language.GraphQL.Validate.Rules
|
|||
, noUndefinedVariablesRule
|
||||
, noUnusedFragmentsRule
|
||||
, noUnusedVariablesRule
|
||||
, overlappingFieldsCanBeMergedRule
|
||||
, possibleFragmentSpreadsRule
|
||||
, providedRequiredInputFieldsRule
|
||||
, providedRequiredArgumentsRule
|
||||
, scalarLeafsRule
|
||||
|
@ -35,22 +38,24 @@ module Language.GraphQL.Validate.Rules
|
|||
, uniqueInputFieldNamesRule
|
||||
, uniqueOperationNamesRule
|
||||
, uniqueVariableNamesRule
|
||||
, valuesOfCorrectTypeRule
|
||||
, variablesInAllowedPositionRule
|
||||
, variablesAreInputTypesRule
|
||||
) where
|
||||
|
||||
import Control.Monad ((>=>), foldM)
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT)
|
||||
import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT)
|
||||
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Foldable (find, toList)
|
||||
import Data.Foldable (find, fold, foldl', 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.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Ord (comparing)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
|
@ -80,6 +85,7 @@ specifiedRules =
|
|||
-- Fields
|
||||
, fieldsOnCorrectTypeRule
|
||||
, scalarLeafsRule
|
||||
, overlappingFieldsCanBeMergedRule
|
||||
-- Arguments.
|
||||
, knownArgumentNamesRule
|
||||
, uniqueArgumentNamesRule
|
||||
|
@ -91,7 +97,9 @@ specifiedRules =
|
|||
, noUnusedFragmentsRule
|
||||
, fragmentSpreadTargetDefinedRule
|
||||
, noFragmentCyclesRule
|
||||
, possibleFragmentSpreadsRule
|
||||
-- Values
|
||||
, valuesOfCorrectTypeRule
|
||||
, knownInputFieldNamesRule
|
||||
, uniqueInputFieldNamesRule
|
||||
, providedRequiredInputFieldsRule
|
||||
|
@ -104,6 +112,7 @@ specifiedRules =
|
|||
, variablesAreInputTypesRule
|
||||
, noUndefinedVariablesRule
|
||||
, noUnusedVariablesRule
|
||||
, variablesInAllowedPositionRule
|
||||
]
|
||||
|
||||
-- | Definition must be OperationDefinition or FragmentDefinition.
|
||||
|
@ -320,10 +329,8 @@ 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
|
||||
typeCondition <- findSpreadTarget fragmentName
|
||||
case HashMap.lookup typeCondition types' of
|
||||
Nothing -> pure $ Error
|
||||
{ message = spreadError fragmentName typeCondition
|
||||
|
@ -342,10 +349,6 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
|
|||
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
|
||||
|
@ -451,8 +454,7 @@ filterSelections applyFilter selections
|
|||
noFragmentCyclesRule :: forall m. Rule m
|
||||
noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
||||
Full.FragmentDefinition fragmentName _ _ selections location' -> do
|
||||
state <- evalStateT (collectFields selections)
|
||||
(0, fragmentName)
|
||||
state <- evalStateT (collectCycles selections) (0, fragmentName)
|
||||
let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)
|
||||
case reverse spreadPath of
|
||||
x : _ | x == fragmentName -> pure $ Error
|
||||
|
@ -467,10 +469,10 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
|||
}
|
||||
_ -> lift mempty
|
||||
where
|
||||
collectFields :: Traversable t
|
||||
collectCycles :: Traversable t
|
||||
=> t Full.Selection
|
||||
-> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
|
||||
collectFields selectionSet = foldM forEach HashMap.empty selectionSet
|
||||
collectCycles selectionSet = foldM forEach HashMap.empty selectionSet
|
||||
forEach accumulator = \case
|
||||
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
|
||||
Full.InlineFragmentSelection fragmentSelection ->
|
||||
|
@ -487,15 +489,15 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
|||
then pure newAccumulator
|
||||
else collectFromSpread fragmentName newAccumulator
|
||||
forInline accumulator (Full.InlineFragment _ _ selections _) =
|
||||
(accumulator <>) <$> collectFields selections
|
||||
(accumulator <>) <$> collectCycles selections
|
||||
forField accumulator (Full.Field _ _ _ _ selections _) =
|
||||
(accumulator <>) <$> collectFields selections
|
||||
(accumulator <>) <$> collectCycles selections
|
||||
collectFromSpread fragmentName accumulator = do
|
||||
ast' <- lift $ asks ast
|
||||
case findFragmentDefinition fragmentName ast' of
|
||||
Nothing -> pure accumulator
|
||||
Just (Full.FragmentDefinition _ _ _ selections _) ->
|
||||
(accumulator <>) <$> collectFields selections
|
||||
(accumulator <>) <$> collectCycles selections
|
||||
|
||||
findFragmentDefinition :: Text
|
||||
-> NonEmpty Full.Definition
|
||||
|
@ -531,15 +533,22 @@ uniqueDirectiveNamesRule = DirectivesRule
|
|||
extract (Full.Directive directiveName _ location') =
|
||||
(directiveName, location')
|
||||
|
||||
filterDuplicates :: (a -> (Text, Full.Location)) -> String -> [a] -> Seq Error
|
||||
groupSorted :: forall a. (a -> Text) -> [a] -> [[a]]
|
||||
groupSorted getName = groupBy equalByName . sortOn getName
|
||||
where
|
||||
equalByName lhs rhs = getName lhs == getName rhs
|
||||
|
||||
filterDuplicates :: forall a
|
||||
. (a -> (Text, Full.Location))
|
||||
-> String
|
||||
-> [a]
|
||||
-> Seq Error
|
||||
filterDuplicates extract nodeType = Seq.fromList
|
||||
. fmap makeError
|
||||
. filter ((> 1) . length)
|
||||
. groupBy equalByName
|
||||
. sortOn getName
|
||||
. groupSorted getName
|
||||
where
|
||||
getName = fst . extract
|
||||
equalByName lhs rhs = getName lhs == getName rhs
|
||||
makeError directives' = Error
|
||||
{ message = makeMessage $ head directives'
|
||||
, locations = snd . extract <$> directives'
|
||||
|
@ -647,12 +656,9 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
|
|||
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
|
||||
nonVisitedFragmentDefinition <- visitFragmentDefinition fragmentName
|
||||
case nonVisitedFragmentDefinition of
|
||||
Just fragmentDefinition -> diveIntoSpread fragmentDefinition
|
||||
_ -> lift $ lift mempty
|
||||
diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _)
|
||||
= filterSelections' selections
|
||||
|
@ -710,7 +716,7 @@ fieldsOnCorrectTypeRule = FieldRule fieldRule
|
|||
fieldRule parentType (Full.Field _ fieldName _ _ _ location')
|
||||
| Just objectType <- parentType
|
||||
, Nothing <- Type.lookupTypeField fieldName objectType
|
||||
, Just typeName <- compositeTypeName objectType = pure $ Error
|
||||
, Just typeName <- typeNameIfComposite objectType = pure $ Error
|
||||
{ message = errorMessage fieldName typeName
|
||||
, locations = [location']
|
||||
}
|
||||
|
@ -723,20 +729,17 @@ fieldsOnCorrectTypeRule = FieldRule fieldRule
|
|||
, "\"."
|
||||
]
|
||||
|
||||
compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name
|
||||
compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
|
||||
Just typeName
|
||||
compositeTypeName (Out.InterfaceBaseType interfaceType) =
|
||||
compositeTypeName :: forall m. Type.CompositeType m -> Full.Name
|
||||
compositeTypeName (Type.CompositeObjectType (Out.ObjectType typeName _ _ _)) =
|
||||
typeName
|
||||
compositeTypeName (Type.CompositeInterfaceType 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
|
||||
in typeName
|
||||
compositeTypeName (Type.CompositeUnionType (Out.UnionType typeName _ _)) =
|
||||
typeName
|
||||
|
||||
typeNameIfComposite :: forall m. Out.Type m -> Maybe Full.Name
|
||||
typeNameIfComposite = fmap compositeTypeName . Type.outToComposite
|
||||
|
||||
-- | Field selections on scalars or enums are never allowed, because they are
|
||||
-- the leaf nodes of any GraphQL query.
|
||||
|
@ -794,7 +797,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
|||
where
|
||||
fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ _)
|
||||
| Just typeField <- Type.lookupTypeField fieldName objectType
|
||||
, Just typeName <- compositeTypeName objectType =
|
||||
, Just typeName <- typeNameIfComposite objectType =
|
||||
lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
|
||||
fieldRule _ _ = lift mempty
|
||||
go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors
|
||||
|
@ -1013,3 +1016,590 @@ providedRequiredInputFieldsRule = ValueRule go constGo
|
|||
, Text.unpack typeName
|
||||
, "\" is required, but it was not provided."
|
||||
]
|
||||
|
||||
-- | If multiple field selections with the same response names are encountered
|
||||
-- during execution, the field and arguments to execute and the resulting value
|
||||
-- should be unambiguous. Therefore any two field selections which might both be
|
||||
-- encountered for the same object are only valid if they are equivalent.
|
||||
--
|
||||
-- For simple hand‐written GraphQL, this rule is obviously a clear developer
|
||||
-- error, however nested fragments can make this difficult to detect manually.
|
||||
overlappingFieldsCanBeMergedRule :: Rule m
|
||||
overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case
|
||||
Full.SelectionSet selectionSet _ -> do
|
||||
schema' <- asks schema
|
||||
go (toList selectionSet)
|
||||
$ Type.CompositeObjectType
|
||||
$ Schema.query schema'
|
||||
Full.OperationDefinition operationType _ _ _ selectionSet _ -> do
|
||||
schema' <- asks schema
|
||||
let root = go (toList selectionSet) . Type.CompositeObjectType
|
||||
case operationType of
|
||||
Full.Query -> root $ Schema.query schema'
|
||||
Full.Mutation
|
||||
| Just objectType <- Schema.mutation schema' -> root objectType
|
||||
Full.Subscription
|
||||
| Just objectType <- Schema.mutation schema' -> root objectType
|
||||
_ -> lift mempty
|
||||
where
|
||||
go selectionSet selectionType = do
|
||||
fieldTuples <- evalStateT (collectFields selectionType selectionSet) HashSet.empty
|
||||
fieldsInSetCanMerge fieldTuples
|
||||
fieldsInSetCanMerge :: forall m
|
||||
. HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))
|
||||
-> ReaderT (Validation m) Seq Error
|
||||
fieldsInSetCanMerge fieldTuples = do
|
||||
validation <- ask
|
||||
let (lonely, paired) = flattenPairs fieldTuples
|
||||
let reader = flip runReaderT validation
|
||||
lift $ foldMap (reader . visitLonelyFields) lonely
|
||||
<> foldMap (reader . forEachFieldTuple) paired
|
||||
forEachFieldTuple :: forall m
|
||||
. (FieldInfo m, FieldInfo m)
|
||||
-> ReaderT (Validation m) Seq Error
|
||||
forEachFieldTuple (fieldA, fieldB) =
|
||||
case (parent fieldA, parent fieldB) of
|
||||
(parentA@Type.CompositeObjectType{}, parentB@Type.CompositeObjectType{})
|
||||
| parentA /= parentB -> sameResponseShape fieldA fieldB
|
||||
_ -> mapReaderT (checkEquality (node fieldA) (node fieldB))
|
||||
$ sameResponseShape fieldA fieldB
|
||||
checkEquality fieldA fieldB Seq.Empty
|
||||
| Full.Field _ fieldNameA _ _ _ _ <- fieldA
|
||||
, Full.Field _ fieldNameB _ _ _ _ <- fieldB
|
||||
, fieldNameA /= fieldNameB = pure $ makeError fieldA fieldB
|
||||
| Full.Field _ fieldNameA argumentsA _ _ locationA <- fieldA
|
||||
, Full.Field _ _ argumentsB _ _ locationB <- fieldB
|
||||
, argumentsA /= argumentsB =
|
||||
let message = concat
|
||||
[ "Fields \""
|
||||
, Text.unpack fieldNameA
|
||||
, "\" conflict because they have different arguments. Use "
|
||||
, "different aliases on the fields to fetch both if this "
|
||||
, "was intentional."
|
||||
]
|
||||
in pure $ Error message [locationB, locationA]
|
||||
checkEquality _ _ previousErrors = previousErrors
|
||||
visitLonelyFields FieldInfo{..} =
|
||||
let Full.Field _ _ _ _ subSelections _ = node
|
||||
compositeFieldType = Type.outToComposite type'
|
||||
in maybe (lift Seq.empty) (go subSelections) compositeFieldType
|
||||
sameResponseShape :: forall m
|
||||
. FieldInfo m
|
||||
-> FieldInfo m
|
||||
-> ReaderT (Validation m) Seq Error
|
||||
sameResponseShape fieldA fieldB =
|
||||
let Full.Field _ _ _ _ selectionsA _ = node fieldA
|
||||
Full.Field _ _ _ _ selectionsB _ = node fieldB
|
||||
in case unwrapTypes (type' fieldA) (type' fieldB) of
|
||||
Left True -> lift mempty
|
||||
Right (compositeA, compositeB) -> do
|
||||
validation <- ask
|
||||
let collectFields' composite = flip runReaderT validation
|
||||
. flip evalStateT HashSet.empty
|
||||
. collectFields composite
|
||||
let collectA = collectFields' compositeA selectionsA
|
||||
let collectB = collectFields' compositeB selectionsB
|
||||
fieldsInSetCanMerge
|
||||
$ foldl' (HashMap.unionWith (<>)) HashMap.empty
|
||||
$ collectA <> collectB
|
||||
_ -> pure $ makeError (node fieldA) (node fieldB)
|
||||
makeError fieldA fieldB =
|
||||
let Full.Field aliasA fieldNameA _ _ _ locationA = fieldA
|
||||
Full.Field _ fieldNameB _ _ _ locationB = fieldB
|
||||
message = concat
|
||||
[ "Fields \""
|
||||
, Text.unpack (fromMaybe fieldNameA aliasA)
|
||||
, "\" conflict because \""
|
||||
, Text.unpack fieldNameB
|
||||
, "\" and \""
|
||||
, Text.unpack fieldNameA
|
||||
, "\" are different fields. Use different aliases on the fields "
|
||||
, "to fetch both if this was intentional."
|
||||
]
|
||||
in Error message [locationB, locationA]
|
||||
unwrapTypes typeA@Out.ScalarBaseType{} typeB@Out.ScalarBaseType{} =
|
||||
Left $ typeA == typeB
|
||||
unwrapTypes typeA@Out.EnumBaseType{} typeB@Out.EnumBaseType{} =
|
||||
Left $ typeA == typeB
|
||||
unwrapTypes (Out.ListType listA) (Out.ListType listB) =
|
||||
unwrapTypes listA listB
|
||||
unwrapTypes (Out.NonNullListType listA) (Out.NonNullListType listB) =
|
||||
unwrapTypes listA listB
|
||||
unwrapTypes typeA typeB
|
||||
| Out.isNonNullType typeA == Out.isNonNullType typeB
|
||||
, Just compositeA <- Type.outToComposite typeA
|
||||
, Just compositeB <- Type.outToComposite typeB =
|
||||
Right (compositeA, compositeB)
|
||||
| otherwise = Left False
|
||||
flattenPairs :: forall m
|
||||
. HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))
|
||||
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
|
||||
flattenPairs xs = HashMap.foldr splitSingleFields (Seq.empty, Seq.empty)
|
||||
$ foldr lookupTypeField [] <$> xs
|
||||
splitSingleFields :: forall m
|
||||
. [FieldInfo m]
|
||||
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
|
||||
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
|
||||
splitSingleFields [head'] (fields, pairList) = (fields |> head', pairList)
|
||||
splitSingleFields xs (fields, pairList) = (fields, pairs pairList xs)
|
||||
lookupTypeField (field, parentType) accumulator =
|
||||
let Full.Field _ fieldName _ _ _ _ = field
|
||||
in case Type.lookupCompositeField fieldName parentType of
|
||||
Nothing -> accumulator
|
||||
Just (Out.Field _ typeField _) ->
|
||||
FieldInfo field typeField parentType : accumulator
|
||||
pairs :: forall m
|
||||
. Seq (FieldInfo m, FieldInfo m)
|
||||
-> [FieldInfo m]
|
||||
-> Seq (FieldInfo m, FieldInfo m)
|
||||
pairs accumulator [] = accumulator
|
||||
pairs accumulator (fieldA : fields) =
|
||||
pair fieldA (pairs accumulator fields) fields
|
||||
pair _ accumulator [] = accumulator
|
||||
pair field accumulator (fieldA : fields) =
|
||||
pair field accumulator fields |> (field, fieldA)
|
||||
collectFields objectType = accumulateFields objectType mempty
|
||||
accumulateFields = foldM . forEach
|
||||
forEach parentType accumulator = \case
|
||||
Full.FieldSelection fieldSelection ->
|
||||
forField parentType accumulator fieldSelection
|
||||
Full.FragmentSpreadSelection fragmentSelection ->
|
||||
forSpread accumulator fragmentSelection
|
||||
Full.InlineFragmentSelection fragmentSelection ->
|
||||
forInline parentType accumulator fragmentSelection
|
||||
forField parentType accumulator field@(Full.Field alias fieldName _ _ _ _) =
|
||||
let key = fromMaybe fieldName alias
|
||||
value = (field, parentType) :| []
|
||||
in pure $ HashMap.insertWith (<>) key value accumulator
|
||||
forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do
|
||||
inVisitetFragments <- gets $ HashSet.member fragmentName
|
||||
if inVisitetFragments
|
||||
then pure accumulator
|
||||
else collectFromSpread fragmentName accumulator
|
||||
forInline parentType accumulator = \case
|
||||
Full.InlineFragment maybeType _ selections _
|
||||
| Just typeCondition <- maybeType ->
|
||||
collectFromFragment typeCondition selections accumulator
|
||||
| otherwise -> accumulateFields parentType accumulator $ toList selections
|
||||
collectFromFragment typeCondition selectionSet' accumulator = do
|
||||
types' <- lift $ asks $ Schema.types . schema
|
||||
case Type.lookupTypeCondition typeCondition types' of
|
||||
Nothing -> pure accumulator
|
||||
Just compositeType ->
|
||||
accumulateFields compositeType accumulator $ toList selectionSet'
|
||||
collectFromSpread fragmentName accumulator = do
|
||||
modify $ HashSet.insert fragmentName
|
||||
ast' <- lift $ asks ast
|
||||
case findFragmentDefinition fragmentName ast' of
|
||||
Nothing -> pure accumulator
|
||||
Just (Full.FragmentDefinition _ typeCondition _ selectionSet' _) ->
|
||||
collectFromFragment typeCondition selectionSet' accumulator
|
||||
|
||||
data FieldInfo m = FieldInfo
|
||||
{ node :: Full.Field
|
||||
, type' :: Out.Type m
|
||||
, parent :: Type.CompositeType m
|
||||
}
|
||||
|
||||
-- | Fragments are declared on a type and will only apply when the runtime
|
||||
-- object type matches the type condition. They also are spread within the
|
||||
-- context of a parent type. A fragment spread is only valid if its type
|
||||
-- condition could ever apply within the parent type.
|
||||
possibleFragmentSpreadsRule :: forall m. Rule m
|
||||
possibleFragmentSpreadsRule = SelectionRule go
|
||||
where
|
||||
go (Just parentType) (Full.InlineFragmentSelection fragmentSelection)
|
||||
| Full.InlineFragment maybeType _ _ location' <- fragmentSelection
|
||||
, Just typeCondition <- maybeType = do
|
||||
(fragmentTypeName, parentTypeName) <-
|
||||
compareTypes typeCondition parentType
|
||||
pure $ Error
|
||||
{ message = concat
|
||||
[ "Fragment cannot be spread here as objects of type \""
|
||||
, Text.unpack parentTypeName
|
||||
, "\" can never be of type \""
|
||||
, Text.unpack fragmentTypeName
|
||||
, "\"."
|
||||
]
|
||||
, locations = [location']
|
||||
}
|
||||
go (Just parentType) (Full.FragmentSpreadSelection fragmentSelection)
|
||||
| Full.FragmentSpread fragmentName _ location' <- fragmentSelection = do
|
||||
typeCondition <- findSpreadTarget fragmentName
|
||||
(fragmentTypeName, parentTypeName) <-
|
||||
compareTypes typeCondition parentType
|
||||
pure $ Error
|
||||
{ message = concat
|
||||
[ "Fragment \""
|
||||
, Text.unpack fragmentName
|
||||
, "\" cannot be spread here as objects of type \""
|
||||
, Text.unpack parentTypeName
|
||||
, "\" can never be of type \""
|
||||
, Text.unpack fragmentTypeName
|
||||
, "\"."
|
||||
]
|
||||
, locations = [location']
|
||||
}
|
||||
go _ _ = lift mempty
|
||||
compareTypes typeCondition parentType = do
|
||||
types' <- asks $ Schema.types . schema
|
||||
fragmentType <- lift
|
||||
$ maybeToSeq
|
||||
$ Type.lookupTypeCondition typeCondition types'
|
||||
parentComposite <- lift
|
||||
$ maybeToSeq
|
||||
$ Type.outToComposite parentType
|
||||
possibleFragments <- getPossibleTypes fragmentType
|
||||
possibleParents <- getPossibleTypes parentComposite
|
||||
let fragmentTypeName = compositeTypeName fragmentType
|
||||
let parentTypeName = compositeTypeName parentComposite
|
||||
if HashSet.null $ HashSet.intersection possibleFragments possibleParents
|
||||
then pure (fragmentTypeName, parentTypeName)
|
||||
else lift mempty
|
||||
getPossibleTypeList (Type.CompositeObjectType objectType) =
|
||||
pure [Schema.ObjectType objectType]
|
||||
getPossibleTypeList (Type.CompositeUnionType unionType) =
|
||||
let Out.UnionType _ _ members = unionType
|
||||
in pure $ Schema.ObjectType <$> members
|
||||
getPossibleTypeList (Type.CompositeInterfaceType interfaceType) =
|
||||
let Out.InterfaceType typeName _ _ _ = interfaceType
|
||||
in HashMap.lookupDefault [] typeName
|
||||
<$> asks (Schema.implementations . schema)
|
||||
getPossibleTypes compositeType
|
||||
= foldr (HashSet.insert . internalTypeName) HashSet.empty
|
||||
<$> getPossibleTypeList compositeType
|
||||
|
||||
internalTypeName :: forall m. Schema.Type m -> Full.Name
|
||||
internalTypeName (Schema.ScalarType (Definition.ScalarType typeName _)) =
|
||||
typeName
|
||||
internalTypeName (Schema.EnumType (Definition.EnumType typeName _ _)) = typeName
|
||||
internalTypeName (Schema.ObjectType (Out.ObjectType typeName _ _ _)) = typeName
|
||||
internalTypeName (Schema.InputObjectType (In.InputObjectType typeName _ _)) =
|
||||
typeName
|
||||
internalTypeName (Schema.InterfaceType (Out.InterfaceType typeName _ _ _)) =
|
||||
typeName
|
||||
internalTypeName (Schema.UnionType (Out.UnionType typeName _ _)) = typeName
|
||||
|
||||
findSpreadTarget :: Full.Name -> ReaderT (Validation m1) Seq Full.TypeCondition
|
||||
findSpreadTarget fragmentName = do
|
||||
ast' <- asks ast
|
||||
let target = find (isSpreadTarget fragmentName) ast'
|
||||
lift $ maybeToSeq $ target >>= extractTypeCondition
|
||||
where
|
||||
extractTypeCondition (viewFragment -> Just fragmentDefinition) =
|
||||
let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition
|
||||
in Just typeCondition
|
||||
extractTypeCondition _ = Nothing
|
||||
|
||||
visitFragmentDefinition :: forall m
|
||||
. Text
|
||||
-> ValidationState m (Maybe Full.FragmentDefinition)
|
||||
visitFragmentDefinition fragmentName = 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 -> pure $ Just fragmentDefinition
|
||||
_ -> pure Nothing
|
||||
|
||||
-- | Variable usages must be compatible with the arguments they are passed to.
|
||||
--
|
||||
-- Validation failures occur when variables are used in the context of types
|
||||
-- that are complete mismatches, or if a nullable type in a variable is passed
|
||||
-- to a non‐null argument type.
|
||||
variablesInAllowedPositionRule :: forall m. Rule m
|
||||
variablesInAllowedPositionRule = OperationDefinitionRule $ \case
|
||||
Full.OperationDefinition operationType _ variables _ selectionSet _ -> do
|
||||
schema' <- asks schema
|
||||
let root = go variables (toList selectionSet) . Type.CompositeObjectType
|
||||
case operationType of
|
||||
Full.Query -> root $ Schema.query schema'
|
||||
Full.Mutation
|
||||
| Just objectType <- Schema.mutation schema' -> root objectType
|
||||
Full.Subscription
|
||||
| Just objectType <- Schema.mutation schema' -> root objectType
|
||||
_ -> lift mempty
|
||||
_ -> lift mempty
|
||||
where
|
||||
go variables selections selectionType = mapReaderT (foldr (<>) Seq.empty)
|
||||
$ flip evalStateT HashSet.empty
|
||||
$ visitSelectionSet variables selectionType
|
||||
$ toList selections
|
||||
visitSelectionSet :: Foldable t
|
||||
=> [Full.VariableDefinition]
|
||||
-> Type.CompositeType m
|
||||
-> t Full.Selection
|
||||
-> ValidationState m (Seq Error)
|
||||
visitSelectionSet variables selectionType selections =
|
||||
foldM (evaluateSelection variables selectionType) mempty selections
|
||||
evaluateFieldSelection variables selections accumulator = \case
|
||||
Just newParentType -> do
|
||||
let folder = evaluateSelection variables newParentType
|
||||
selectionErrors <- foldM folder accumulator selections
|
||||
pure $ accumulator <> selectionErrors
|
||||
Nothing -> pure accumulator
|
||||
evaluateSelection :: [Full.VariableDefinition]
|
||||
-> Type.CompositeType m
|
||||
-> Seq Error
|
||||
-> Full.Selection
|
||||
-> ValidationState m (Seq Error)
|
||||
evaluateSelection variables selectionType accumulator selection
|
||||
| Full.FragmentSpreadSelection spread <- selection
|
||||
, Full.FragmentSpread fragmentName _ _ <- spread = do
|
||||
types' <- lift $ asks $ Schema.types . schema
|
||||
nonVisitedFragmentDefinition <- visitFragmentDefinition fragmentName
|
||||
case nonVisitedFragmentDefinition of
|
||||
Just fragmentDefinition
|
||||
| Full.FragmentDefinition _ typeCondition _ _ _ <- fragmentDefinition
|
||||
, Just spreadType <- Type.lookupTypeCondition typeCondition types' -> do
|
||||
spreadErrors <- spreadVariables variables spread
|
||||
selectionErrors <- diveIntoSpread variables spreadType fragmentDefinition
|
||||
pure $ accumulator <> spreadErrors <> selectionErrors
|
||||
_ -> lift $ lift mempty
|
||||
| Full.FieldSelection fieldSelection <- selection
|
||||
, Full.Field _ fieldName _ _ subselections _ <- fieldSelection =
|
||||
case Type.lookupCompositeField fieldName selectionType of
|
||||
Just (Out.Field _ typeField argumentTypes) -> do
|
||||
fieldErrors <- fieldVariables variables argumentTypes fieldSelection
|
||||
selectionErrors <- evaluateFieldSelection variables subselections accumulator
|
||||
$ Type.outToComposite typeField
|
||||
pure $ selectionErrors <> fieldErrors
|
||||
Nothing -> pure accumulator
|
||||
| Full.InlineFragmentSelection inlineSelection <- selection
|
||||
, Full.InlineFragment typeCondition _ subselections _ <- inlineSelection = do
|
||||
types' <- lift $ asks $ Schema.types . schema
|
||||
let inlineType = fromMaybe selectionType
|
||||
$ typeCondition >>= flip Type.lookupTypeCondition types'
|
||||
fragmentErrors <- inlineVariables variables inlineSelection
|
||||
let folder = evaluateSelection variables inlineType
|
||||
selectionErrors <- foldM folder accumulator subselections
|
||||
pure $ accumulator <> fragmentErrors <> selectionErrors
|
||||
inlineVariables variables inline
|
||||
| Full.InlineFragment _ directives' _ _ <- inline =
|
||||
mapDirectives variables directives'
|
||||
fieldVariables :: [Full.VariableDefinition]
|
||||
-> In.Arguments
|
||||
-> Full.Field
|
||||
-> ValidationState m (Seq Error)
|
||||
fieldVariables variables argumentTypes fieldSelection = do
|
||||
let Full.Field _ _ arguments directives' _ _ = fieldSelection
|
||||
argumentErrors <- mapArguments variables argumentTypes arguments
|
||||
directiveErrors <- mapDirectives variables directives'
|
||||
pure $ argumentErrors <> directiveErrors
|
||||
spreadVariables variables (Full.FragmentSpread _ directives' _) =
|
||||
mapDirectives variables directives'
|
||||
diveIntoSpread variables fieldType fragmentDefinition = do
|
||||
let Full.FragmentDefinition _ _ directives' selections _ =
|
||||
fragmentDefinition
|
||||
selectionErrors <- visitSelectionSet variables fieldType selections
|
||||
directiveErrors <- mapDirectives variables directives'
|
||||
pure $ selectionErrors <> directiveErrors
|
||||
findDirectiveVariables variables directive = do
|
||||
let Full.Directive directiveName arguments _ = directive
|
||||
directiveDefinitions <- lift $ asks $ Schema.directives . schema
|
||||
case HashMap.lookup directiveName directiveDefinitions of
|
||||
Just (Schema.Directive _ _ directiveArguments) ->
|
||||
mapArguments variables directiveArguments arguments
|
||||
Nothing -> pure mempty
|
||||
mapArguments variables argumentTypes = fmap fold
|
||||
. traverse (findArgumentVariables variables argumentTypes)
|
||||
mapDirectives variables = fmap fold
|
||||
<$> traverse (findDirectiveVariables variables)
|
||||
lookupInputObject variables objectFieldValue locationInfo
|
||||
| Full.Node{ node = Full.Object objectFields } <- objectFieldValue
|
||||
, Just (expectedType, _) <- locationInfo
|
||||
, In.InputObjectBaseType inputObjectType <- expectedType
|
||||
, In.InputObjectType _ _ fieldTypes' <- inputObjectType =
|
||||
fold <$> traverse (traverseObjectField variables fieldTypes') objectFields
|
||||
| otherwise = pure mempty
|
||||
maybeUsageAllowed variableName variables locationInfo
|
||||
| Just (locationType, locationValue) <- locationInfo
|
||||
, findVariableDefinition' <- findVariableDefinition variableName
|
||||
, Just variableDefinition <- find findVariableDefinition' variables
|
||||
= maybeToSeq
|
||||
<$> isVariableUsageAllowed locationType locationValue variableDefinition
|
||||
| otherwise = pure mempty
|
||||
findArgumentVariables :: [Full.VariableDefinition]
|
||||
-> HashMap Full.Name In.Argument
|
||||
-> Full.Argument
|
||||
-> ValidationState m (Seq Error)
|
||||
findArgumentVariables variables argumentTypes argument
|
||||
| Full.Argument argumentName argumentValue _ <- argument
|
||||
, Full.Node{ node = Full.Variable variableName } <- argumentValue
|
||||
= maybeUsageAllowed variableName variables
|
||||
$ locationPair extractArgument argumentTypes argumentName
|
||||
| Full.Argument argumentName argumentValue _ <- argument
|
||||
= lookupInputObject variables argumentValue
|
||||
$ locationPair extractArgument argumentTypes argumentName
|
||||
extractField (In.InputField _ locationType locationValue) =
|
||||
(locationType, locationValue)
|
||||
extractArgument (In.Argument _ locationType locationValue) =
|
||||
(locationType, locationValue)
|
||||
locationPair extract fieldTypes name =
|
||||
extract <$> HashMap.lookup name fieldTypes
|
||||
traverseObjectField variables fieldTypes Full.ObjectField{..}
|
||||
| Full.Node{ node = Full.Variable variableName } <- value
|
||||
= maybeUsageAllowed variableName variables
|
||||
$ locationPair extractField fieldTypes name
|
||||
| otherwise = lookupInputObject variables value
|
||||
$ locationPair extractField fieldTypes name
|
||||
findVariableDefinition variableName variableDefinition =
|
||||
let Full.VariableDefinition variableName' _ _ _ = variableDefinition
|
||||
in variableName == variableName'
|
||||
isVariableUsageAllowed locationType locationDefaultValue variableDefinition
|
||||
| Full.VariableDefinition _ variableType _ _ <- variableDefinition
|
||||
, Full.TypeNonNull _ <- variableType =
|
||||
typesCompatibleOrError variableDefinition locationType
|
||||
| Just nullableLocationType <- unwrapInType locationType
|
||||
, Full.VariableDefinition _ variableType variableDefaultValue _ <-
|
||||
variableDefinition
|
||||
, hasNonNullVariableDefaultValue' <-
|
||||
hasNonNullVariableDefaultValue variableDefaultValue
|
||||
, hasLocationDefaultValue <- isJust locationDefaultValue =
|
||||
if (hasNonNullVariableDefaultValue' || hasLocationDefaultValue)
|
||||
&& areTypesCompatible variableType nullableLocationType
|
||||
then pure Nothing
|
||||
else pure $ makeError variableDefinition locationType
|
||||
| otherwise = typesCompatibleOrError variableDefinition locationType
|
||||
typesCompatibleOrError variableDefinition locationType
|
||||
| Full.VariableDefinition _ variableType _ _ <- variableDefinition
|
||||
, areTypesCompatible variableType locationType = pure Nothing
|
||||
| otherwise = pure $ makeError variableDefinition locationType
|
||||
areTypesCompatible nonNullType (unwrapInType -> Just nullableLocationType)
|
||||
| Full.TypeNonNull (Full.NonNullTypeNamed namedType) <- nonNullType =
|
||||
areTypesCompatible (Full.TypeNamed namedType) nullableLocationType
|
||||
| Full.TypeNonNull (Full.NonNullTypeList namedList) <- nonNullType =
|
||||
areTypesCompatible (Full.TypeList namedList) nullableLocationType
|
||||
areTypesCompatible _ (In.isNonNullType -> True) = False
|
||||
areTypesCompatible (Full.TypeNonNull nonNullType) locationType
|
||||
| Full.NonNullTypeNamed namedType <- nonNullType =
|
||||
areTypesCompatible (Full.TypeNamed namedType) locationType
|
||||
| Full.NonNullTypeList namedType <- nonNullType =
|
||||
areTypesCompatible (Full.TypeList namedType) locationType
|
||||
areTypesCompatible variableType locationType
|
||||
| Full.TypeList itemVariableType <- variableType
|
||||
, In.ListType itemLocationType <- locationType =
|
||||
areTypesCompatible itemVariableType itemLocationType
|
||||
| areIdentical variableType locationType = True
|
||||
| otherwise = False
|
||||
areIdentical (Full.TypeList typeList) (In.ListType itemLocationType) =
|
||||
areIdentical typeList itemLocationType
|
||||
areIdentical (Full.TypeNonNull nonNullType) locationType
|
||||
| Full.NonNullTypeList nonNullList <- nonNullType
|
||||
, In.NonNullListType itemLocationType <- locationType =
|
||||
areIdentical nonNullList itemLocationType
|
||||
| Full.NonNullTypeNamed _ <- nonNullType
|
||||
, In.ListBaseType _ <- locationType = False
|
||||
| Full.NonNullTypeNamed nonNullList <- nonNullType
|
||||
, In.isNonNullType locationType =
|
||||
nonNullList == inputTypeName locationType
|
||||
areIdentical (Full.TypeNamed _) (In.ListBaseType _) = False
|
||||
areIdentical (Full.TypeNamed typeNamed) locationType
|
||||
| not $ In.isNonNullType locationType =
|
||||
typeNamed == inputTypeName locationType
|
||||
areIdentical _ _ = False
|
||||
hasNonNullVariableDefaultValue (Just (Full.Node Full.ConstNull _)) = False
|
||||
hasNonNullVariableDefaultValue Nothing = False
|
||||
hasNonNullVariableDefaultValue _ = True
|
||||
unwrapInType (In.NonNullScalarType nonNullType) =
|
||||
Just $ In.NamedScalarType nonNullType
|
||||
unwrapInType (In.NonNullEnumType nonNullType) =
|
||||
Just $ In.NamedEnumType nonNullType
|
||||
unwrapInType (In.NonNullInputObjectType nonNullType) =
|
||||
Just $ In.NamedInputObjectType nonNullType
|
||||
unwrapInType (In.NonNullListType nonNullType) =
|
||||
Just $ In.ListType nonNullType
|
||||
unwrapInType _ = Nothing
|
||||
makeError variableDefinition expectedType =
|
||||
let Full.VariableDefinition variableName variableType _ location' =
|
||||
variableDefinition
|
||||
in Just $ Error
|
||||
{ message = concat
|
||||
[ "Variable \"$"
|
||||
, Text.unpack variableName
|
||||
, "\" of type \""
|
||||
, show variableType
|
||||
, "\" used in position expecting type \""
|
||||
, show expectedType
|
||||
, "\"."
|
||||
]
|
||||
, locations = [location']
|
||||
}
|
||||
|
||||
-- | Literal values must be compatible with the type expected in the position
|
||||
-- they are found as per the coercion rules.
|
||||
--
|
||||
-- The type expected in a position include the type defined by the argument a
|
||||
-- value is provided for, the type defined by an input object field a value is
|
||||
-- provided for, and the type of a variable definition a default value is
|
||||
-- provided for.
|
||||
valuesOfCorrectTypeRule :: forall m. Rule m
|
||||
valuesOfCorrectTypeRule = ValueRule go constGo
|
||||
where
|
||||
go (Just inputType) value
|
||||
| Just constValue <- toConstNode value =
|
||||
lift $ check inputType constValue
|
||||
go _ _ = lift mempty
|
||||
toConstNode Full.Node{..} = flip Full.Node location <$> toConst node
|
||||
toConst (Full.Variable _) = Nothing
|
||||
toConst (Full.Int integer) = Just $ Full.ConstInt integer
|
||||
toConst (Full.Float double) = Just $ Full.ConstFloat double
|
||||
toConst (Full.String string) = Just $ Full.ConstString string
|
||||
toConst (Full.Boolean boolean) = Just $ Full.ConstBoolean boolean
|
||||
toConst Full.Null = Just Full.ConstNull
|
||||
toConst (Full.Enum enum) = Just $ Full.ConstEnum enum
|
||||
toConst (Full.List values) =
|
||||
Just $ Full.ConstList $ catMaybes $ toConst <$> values
|
||||
toConst (Full.Object fields) = Just $ Full.ConstObject
|
||||
$ catMaybes $ constObjectField <$> fields
|
||||
constObjectField Full.ObjectField{..}
|
||||
| Just constValue <- toConstNode value =
|
||||
Just $ Full.ObjectField name constValue location
|
||||
| otherwise = Nothing
|
||||
constGo Nothing = const $ lift mempty
|
||||
constGo (Just inputType) = lift . check inputType
|
||||
check :: In.Type -> Full.Node Full.ConstValue -> Seq Error
|
||||
check _ Full.Node{ node = Full.ConstNull } =
|
||||
mempty -- Ignore, required fields are checked elsewhere.
|
||||
check (In.ScalarBaseType scalarType) Full.Node{ node }
|
||||
| Definition.ScalarType "Int" _ <- scalarType
|
||||
, Full.ConstInt _ <- node = mempty
|
||||
| Definition.ScalarType "Boolean" _ <- scalarType
|
||||
, Full.ConstBoolean _ <- node = mempty
|
||||
| Definition.ScalarType "String" _ <- scalarType
|
||||
, Full.ConstString _ <- node = mempty
|
||||
| Definition.ScalarType "ID" _ <- scalarType
|
||||
, Full.ConstString _ <- node = mempty
|
||||
| Definition.ScalarType "ID" _ <- scalarType
|
||||
, Full.ConstInt _ <- node = mempty
|
||||
| Definition.ScalarType "Float" _ <- scalarType
|
||||
, Full.ConstFloat _ <- node = mempty
|
||||
| Definition.ScalarType "Float" _ <- scalarType
|
||||
, Full.ConstInt _ <- node = mempty
|
||||
check (In.EnumBaseType enumType) Full.Node{ node }
|
||||
| Definition.EnumType _ _ members <- enumType
|
||||
, Full.ConstEnum memberValue <- node
|
||||
, HashMap.member memberValue members = mempty
|
||||
check (In.InputObjectBaseType objectType) Full.Node{ node }
|
||||
| In.InputObjectType _ _ typeFields <- objectType
|
||||
, Full.ConstObject valueFields <- node =
|
||||
foldMap (checkObjectField typeFields) valueFields
|
||||
check (In.ListBaseType listType) constValue@Full.Node{ .. }
|
||||
| Full.ConstList listValues <- node =
|
||||
foldMap (check listType) $ flip Full.Node location <$> listValues
|
||||
| otherwise = check listType constValue
|
||||
check inputType Full.Node{ .. } = pure $ Error
|
||||
{ message = concat
|
||||
[ "Value "
|
||||
, show node, " cannot be coerced to type \""
|
||||
, show inputType
|
||||
, "\"."
|
||||
]
|
||||
, locations = [location]
|
||||
}
|
||||
checkObjectField typeFields Full.ObjectField{..}
|
||||
| Just typeField <- HashMap.lookup name typeFields
|
||||
, In.InputField _ fieldType _ <- typeField =
|
||||
check fieldType value
|
||||
checkObjectField _ _ = mempty
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
resolver: lts-16.20
|
||||
resolver: lts-17.2
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
|
|
@ -0,0 +1,20 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.GraphQL.AST.DocumentSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Language.GraphQL.AST.Document
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "Document" $ do
|
||||
it "shows objects" $
|
||||
let zero = Location 0 0
|
||||
object = ConstObject
|
||||
[ ObjectField "field1" (Node (ConstFloat 1.2) zero) zero
|
||||
, ObjectField "field2" (Node ConstNull zero) zero
|
||||
]
|
||||
expected = "{ field1: 1.2, field2: null }"
|
||||
in show object `shouldBe` expected
|
|
@ -0,0 +1,914 @@
|
|||
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
||||
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 OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Language.GraphQL.Validate.RulesSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Foldable (toList)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.AST as AST
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Validate
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain)
|
||||
import Text.Megaparsec (parse, errorBundlePretty)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
petSchema :: Schema IO
|
||||
petSchema = schema queryType Nothing (Just subscriptionType) mempty
|
||||
|
||||
queryType :: ObjectType IO
|
||||
queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
[ ("dog", dogResolver)
|
||||
, ("cat", catResolver)
|
||||
, ("findDog", findDogResolver)
|
||||
]
|
||||
where
|
||||
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
||||
dogResolver = ValueResolver dogField $ pure Null
|
||||
findDogArguments = HashMap.singleton "complex"
|
||||
$ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing
|
||||
findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments
|
||||
findDogResolver = ValueResolver findDogField $ pure Null
|
||||
catField = Field Nothing (Out.NamedObjectType catType) mempty
|
||||
catResolver = ValueResolver catField $ pure Null
|
||||
|
||||
catCommandType :: EnumType
|
||||
catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
|
||||
[ ("JUMP", EnumValue Nothing)
|
||||
]
|
||||
|
||||
catType :: ObjectType IO
|
||||
catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
|
||||
[ ("name", nameResolver)
|
||||
, ("nickname", nicknameResolver)
|
||||
, ("doesKnowCommand", doesKnowCommandResolver)
|
||||
, ("meowVolume", meowVolumeResolver)
|
||||
]
|
||||
where
|
||||
meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
|
||||
meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 3
|
||||
doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
|
||||
$ HashMap.singleton "catCommand"
|
||||
$ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
|
||||
doesKnowCommandResolver = ValueResolver doesKnowCommandField
|
||||
$ pure $ Boolean True
|
||||
|
||||
nameResolver :: Resolver IO
|
||||
nameResolver = ValueResolver nameField $ pure "Name"
|
||||
where
|
||||
nameField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
|
||||
nicknameResolver :: Resolver IO
|
||||
nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
|
||||
where
|
||||
nicknameField = Field Nothing (Out.NamedScalarType string) mempty
|
||||
|
||||
dogCommandType :: EnumType
|
||||
dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
|
||||
[ ("SIT", EnumValue Nothing)
|
||||
, ("DOWN", EnumValue Nothing)
|
||||
, ("HEEL", EnumValue Nothing)
|
||||
]
|
||||
|
||||
dogType :: ObjectType IO
|
||||
dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
|
||||
[ ("name", nameResolver)
|
||||
, ("nickname", nicknameResolver)
|
||||
, ("barkVolume", barkVolumeResolver)
|
||||
, ("doesKnowCommand", doesKnowCommandResolver)
|
||||
, ("isHousetrained", isHousetrainedResolver)
|
||||
, ("owner", ownerResolver)
|
||||
]
|
||||
where
|
||||
barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty
|
||||
barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3
|
||||
doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
|
||||
$ HashMap.singleton "dogCommand"
|
||||
$ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing
|
||||
doesKnowCommandResolver = ValueResolver doesKnowCommandField
|
||||
$ pure $ Boolean True
|
||||
isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean)
|
||||
$ HashMap.singleton "atOtherHomes"
|
||||
$ In.Argument Nothing (In.NamedScalarType boolean) Nothing
|
||||
isHousetrainedResolver = ValueResolver isHousetrainedField
|
||||
$ pure $ Boolean True
|
||||
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
|
||||
ownerResolver = ValueResolver ownerField $ pure Null
|
||||
|
||||
dogDataType :: InputObjectType
|
||||
dogDataType = InputObjectType "DogData" Nothing
|
||||
$ HashMap.singleton "name" nameInputField
|
||||
where
|
||||
nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing
|
||||
|
||||
sentientType :: InterfaceType IO
|
||||
sentientType = InterfaceType "Sentient" Nothing []
|
||||
$ HashMap.singleton "name"
|
||||
$ Field Nothing (Out.NonNullScalarType string) mempty
|
||||
|
||||
petType :: InterfaceType IO
|
||||
petType = InterfaceType "Pet" Nothing []
|
||||
$ HashMap.singleton "name"
|
||||
$ Field Nothing (Out.NonNullScalarType string) mempty
|
||||
|
||||
subscriptionType :: ObjectType IO
|
||||
subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList
|
||||
[ ("newMessage", newMessageResolver)
|
||||
, ("disallowedSecondRootField", newMessageResolver)
|
||||
]
|
||||
where
|
||||
newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty
|
||||
newMessageResolver = ValueResolver newMessageField
|
||||
$ pure $ Object HashMap.empty
|
||||
|
||||
messageType :: ObjectType IO
|
||||
messageType = ObjectType "Message" Nothing [] $ HashMap.fromList
|
||||
[ ("sender", senderResolver)
|
||||
, ("body", bodyResolver)
|
||||
]
|
||||
where
|
||||
senderField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
senderResolver = ValueResolver senderField $ pure "Sender"
|
||||
bodyField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
bodyResolver = ValueResolver bodyField $ pure "Message body."
|
||||
|
||||
humanType :: ObjectType IO
|
||||
humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
|
||||
[ ("name", nameResolver)
|
||||
, ("pets", petsResolver)
|
||||
]
|
||||
where
|
||||
petsField =
|
||||
Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
|
||||
petsResolver = ValueResolver petsField $ pure $ List []
|
||||
|
||||
validate :: Text -> [Error]
|
||||
validate queryString =
|
||||
case parse AST.document "" queryString of
|
||||
Left parseErrors -> error $ errorBundlePretty parseErrors
|
||||
Right ast -> toList $ document petSchema specifiedRules ast
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "document" $ do
|
||||
context "executableDefinitionsRule" $
|
||||
it "rejects type definitions" $
|
||||
let queryString = [r|
|
||||
query getDogName {
|
||||
dog {
|
||||
name
|
||||
color
|
||||
}
|
||||
}
|
||||
|
||||
extend type Dog {
|
||||
color: String
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Definition must be OperationDefinition or \
|
||||
\FragmentDefinition."
|
||||
, locations = [AST.Location 9 19]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
context "singleFieldSubscriptionsRule" $ do
|
||||
it "rejects multiple subscription root fields" $
|
||||
let queryString = [r|
|
||||
subscription sub {
|
||||
newMessage {
|
||||
body
|
||||
sender
|
||||
}
|
||||
disallowedSecondRootField
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Subscription \"sub\" must select only one top \
|
||||
\level field."
|
||||
, locations = [AST.Location 2 19]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects multiple subscription root fields coming from a fragment" $
|
||||
let queryString = [r|
|
||||
subscription sub {
|
||||
...multipleSubscriptions
|
||||
}
|
||||
|
||||
fragment multipleSubscriptions on Subscription {
|
||||
newMessage {
|
||||
body
|
||||
sender
|
||||
}
|
||||
disallowedSecondRootField
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Subscription \"sub\" must select only one top \
|
||||
\level field."
|
||||
, locations = [AST.Location 2 19]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "finds corresponding subscription fragment" $
|
||||
let queryString = [r|
|
||||
subscription sub {
|
||||
...anotherSubscription
|
||||
...multipleSubscriptions
|
||||
}
|
||||
fragment multipleSubscriptions on Subscription {
|
||||
newMessage {
|
||||
body
|
||||
}
|
||||
disallowedSecondRootField {
|
||||
sender
|
||||
}
|
||||
}
|
||||
fragment anotherSubscription on Subscription {
|
||||
newMessage {
|
||||
body
|
||||
sender
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Subscription \"sub\" must select only one top \
|
||||
\level field."
|
||||
, locations = [AST.Location 2 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "loneAnonymousOperationRule" $
|
||||
it "rejects multiple anonymous operations" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
name
|
||||
}
|
||||
}
|
||||
|
||||
query getName {
|
||||
dog {
|
||||
owner {
|
||||
name
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"This anonymous operation must be the only defined \
|
||||
\operation."
|
||||
, locations = [AST.Location 2 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "uniqueOperationNamesRule" $
|
||||
it "rejects operations with the same name" $
|
||||
let queryString = [r|
|
||||
query dogOperation {
|
||||
dog {
|
||||
name
|
||||
}
|
||||
}
|
||||
|
||||
mutation dogOperation {
|
||||
mutateDog {
|
||||
id
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one operation named \
|
||||
\\"dogOperation\"."
|
||||
, locations = [AST.Location 2 19, AST.Location 8 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "uniqueFragmentNamesRule" $
|
||||
it "rejects fragments with the same name" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...fragmentOne
|
||||
}
|
||||
}
|
||||
|
||||
fragment fragmentOne on Dog {
|
||||
name
|
||||
}
|
||||
|
||||
fragment fragmentOne on Dog {
|
||||
owner {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one fragment named \
|
||||
\\"fragmentOne\"."
|
||||
, locations = [AST.Location 8 19, AST.Location 12 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "fragmentSpreadTargetDefinedRule" $
|
||||
it "rejects the fragment spread without a target" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...undefinedFragment
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment target \"undefinedFragment\" is \
|
||||
\undefined."
|
||||
, locations = [AST.Location 4 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "fragmentSpreadTypeExistenceRule" $ do
|
||||
it "rejects fragment spreads without an unknown target type" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...notOnExistingType
|
||||
}
|
||||
}
|
||||
fragment notOnExistingType on NotInSchema {
|
||||
name
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment \"notOnExistingType\" is specified on \
|
||||
\type \"NotInSchema\" which doesn't exist in the \
|
||||
\schema."
|
||||
, locations = [AST.Location 4 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects inline fragments without a target" $
|
||||
let queryString = [r|
|
||||
{
|
||||
... on NotInSchema {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Inline fragment is specified on type \
|
||||
\\"NotInSchema\" which doesn't exist in the schema."
|
||||
, locations = [AST.Location 3 21]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "fragmentsOnCompositeTypesRule" $ do
|
||||
it "rejects fragments on scalar types" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...fragOnScalar
|
||||
}
|
||||
}
|
||||
fragment fragOnScalar on Int {
|
||||
name
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment cannot condition on non composite type \
|
||||
\\"Int\"."
|
||||
, locations = [AST.Location 7 19]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects inline fragments on scalar types" $
|
||||
let queryString = [r|
|
||||
{
|
||||
... on Boolean {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment cannot condition on non composite type \
|
||||
\\"Boolean\"."
|
||||
, locations = [AST.Location 3 21]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
context "noUnusedFragmentsRule" $
|
||||
it "rejects unused fragments" $
|
||||
let queryString = [r|
|
||||
fragment nameFragment on Dog { # unused
|
||||
name
|
||||
}
|
||||
|
||||
{
|
||||
dog {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment \"nameFragment\" is never used."
|
||||
, locations = [AST.Location 2 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "noFragmentCyclesRule" $
|
||||
it "rejects spreads that form cycles" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...nameFragment
|
||||
}
|
||||
}
|
||||
fragment nameFragment on Dog {
|
||||
name
|
||||
...barkVolumeFragment
|
||||
}
|
||||
fragment barkVolumeFragment on Dog {
|
||||
barkVolume
|
||||
...nameFragment
|
||||
}
|
||||
|]
|
||||
error1 = Error
|
||||
{ message =
|
||||
"Cannot spread fragment \"barkVolumeFragment\" \
|
||||
\within itself (via barkVolumeFragment -> \
|
||||
\nameFragment -> barkVolumeFragment)."
|
||||
, locations = [AST.Location 11 19]
|
||||
}
|
||||
error2 = Error
|
||||
{ message =
|
||||
"Cannot spread fragment \"nameFragment\" within \
|
||||
\itself (via nameFragment -> barkVolumeFragment -> \
|
||||
\nameFragment)."
|
||||
, locations = [AST.Location 7 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [error1, error2]
|
||||
|
||||
context "uniqueArgumentNamesRule" $
|
||||
it "rejects duplicate field arguments" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: true, atOtherHomes: true)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one argument named \
|
||||
\\"atOtherHomes\"."
|
||||
, locations = [AST.Location 4 38, AST.Location 4 58]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "uniqueDirectiveNamesRule" $
|
||||
it "rejects more than one directive per location" $
|
||||
let queryString = [r|
|
||||
query ($foo: Boolean = true, $bar: Boolean = false) {
|
||||
dog @skip(if: $foo) @skip(if: $bar) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one directive named \"skip\"."
|
||||
, locations = [AST.Location 3 25, AST.Location 3 41]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "uniqueVariableNamesRule" $
|
||||
it "rejects duplicate variables" $
|
||||
let queryString = [r|
|
||||
query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: $atOtherHomes)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one variable named \
|
||||
\\"atOtherHomes\"."
|
||||
, locations = [AST.Location 2 43, AST.Location 2 67]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "variablesAreInputTypesRule" $
|
||||
it "rejects non-input types as variables" $
|
||||
let queryString = [r|
|
||||
query takesDogBang($dog: Dog!) {
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: $dog)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Variable \"$dog\" cannot be non-input type \
|
||||
\\"Dog\"."
|
||||
, locations = [AST.Location 2 38]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
context "noUndefinedVariablesRule" $
|
||||
it "rejects undefined variables" $
|
||||
let queryString = [r|
|
||||
query variableIsNotDefinedUsedInSingleFragment {
|
||||
dog {
|
||||
...isHousetrainedFragment
|
||||
}
|
||||
}
|
||||
|
||||
fragment isHousetrainedFragment on Dog {
|
||||
isHousetrained(atOtherHomes: $atOtherHomes)
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Variable \"$atOtherHomes\" is not defined by \
|
||||
\operation \
|
||||
\\"variableIsNotDefinedUsedInSingleFragment\"."
|
||||
, locations = [AST.Location 9 50]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "noUnusedVariablesRule" $
|
||||
it "rejects unused variables" $
|
||||
let queryString = [r|
|
||||
query variableUnused($atOtherHomes: Boolean) {
|
||||
dog {
|
||||
isHousetrained
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Variable \"$atOtherHomes\" is never used in \
|
||||
\operation \"variableUnused\"."
|
||||
, locations = [AST.Location 2 40]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "uniqueInputFieldNamesRule" $
|
||||
it "rejects duplicate fields in input objects" $
|
||||
let queryString = [r|
|
||||
{
|
||||
findDog(complex: { name: "Fido", name: "Jack" }) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one input field named \"name\"."
|
||||
, locations = [AST.Location 3 40, AST.Location 3 54]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "fieldsOnCorrectTypeRule" $
|
||||
it "rejects undefined fields" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
meowVolume
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Cannot query field \"meowVolume\" on type \"Dog\"."
|
||||
, locations = [AST.Location 4 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "scalarLeafsRule" $
|
||||
it "rejects scalar fields with not empty selection set" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
barkVolume {
|
||||
sinceWhen
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Field \"barkVolume\" must not have a selection \
|
||||
\since type \"Int\" has no subfields."
|
||||
, locations = [AST.Location 4 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "knownArgumentNamesRule" $ do
|
||||
it "rejects field arguments missing in the type" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Unknown argument \"command\" on field \
|
||||
\\"Dog.doesKnowCommand\"."
|
||||
, locations = [AST.Location 4 39]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects directive arguments missing in the definition" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: true) @include(unless: false, if: true)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Unknown argument \"unless\" on directive \
|
||||
\\"@include\"."
|
||||
, locations = [AST.Location 4 67]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "knownDirectiveNamesRule" $
|
||||
it "rejects undefined directives" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: true) @ignore(if: true)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message = "Unknown directive \"@ignore\"."
|
||||
, locations = [AST.Location 4 58]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "knownInputFieldNamesRule" $
|
||||
it "rejects undefined input object fields" $
|
||||
let queryString = [r|
|
||||
{
|
||||
findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Field \"favoriteCookieFlavor\" is not defined \
|
||||
\by type \"DogData\"."
|
||||
, locations = [AST.Location 3 40]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "directivesInValidLocationsRule" $
|
||||
it "rejects directives in invalid locations" $
|
||||
let queryString = [r|
|
||||
query @skip(if: $foo) {
|
||||
dog {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Directive \"@skip\" may not be used on QUERY."
|
||||
, locations = [AST.Location 2 25]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "overlappingFieldsCanBeMergedRule" $ do
|
||||
it "fails to merge fields of mismatching types" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
name: nickname
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fields \"name\" conflict because \"nickname\" and \
|
||||
\\"name\" are different fields. Use different \
|
||||
\aliases on the fields to fetch both if this was \
|
||||
\intentional."
|
||||
, locations = [AST.Location 4 23, AST.Location 5 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "fails if the arguments of the same field don't match" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
doesKnowCommand(dogCommand: SIT)
|
||||
doesKnowCommand(dogCommand: HEEL)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fields \"doesKnowCommand\" conflict because they \
|
||||
\have different arguments. Use different aliases \
|
||||
\on the fields to fetch both if this was \
|
||||
\intentional."
|
||||
, locations = [AST.Location 4 23, AST.Location 5 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "fails to merge same-named field and alias" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
doesKnowCommand(dogCommand: SIT)
|
||||
doesKnowCommand: isHousetrained(atOtherHomes: true)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fields \"doesKnowCommand\" conflict because \
|
||||
\\"doesKnowCommand\" and \"isHousetrained\" are \
|
||||
\different fields. Use different aliases on the \
|
||||
\fields to fetch both if this was intentional."
|
||||
, locations = [AST.Location 4 23, AST.Location 5 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "looks for fields after a successfully merged field pair" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
name
|
||||
doesKnowCommand(dogCommand: SIT)
|
||||
}
|
||||
dog {
|
||||
name
|
||||
doesKnowCommand: isHousetrained(atOtherHomes: true)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fields \"doesKnowCommand\" conflict because \
|
||||
\\"doesKnowCommand\" and \"isHousetrained\" are \
|
||||
\different fields. Use different aliases on the \
|
||||
\fields to fetch both if this was intentional."
|
||||
, locations = [AST.Location 5 23, AST.Location 9 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "possibleFragmentSpreadsRule" $ do
|
||||
it "rejects object inline spreads outside object scope" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
... on Cat {
|
||||
meowVolume
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment cannot be spread here as objects of type \
|
||||
\\"Dog\" can never be of type \"Cat\"."
|
||||
, locations = [AST.Location 4 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects object named spreads outside object scope" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
... catInDogFragmentInvalid
|
||||
}
|
||||
}
|
||||
|
||||
fragment catInDogFragmentInvalid on Cat {
|
||||
meowVolume
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment \"catInDogFragmentInvalid\" cannot be \
|
||||
\spread here as objects of type \"Dog\" can never \
|
||||
\be of type \"Cat\"."
|
||||
, locations = [AST.Location 4 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "providedRequiredInputFieldsRule" $
|
||||
it "rejects missing required input fields" $
|
||||
let queryString = [r|
|
||||
{
|
||||
findDog(complex: { name: null }) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Input field \"name\" of type \"DogData\" is \
|
||||
\required, but it was not provided."
|
||||
, locations = [AST.Location 3 38]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "providedRequiredArgumentsRule" $
|
||||
it "checks for (non-)nullable arguments" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
doesKnowCommand(dogCommand: null)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Field \"doesKnowCommand\" argument \"dogCommand\" \
|
||||
\of type \"DogCommand\" is required, but it was \
|
||||
\not provided."
|
||||
, locations = [AST.Location 4 23]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "variablesInAllowedPositionRule" $ do
|
||||
it "rejects wrongly typed variable arguments" $
|
||||
let queryString = [r|
|
||||
query catCommandArgQuery($catCommandArg: CatCommand) {
|
||||
cat {
|
||||
doesKnowCommand(catCommand: $catCommandArg)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Variable \"$catCommandArg\" of type \
|
||||
\\"CatCommand\" used in position expecting type \
|
||||
\\"!CatCommand\"."
|
||||
, locations = [AST.Location 2 44]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects wrongly typed variable arguments" $
|
||||
let queryString = [r|
|
||||
query intCannotGoIntoBoolean($intArg: Int) {
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: $intArg)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Variable \"$intArg\" of type \"Int\" used in \
|
||||
\position expecting type \"Boolean\"."
|
||||
, locations = [AST.Location 2 48]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "valuesOfCorrectTypeRule" $
|
||||
it "rejects values of incorrect types" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: 3)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Value 3 cannot be coerced to type \"Boolean\"."
|
||||
, locations = [AST.Location 4 52]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
|
@ -1,665 +0,0 @@
|
|||
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
||||
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 OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Language.GraphQL.ValidateSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Foldable (toList)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.AST as AST
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Validate
|
||||
import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
petSchema :: Schema IO
|
||||
petSchema = schema queryType Nothing (Just subscriptionType) mempty
|
||||
|
||||
queryType :: ObjectType IO
|
||||
queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
[ ("dog", dogResolver)
|
||||
, ("findDog", findDogResolver)
|
||||
]
|
||||
where
|
||||
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
||||
dogResolver = ValueResolver dogField $ pure Null
|
||||
findDogArguments = HashMap.singleton "complex"
|
||||
$ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing
|
||||
findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments
|
||||
findDogResolver = ValueResolver findDogField $ pure Null
|
||||
|
||||
dogCommandType :: EnumType
|
||||
dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
|
||||
[ ("SIT", EnumValue Nothing)
|
||||
, ("DOWN", EnumValue Nothing)
|
||||
, ("HEEL", EnumValue Nothing)
|
||||
]
|
||||
|
||||
dogType :: ObjectType IO
|
||||
dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
|
||||
[ ("name", nameResolver)
|
||||
, ("nickname", nicknameResolver)
|
||||
, ("barkVolume", barkVolumeResolver)
|
||||
, ("doesKnowCommand", doesKnowCommandResolver)
|
||||
, ("isHousetrained", isHousetrainedResolver)
|
||||
, ("owner", ownerResolver)
|
||||
]
|
||||
where
|
||||
nameField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
nameResolver = ValueResolver nameField $ pure "Name"
|
||||
nicknameField = Field Nothing (Out.NamedScalarType string) mempty
|
||||
nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
|
||||
barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty
|
||||
barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3
|
||||
doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
|
||||
$ HashMap.singleton "dogCommand"
|
||||
$ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing
|
||||
doesKnowCommandResolver = ValueResolver doesKnowCommandField
|
||||
$ pure $ Boolean True
|
||||
isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean)
|
||||
$ HashMap.singleton "atOtherHomes"
|
||||
$ In.Argument Nothing (In.NamedScalarType boolean) Nothing
|
||||
isHousetrainedResolver = ValueResolver isHousetrainedField
|
||||
$ pure $ Boolean True
|
||||
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
|
||||
ownerResolver = ValueResolver ownerField $ pure Null
|
||||
|
||||
dogDataType :: InputObjectType
|
||||
dogDataType = InputObjectType "DogData" Nothing
|
||||
$ HashMap.singleton "name" nameInputField
|
||||
where
|
||||
nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing
|
||||
|
||||
sentientType :: InterfaceType IO
|
||||
sentientType = InterfaceType "Sentient" Nothing []
|
||||
$ HashMap.singleton "name"
|
||||
$ Field Nothing (Out.NonNullScalarType string) mempty
|
||||
|
||||
petType :: InterfaceType IO
|
||||
petType = InterfaceType "Pet" Nothing []
|
||||
$ HashMap.singleton "name"
|
||||
$ Field Nothing (Out.NonNullScalarType string) mempty
|
||||
|
||||
subscriptionType :: ObjectType IO
|
||||
subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList
|
||||
[ ("newMessage", newMessageResolver)
|
||||
, ("disallowedSecondRootField", newMessageResolver)
|
||||
]
|
||||
where
|
||||
newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty
|
||||
newMessageResolver = ValueResolver newMessageField
|
||||
$ pure $ Object HashMap.empty
|
||||
|
||||
messageType :: ObjectType IO
|
||||
messageType = ObjectType "Message" Nothing [] $ HashMap.fromList
|
||||
[ ("sender", senderResolver)
|
||||
, ("body", bodyResolver)
|
||||
]
|
||||
where
|
||||
senderField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
senderResolver = ValueResolver senderField $ pure "Sender"
|
||||
bodyField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
bodyResolver = ValueResolver bodyField $ pure "Message body."
|
||||
|
||||
humanType :: ObjectType IO
|
||||
humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
|
||||
[ ("name", nameResolver)
|
||||
, ("pets", petsResolver)
|
||||
]
|
||||
where
|
||||
nameField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
nameResolver = ValueResolver nameField $ pure "Name"
|
||||
petsField =
|
||||
Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
|
||||
petsResolver = ValueResolver petsField $ pure $ List []
|
||||
{-
|
||||
catOrDogType :: UnionType IO
|
||||
catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
|
||||
-}
|
||||
validate :: Text -> [Error]
|
||||
validate queryString =
|
||||
case parse AST.document "" queryString of
|
||||
Left _ -> []
|
||||
Right ast -> toList $ document petSchema specifiedRules ast
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "document" $ do
|
||||
it "rejects type definitions" $
|
||||
let queryString = [r|
|
||||
query getDogName {
|
||||
dog {
|
||||
name
|
||||
color
|
||||
}
|
||||
}
|
||||
|
||||
extend type Dog {
|
||||
color: String
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Definition must be OperationDefinition or FragmentDefinition."
|
||||
, locations = [AST.Location 9 15]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects multiple subscription root fields" $
|
||||
let queryString = [r|
|
||||
subscription sub {
|
||||
newMessage {
|
||||
body
|
||||
sender
|
||||
}
|
||||
disallowedSecondRootField
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Subscription \"sub\" must select only one top level \
|
||||
\field."
|
||||
, locations = [AST.Location 2 15]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects multiple subscription root fields coming from a fragment" $
|
||||
let queryString = [r|
|
||||
subscription sub {
|
||||
...multipleSubscriptions
|
||||
}
|
||||
|
||||
fragment multipleSubscriptions on Subscription {
|
||||
newMessage {
|
||||
body
|
||||
sender
|
||||
}
|
||||
disallowedSecondRootField
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Subscription \"sub\" must select only one top level \
|
||||
\field."
|
||||
, locations = [AST.Location 2 15]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects multiple anonymous operations" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
name
|
||||
}
|
||||
}
|
||||
|
||||
query getName {
|
||||
dog {
|
||||
owner {
|
||||
name
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"This anonymous operation must be the only defined operation."
|
||||
, locations = [AST.Location 2 15]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects operations with the same name" $
|
||||
let queryString = [r|
|
||||
query dogOperation {
|
||||
dog {
|
||||
name
|
||||
}
|
||||
}
|
||||
|
||||
mutation dogOperation {
|
||||
mutateDog {
|
||||
id
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one operation named \"dogOperation\"."
|
||||
, locations = [AST.Location 2 15, AST.Location 8 15]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects fragments with the same name" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...fragmentOne
|
||||
}
|
||||
}
|
||||
|
||||
fragment fragmentOne on Dog {
|
||||
name
|
||||
}
|
||||
|
||||
fragment fragmentOne on Dog {
|
||||
owner {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one fragment named \"fragmentOne\"."
|
||||
, locations = [AST.Location 8 15, AST.Location 12 15]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects the fragment spread without a target" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...undefinedFragment
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment target \"undefinedFragment\" is undefined."
|
||||
, locations = [AST.Location 4 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects fragment spreads without an unknown target type" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...notOnExistingType
|
||||
}
|
||||
}
|
||||
fragment notOnExistingType on NotInSchema {
|
||||
name
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment \"notOnExistingType\" is specified on type \
|
||||
\\"NotInSchema\" which doesn't exist in the schema."
|
||||
, locations = [AST.Location 4 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects inline fragments without a target" $
|
||||
let queryString = [r|
|
||||
{
|
||||
... on NotInSchema {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Inline fragment is specified on type \"NotInSchema\" \
|
||||
\which doesn't exist in the schema."
|
||||
, locations = [AST.Location 3 17]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects fragments on scalar types" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...fragOnScalar
|
||||
}
|
||||
}
|
||||
fragment fragOnScalar on Int {
|
||||
name
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment cannot condition on non composite type \
|
||||
\\"Int\"."
|
||||
, locations = [AST.Location 7 15]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects inline fragments on scalar types" $
|
||||
let queryString = [r|
|
||||
{
|
||||
... on Boolean {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment cannot condition on non composite type \
|
||||
\\"Boolean\"."
|
||||
, locations = [AST.Location 3 17]
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects unused fragments" $
|
||||
let queryString = [r|
|
||||
fragment nameFragment on Dog { # unused
|
||||
name
|
||||
}
|
||||
|
||||
{
|
||||
dog {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Fragment \"nameFragment\" is never used."
|
||||
, locations = [AST.Location 2 15]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects spreads that form cycles" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
...nameFragment
|
||||
}
|
||||
}
|
||||
fragment nameFragment on Dog {
|
||||
name
|
||||
...barkVolumeFragment
|
||||
}
|
||||
fragment barkVolumeFragment on Dog {
|
||||
barkVolume
|
||||
...nameFragment
|
||||
}
|
||||
|]
|
||||
error1 = Error
|
||||
{ message =
|
||||
"Cannot spread fragment \"barkVolumeFragment\" within \
|
||||
\itself (via barkVolumeFragment -> nameFragment -> \
|
||||
\barkVolumeFragment)."
|
||||
, locations = [AST.Location 11 15]
|
||||
}
|
||||
error2 = Error
|
||||
{ message =
|
||||
"Cannot spread fragment \"nameFragment\" within itself \
|
||||
\(via nameFragment -> barkVolumeFragment -> \
|
||||
\nameFragment)."
|
||||
, locations = [AST.Location 7 15]
|
||||
}
|
||||
in validate queryString `shouldBe` [error1, error2]
|
||||
|
||||
it "rejects duplicate field arguments" $ do
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: true, atOtherHomes: true)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one argument named \"atOtherHomes\"."
|
||||
, locations = [AST.Location 4 34, AST.Location 4 54]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects more than one directive per location" $ do
|
||||
let queryString = [r|
|
||||
query ($foo: Boolean = true, $bar: Boolean = false) {
|
||||
dog @skip(if: $foo) @skip(if: $bar) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one directive named \"skip\"."
|
||||
, locations = [AST.Location 3 21, AST.Location 3 37]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects duplicate variables" $
|
||||
let queryString = [r|
|
||||
query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: $atOtherHomes)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one variable named \"atOtherHomes\"."
|
||||
, locations = [AST.Location 2 39, AST.Location 2 63]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects non-input types as variables" $
|
||||
let queryString = [r|
|
||||
query takesDogBang($dog: Dog!) {
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: $dog)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Variable \"$dog\" cannot be non-input type \"Dog\"."
|
||||
, locations = [AST.Location 2 34]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects undefined variables" $
|
||||
let queryString = [r|
|
||||
query variableIsNotDefinedUsedInSingleFragment {
|
||||
dog {
|
||||
...isHousetrainedFragment
|
||||
}
|
||||
}
|
||||
|
||||
fragment isHousetrainedFragment on Dog {
|
||||
isHousetrained(atOtherHomes: $atOtherHomes)
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Variable \"$atOtherHomes\" is not defined by \
|
||||
\operation \
|
||||
\\"variableIsNotDefinedUsedInSingleFragment\"."
|
||||
, locations = [AST.Location 9 46]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects unused variables" $
|
||||
let queryString = [r|
|
||||
query variableUnused($atOtherHomes: Boolean) {
|
||||
dog {
|
||||
isHousetrained
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Variable \"$atOtherHomes\" is never used in operation \
|
||||
\\"variableUnused\"."
|
||||
, locations = [AST.Location 2 36]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects duplicate fields in input objects" $
|
||||
let queryString = [r|
|
||||
{
|
||||
findDog(complex: { name: "Fido", name: "Jack" }) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one input field named \"name\"."
|
||||
, locations = [AST.Location 3 36, AST.Location 3 50]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects undefined fields" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
meowVolume
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Cannot query field \"meowVolume\" on type \"Dog\"."
|
||||
, locations = [AST.Location 4 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects scalar fields with not empty selection set" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
barkVolume {
|
||||
sinceWhen
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Field \"barkVolume\" must not have a selection since \
|
||||
\type \"Int\" has no subfields."
|
||||
, locations = [AST.Location 4 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects field arguments missing in the type" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Unknown argument \"command\" on field \
|
||||
\\"Dog.doesKnowCommand\"."
|
||||
, locations = [AST.Location 4 35]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects directive arguments missing in the definition" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: true) @include(unless: false, if: true)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Unknown argument \"unless\" on directive \"@include\"."
|
||||
, locations = [AST.Location 4 63]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects undefined directives" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: true) @ignore(if: true)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message = "Unknown directive \"@ignore\"."
|
||||
, locations = [AST.Location 4 54]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects undefined input object fields" $
|
||||
let queryString = [r|
|
||||
{
|
||||
findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Field \"favoriteCookieFlavor\" is not defined \
|
||||
\by type \"DogData\"."
|
||||
, locations = [AST.Location 3 36]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects directives in invalid locations" $
|
||||
let queryString = [r|
|
||||
query @skip(if: $foo) {
|
||||
dog {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message = "Directive \"@skip\" may not be used on QUERY."
|
||||
, locations = [AST.Location 2 21]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects missing required input fields" $
|
||||
let queryString = [r|
|
||||
{
|
||||
findDog(complex: { name: null }) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Input field \"name\" of type \"DogData\" is required, \
|
||||
\but it was not provided."
|
||||
, locations = [AST.Location 3 34]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "finds corresponding subscription fragment" $
|
||||
let queryString = [r|
|
||||
subscription sub {
|
||||
...anotherSubscription
|
||||
...multipleSubscriptions
|
||||
}
|
||||
fragment multipleSubscriptions on Subscription {
|
||||
newMessage {
|
||||
body
|
||||
}
|
||||
disallowedSecondRootField {
|
||||
sender
|
||||
}
|
||||
}
|
||||
fragment anotherSubscription on Subscription {
|
||||
newMessage {
|
||||
body
|
||||
sender
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Subscription \"sub\" must select only one top level \
|
||||
\field."
|
||||
, locations = [AST.Location 2 15]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
Loading…
Reference in New Issue