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
|
and this project adheres to
|
||||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
[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
|
## [0.11.0.0] - 2020-11-07
|
||||||
### Changed
|
### Changed
|
||||||
- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
|
- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
|
||||||
|
@ -400,6 +413,7 @@ and this project adheres to
|
||||||
### Added
|
### Added
|
||||||
- Data types for the GraphQL language.
|
- 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.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.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
|
[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)
|
[![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)
|
[![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
|
See https://www.caraus.tech/projects/pub-graphql.
|
||||||
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.
|
|
||||||
|
|
||||||
## State of the work
|
Report issues on the
|
||||||
|
[bug tracker](https://www.caraus.tech/projects/pub-graphql/issues).
|
||||||
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
|
|
||||||
|
|
||||||
API documentation is available through
|
API documentation is available through
|
||||||
[Hackage](https://hackage.haskell.org/package/graphql).
|
[Hackage](https://hackage.haskell.org/package/graphql).
|
||||||
|
|
|
@ -4,10 +4,10 @@ cabal-version: 2.2
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: c89b0164372b6e02e4f338d3865dd6bb9dfd1a4475f25d808450480d73f94f91
|
-- hash: 15a0880180192f918ba0bd3b3e955c57232f1efe8993745d505fcb6e1aab1451
|
||||||
|
|
||||||
name: graphql
|
name: graphql
|
||||||
version: 0.11.0.0
|
version: 0.11.1.0
|
||||||
synopsis: Haskell GraphQL implementation
|
synopsis: Haskell GraphQL implementation
|
||||||
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||||
category: Language
|
category: Language
|
||||||
|
@ -17,7 +17,7 @@ author: Danny Navarro <j@dannynavarro.net>,
|
||||||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||||
maintainer: belka@caraus.de
|
maintainer: belka@caraus.de
|
||||||
copyright: (c) 2019-2020 Eugen Wissner,
|
copyright: (c) 2019-2021 Eugen Wissner,
|
||||||
(c) 2015-2017 J. Daniel Navarro
|
(c) 2015-2017 J. Daniel Navarro
|
||||||
license: MPL-2.0 AND BSD-3-Clause
|
license: MPL-2.0 AND BSD-3-Clause
|
||||||
license-files: LICENSE,
|
license-files: LICENSE,
|
||||||
|
@ -78,6 +78,7 @@ test-suite graphql-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Language.GraphQL.AST.DocumentSpec
|
||||||
Language.GraphQL.AST.EncoderSpec
|
Language.GraphQL.AST.EncoderSpec
|
||||||
Language.GraphQL.AST.LexerSpec
|
Language.GraphQL.AST.LexerSpec
|
||||||
Language.GraphQL.AST.ParserSpec
|
Language.GraphQL.AST.ParserSpec
|
||||||
|
@ -85,7 +86,7 @@ test-suite graphql-test
|
||||||
Language.GraphQL.Execute.CoerceSpec
|
Language.GraphQL.Execute.CoerceSpec
|
||||||
Language.GraphQL.ExecuteSpec
|
Language.GraphQL.ExecuteSpec
|
||||||
Language.GraphQL.Type.OutSpec
|
Language.GraphQL.Type.OutSpec
|
||||||
Language.GraphQL.ValidateSpec
|
Language.GraphQL.Validate.RulesSpec
|
||||||
Test.DirectiveSpec
|
Test.DirectiveSpec
|
||||||
Test.FragmentSpec
|
Test.FragmentSpec
|
||||||
Test.RootOperationSpec
|
Test.RootOperationSpec
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
name: graphql
|
name: graphql
|
||||||
version: 0.11.0.0
|
version: 0.11.1.0
|
||||||
synopsis: Haskell GraphQL implementation
|
synopsis: Haskell GraphQL implementation
|
||||||
description:
|
description:
|
||||||
Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||||
|
@ -11,7 +11,7 @@ category: Language
|
||||||
license: MPL-2.0 AND BSD-3-Clause
|
license: MPL-2.0 AND BSD-3-Clause
|
||||||
|
|
||||||
copyright:
|
copyright:
|
||||||
- (c) 2019-2020 Eugen Wissner
|
- (c) 2019-2021 Eugen Wissner
|
||||||
- (c) 2015-2017 J. Daniel Navarro
|
- (c) 2015-2017 J. Daniel Navarro
|
||||||
author:
|
author:
|
||||||
- Danny Navarro <j@dannynavarro.net>
|
- Danny Navarro <j@dannynavarro.net>
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE Safe #-}
|
{-# LANGUAGE Safe #-}
|
||||||
|
@ -47,11 +48,15 @@ module Language.GraphQL.AST.Document
|
||||||
, UnionMemberTypes(..)
|
, UnionMemberTypes(..)
|
||||||
, Value(..)
|
, Value(..)
|
||||||
, VariableDefinition(..)
|
, VariableDefinition(..)
|
||||||
|
, escape
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Data.Char (ord)
|
||||||
import Data.Foldable (toList)
|
import Data.Foldable (toList)
|
||||||
import Data.Int (Int32)
|
import Data.Int (Int32)
|
||||||
|
import Data.List (intercalate)
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
|
import Numeric (showFloat, showHex)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
|
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
|
||||||
|
@ -79,7 +84,10 @@ instance Ord Location where
|
||||||
data Node a = Node
|
data Node a = Node
|
||||||
{ node :: a
|
{ node :: a
|
||||||
, location :: Location
|
, location :: Location
|
||||||
} deriving (Eq, Show)
|
} deriving Eq
|
||||||
|
|
||||||
|
instance Show a => Show (Node a) where
|
||||||
|
show Node{ node } = show node
|
||||||
|
|
||||||
instance Functor Node where
|
instance Functor Node where
|
||||||
fmap f Node{..} = Node (f node) location
|
fmap f Node{..} = Node (f node) location
|
||||||
|
@ -218,6 +226,28 @@ type TypeCondition = Name
|
||||||
|
|
||||||
-- ** Input Values
|
-- ** 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).
|
-- | Input value (literal or variable).
|
||||||
data Value
|
data Value
|
||||||
= Variable Name
|
= Variable Name
|
||||||
|
@ -229,7 +259,19 @@ data Value
|
||||||
| Enum Name
|
| Enum Name
|
||||||
| List [Value]
|
| List [Value]
|
||||||
| Object [ObjectField 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.
|
-- | Constant input value.
|
||||||
data ConstValue
|
data ConstValue
|
||||||
|
@ -241,7 +283,18 @@ data ConstValue
|
||||||
| ConstEnum Name
|
| ConstEnum Name
|
||||||
| ConstList [ConstValue]
|
| ConstList [ConstValue]
|
||||||
| ConstObject [ObjectField 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.
|
-- | Key-value pair.
|
||||||
--
|
--
|
||||||
|
@ -250,7 +303,13 @@ data ObjectField a = ObjectField
|
||||||
{ name :: Name
|
{ name :: Name
|
||||||
, value :: Node a
|
, value :: Node a
|
||||||
, location :: Location
|
, 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
|
-- ** Variables
|
||||||
|
|
||||||
|
@ -281,7 +340,12 @@ data Type
|
||||||
= TypeNamed Name
|
= TypeNamed Name
|
||||||
| TypeList Type
|
| TypeList Type
|
||||||
| TypeNonNull NonNullType
|
| 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.
|
-- | Represents type names.
|
||||||
type NamedType = Name
|
type NamedType = Name
|
||||||
|
@ -290,7 +354,11 @@ type NamedType = Name
|
||||||
data NonNullType
|
data NonNullType
|
||||||
= NonNullTypeNamed Name
|
= NonNullTypeNamed Name
|
||||||
| NonNullTypeList Type
|
| NonNullTypeList Type
|
||||||
deriving (Eq, Show)
|
deriving Eq
|
||||||
|
|
||||||
|
instance Show NonNullType where
|
||||||
|
show (NonNullTypeNamed typeName) = '!' : Text.unpack typeName
|
||||||
|
show (NonNullTypeList listType) = concat ["![", show listType, "]"]
|
||||||
|
|
||||||
-- ** Directives
|
-- ** Directives
|
||||||
|
|
||||||
|
|
|
@ -16,7 +16,6 @@ module Language.GraphQL.AST.Encoder
|
||||||
, value
|
, value
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Char (ord)
|
|
||||||
import Data.Foldable (fold)
|
import Data.Foldable (fold)
|
||||||
import qualified Data.List.NonEmpty as NonEmpty
|
import qualified Data.List.NonEmpty as NonEmpty
|
||||||
import Data.Text (Text)
|
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 qualified Data.Text.Lazy as Lazy.Text
|
||||||
import Data.Text.Lazy.Builder (Builder)
|
import Data.Text.Lazy.Builder (Builder)
|
||||||
import qualified Data.Text.Lazy.Builder as Builder
|
import qualified Data.Text.Lazy.Builder as Builder
|
||||||
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
|
import Data.Text.Lazy.Builder.Int (decimal)
|
||||||
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
||||||
import qualified Language.GraphQL.AST.Document as Full
|
import qualified Language.GraphQL.AST.Document as Full
|
||||||
|
|
||||||
|
@ -234,11 +233,12 @@ quote :: Builder.Builder
|
||||||
quote = Builder.singleton '\"'
|
quote = Builder.singleton '\"'
|
||||||
|
|
||||||
oneLine :: Text -> Builder
|
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 :: Formatter -> Text -> Lazy.Text
|
||||||
stringValue Minified string = Builder.toLazyText
|
stringValue Minified string = Builder.toLazyText $ oneLine string
|
||||||
$ quote <> Text.foldr (mappend . escape) quote string
|
|
||||||
stringValue (Pretty indentation) string =
|
stringValue (Pretty indentation) string =
|
||||||
if hasEscaped string
|
if hasEscaped string
|
||||||
then stringValue Minified string
|
then stringValue Minified string
|
||||||
|
@ -266,21 +266,6 @@ stringValue (Pretty indentation) string =
|
||||||
= Builder.fromLazyText (indent (indentation + 1))
|
= Builder.fromLazyText (indent (indentation + 1))
|
||||||
<> line' <> newline <> acc
|
<> 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 -> [Full.Value] -> Lazy.Text
|
||||||
listValue formatter = bracketsCommas formatter $ value formatter
|
listValue formatter = bracketsCommas formatter $ value formatter
|
||||||
|
|
||||||
|
|
|
@ -22,6 +22,7 @@ import Data.HashMap.Strict (HashMap)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.String (IsString(..))
|
import Data.String (IsString(..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text as Text
|
||||||
import Language.GraphQL.AST (Name)
|
import Language.GraphQL.AST (Name)
|
||||||
import Prelude hiding (id)
|
import Prelude hiding (id)
|
||||||
|
|
||||||
|
@ -63,6 +64,9 @@ data ScalarType = ScalarType Name (Maybe Text)
|
||||||
instance Eq ScalarType where
|
instance Eq ScalarType where
|
||||||
(ScalarType this _) == (ScalarType that _) = this == that
|
(ScalarType this _) == (ScalarType that _) = this == that
|
||||||
|
|
||||||
|
instance Show ScalarType where
|
||||||
|
show (ScalarType typeName _) = Text.unpack typeName
|
||||||
|
|
||||||
-- | Enum type definition.
|
-- | Enum type definition.
|
||||||
--
|
--
|
||||||
-- Some leaf values of requests and input values are Enums. GraphQL serializes
|
-- 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
|
instance Eq EnumType where
|
||||||
(EnumType this _ _) == (EnumType that _ _) = this == that
|
(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'.
|
-- | Enum value is a single member of an 'EnumType'.
|
||||||
newtype EnumValue = EnumValue (Maybe Text)
|
newtype EnumValue = EnumValue (Maybe Text)
|
||||||
|
|
||||||
|
|
|
@ -24,6 +24,7 @@ module Language.GraphQL.Type.In
|
||||||
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text as Text
|
||||||
import Language.GraphQL.AST.Document (Name)
|
import Language.GraphQL.AST.Document (Name)
|
||||||
import qualified Language.GraphQL.Type.Definition as Definition
|
import qualified Language.GraphQL.Type.Definition as Definition
|
||||||
|
|
||||||
|
@ -40,6 +41,9 @@ data InputObjectType = InputObjectType
|
||||||
instance Eq InputObjectType where
|
instance Eq InputObjectType where
|
||||||
(InputObjectType this _ _) == (InputObjectType that _ _) = this == that
|
(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.
|
-- | These types may be used as input types for arguments and directives.
|
||||||
--
|
--
|
||||||
-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
|
-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
|
||||||
|
@ -56,6 +60,16 @@ data Type
|
||||||
| NonNullListType Type
|
| NonNullListType Type
|
||||||
deriving Eq
|
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.
|
-- | Field argument definition.
|
||||||
data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
|
data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
|
||||||
|
|
||||||
|
|
|
@ -14,11 +14,14 @@ module Language.GraphQL.Type.Internal
|
||||||
, Type(..)
|
, Type(..)
|
||||||
, directives
|
, directives
|
||||||
, doesFragmentTypeApply
|
, doesFragmentTypeApply
|
||||||
|
, implementations
|
||||||
, instanceOf
|
, instanceOf
|
||||||
|
, lookupCompositeField
|
||||||
, lookupInputType
|
, lookupInputType
|
||||||
, lookupTypeCondition
|
, lookupTypeCondition
|
||||||
, lookupTypeField
|
, lookupTypeField
|
||||||
, mutation
|
, mutation
|
||||||
|
, outToComposite
|
||||||
, subscription
|
, subscription
|
||||||
, query
|
, query
|
||||||
, types
|
, types
|
||||||
|
@ -62,26 +65,31 @@ data Schema m = Schema
|
||||||
(Maybe (Out.ObjectType m))
|
(Maybe (Out.ObjectType m))
|
||||||
Directives
|
Directives
|
||||||
(HashMap Full.Name (Type m))
|
(HashMap Full.Name (Type m))
|
||||||
|
(HashMap Full.Name [Type m])
|
||||||
|
|
||||||
-- | Schema query type.
|
-- | Schema query type.
|
||||||
query :: forall m. Schema m -> Out.ObjectType m
|
query :: forall m. Schema m -> Out.ObjectType m
|
||||||
query (Schema query' _ _ _ _) = query'
|
query (Schema query' _ _ _ _ _) = query'
|
||||||
|
|
||||||
-- | Schema mutation type.
|
-- | Schema mutation type.
|
||||||
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||||
mutation (Schema _ mutation' _ _ _) = mutation'
|
mutation (Schema _ mutation' _ _ _ _) = mutation'
|
||||||
|
|
||||||
-- | Schema subscription type.
|
-- | Schema subscription type.
|
||||||
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||||
subscription (Schema _ _ subscription' _ _) = subscription'
|
subscription (Schema _ _ subscription' _ _ _) = subscription'
|
||||||
|
|
||||||
-- | Schema directive definitions.
|
-- | Schema directive definitions.
|
||||||
directives :: forall m. Schema m -> Directives
|
directives :: forall m. Schema m -> Directives
|
||||||
directives (Schema _ _ _ directives' _) = directives'
|
directives (Schema _ _ _ directives' _ _) = directives'
|
||||||
|
|
||||||
-- | Types referenced by the schema.
|
-- | Types referenced by the schema.
|
||||||
types :: forall m. Schema m -> HashMap Full.Name (Type m)
|
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.
|
-- | These types may describe the parent context of a selection set.
|
||||||
data CompositeType m
|
data CompositeType m
|
||||||
|
@ -160,12 +168,16 @@ lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types'
|
||||||
<$> lookupInputType nonNull types'
|
<$> lookupInputType nonNull types'
|
||||||
|
|
||||||
lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)
|
lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)
|
||||||
lookupTypeField fieldName = \case
|
lookupTypeField fieldName outputType =
|
||||||
Out.ObjectBaseType objectType ->
|
outToComposite outputType >>= lookupCompositeField fieldName
|
||||||
objectChild objectType
|
|
||||||
Out.InterfaceBaseType interfaceType ->
|
lookupCompositeField :: forall a
|
||||||
interfaceChild interfaceType
|
. Full.Name
|
||||||
Out.ListBaseType listType -> lookupTypeField fieldName listType
|
-> CompositeType a
|
||||||
|
-> Maybe (Out.Field a)
|
||||||
|
lookupCompositeField fieldName = \case
|
||||||
|
CompositeObjectType objectType -> objectChild objectType
|
||||||
|
CompositeInterfaceType interfaceType -> interfaceChild interfaceType
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
where
|
where
|
||||||
objectChild (Out.ObjectType _ _ _ resolvers) =
|
objectChild (Out.ObjectType _ _ _ resolvers) =
|
||||||
|
@ -174,3 +186,12 @@ lookupTypeField fieldName = \case
|
||||||
HashMap.lookup fieldName fields
|
HashMap.lookup fieldName fields
|
||||||
resolverType (Out.ValueResolver objectField _) = objectField
|
resolverType (Out.ValueResolver objectField _) = objectField
|
||||||
resolverType (Out.EventStreamResolver 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 qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text as Text
|
||||||
import Language.GraphQL.AST (Name)
|
import Language.GraphQL.AST (Name)
|
||||||
import Language.GraphQL.Type.Definition
|
import Language.GraphQL.Type.Definition
|
||||||
import qualified Language.GraphQL.Type.In as In
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
@ -52,6 +53,9 @@ data ObjectType m = ObjectType
|
||||||
instance forall a. Eq (ObjectType a) where
|
instance forall a. Eq (ObjectType a) where
|
||||||
(ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
|
(ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
|
||||||
|
|
||||||
|
instance forall a. Show (ObjectType a) where
|
||||||
|
show (ObjectType typeName _ _ _) = Text.unpack typeName
|
||||||
|
|
||||||
-- | Interface Type Definition.
|
-- | Interface Type Definition.
|
||||||
--
|
--
|
||||||
-- When a field can return one of a heterogeneous set of types, a Interface type
|
-- 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
|
instance forall a. Eq (InterfaceType a) where
|
||||||
(InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that
|
(InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that
|
||||||
|
|
||||||
|
instance forall a. Show (InterfaceType a) where
|
||||||
|
show (InterfaceType typeName _ _ _) = Text.unpack typeName
|
||||||
|
|
||||||
-- | Union Type Definition.
|
-- | Union Type Definition.
|
||||||
--
|
--
|
||||||
-- When a field can return one of a heterogeneous set of types, a Union type is
|
-- 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
|
instance forall a. Eq (UnionType a) where
|
||||||
(UnionType this _ _) == (UnionType that _ _) = this == that
|
(UnionType this _ _) == (UnionType that _ _) = this == that
|
||||||
|
|
||||||
|
instance forall a. Show (UnionType a) where
|
||||||
|
show (UnionType typeName _ _) = Text.unpack typeName
|
||||||
|
|
||||||
-- | Output object field definition.
|
-- | Output object field definition.
|
||||||
data Field m = Field
|
data Field m = Field
|
||||||
(Maybe Text) -- ^ Description.
|
(Maybe Text) -- ^ Description.
|
||||||
|
@ -98,6 +108,20 @@ data Type m
|
||||||
| NonNullListType (Type m)
|
| NonNullListType (Type m)
|
||||||
deriving Eq
|
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'.
|
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
|
||||||
pattern ScalarBaseType :: forall m. ScalarType -> Type m
|
pattern ScalarBaseType :: forall m. ScalarType -> Type m
|
||||||
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
|
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
|
||||||
|
|
|
@ -23,6 +23,7 @@ import Language.GraphQL.Type.Internal
|
||||||
, Schema
|
, Schema
|
||||||
, Type(..)
|
, Type(..)
|
||||||
, directives
|
, directives
|
||||||
|
, implementations
|
||||||
, mutation
|
, mutation
|
||||||
, subscription
|
, subscription
|
||||||
, query
|
, query
|
||||||
|
@ -41,9 +42,11 @@ schema :: forall m
|
||||||
-> Directives -- ^ Directive definitions.
|
-> Directives -- ^ Directive definitions.
|
||||||
-> Schema m -- ^ Schema.
|
-> Schema m -- ^ Schema.
|
||||||
schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
|
schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
|
||||||
Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes
|
Internal.Schema queryRoot mutationRoot subscriptionRoot
|
||||||
|
allDirectives collectedTypes collectedImplementations
|
||||||
where
|
where
|
||||||
collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot
|
collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot
|
||||||
|
collectedImplementations = collectImplementations collectedTypes
|
||||||
allDirectives = HashMap.union directiveDefinitions defaultDirectives
|
allDirectives = HashMap.union directiveDefinitions defaultDirectives
|
||||||
defaultDirectives = HashMap.fromList
|
defaultDirectives = HashMap.fromList
|
||||||
[ ("skip", skipDirective)
|
[ ("skip", skipDirective)
|
||||||
|
@ -153,3 +156,20 @@ collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
|
||||||
polymorphicTraverser interfaces fields
|
polymorphicTraverser interfaces fields
|
||||||
= flip (foldr visitFields) fields
|
= flip (foldr visitFields) fields
|
||||||
. flip (foldr traverseInterfaceType) interfaces
|
. 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'
|
directives context rule scalarLocation directives'
|
||||||
Full.ObjectTypeDefinition _ _ _ directives' fields
|
Full.ObjectTypeDefinition _ _ _ directives' fields
|
||||||
-> directives context rule objectLocation directives'
|
-> directives context rule objectLocation directives'
|
||||||
>< foldMap (fieldDefinition context rule) fields
|
>< foldMap (fieldDefinition context rule) fields
|
||||||
Full.InterfaceTypeDefinition _ _ directives' fields
|
Full.InterfaceTypeDefinition _ _ directives' fields
|
||||||
-> directives context rule interfaceLocation directives'
|
-> directives context rule interfaceLocation directives'
|
||||||
>< foldMap (fieldDefinition context rule) fields
|
>< foldMap (fieldDefinition context rule) fields
|
||||||
|
|
|
@ -3,6 +3,7 @@
|
||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
@ -24,6 +25,8 @@ module Language.GraphQL.Validate.Rules
|
||||||
, noUndefinedVariablesRule
|
, noUndefinedVariablesRule
|
||||||
, noUnusedFragmentsRule
|
, noUnusedFragmentsRule
|
||||||
, noUnusedVariablesRule
|
, noUnusedVariablesRule
|
||||||
|
, overlappingFieldsCanBeMergedRule
|
||||||
|
, possibleFragmentSpreadsRule
|
||||||
, providedRequiredInputFieldsRule
|
, providedRequiredInputFieldsRule
|
||||||
, providedRequiredArgumentsRule
|
, providedRequiredArgumentsRule
|
||||||
, scalarLeafsRule
|
, scalarLeafsRule
|
||||||
|
@ -35,22 +38,24 @@ module Language.GraphQL.Validate.Rules
|
||||||
, uniqueInputFieldNamesRule
|
, uniqueInputFieldNamesRule
|
||||||
, uniqueOperationNamesRule
|
, uniqueOperationNamesRule
|
||||||
, uniqueVariableNamesRule
|
, uniqueVariableNamesRule
|
||||||
|
, valuesOfCorrectTypeRule
|
||||||
|
, variablesInAllowedPositionRule
|
||||||
, variablesAreInputTypesRule
|
, variablesAreInputTypesRule
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad ((>=>), foldM)
|
import Control.Monad ((>=>), foldM)
|
||||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
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 Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
||||||
import Data.Bifunctor (first)
|
import Data.Bifunctor (first)
|
||||||
import Data.Foldable (find, toList)
|
import Data.Foldable (find, fold, foldl', toList)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.HashSet (HashSet)
|
import Data.HashSet (HashSet)
|
||||||
import qualified Data.HashSet as HashSet
|
import qualified Data.HashSet as HashSet
|
||||||
import Data.List (groupBy, sortBy, sortOn)
|
import Data.List (groupBy, sortBy, sortOn)
|
||||||
import Data.Maybe (isNothing, mapMaybe)
|
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
import Data.Ord (comparing)
|
import Data.Ord (comparing)
|
||||||
import Data.Sequence (Seq(..), (|>))
|
import Data.Sequence (Seq(..), (|>))
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
|
@ -80,6 +85,7 @@ specifiedRules =
|
||||||
-- Fields
|
-- Fields
|
||||||
, fieldsOnCorrectTypeRule
|
, fieldsOnCorrectTypeRule
|
||||||
, scalarLeafsRule
|
, scalarLeafsRule
|
||||||
|
, overlappingFieldsCanBeMergedRule
|
||||||
-- Arguments.
|
-- Arguments.
|
||||||
, knownArgumentNamesRule
|
, knownArgumentNamesRule
|
||||||
, uniqueArgumentNamesRule
|
, uniqueArgumentNamesRule
|
||||||
|
@ -91,7 +97,9 @@ specifiedRules =
|
||||||
, noUnusedFragmentsRule
|
, noUnusedFragmentsRule
|
||||||
, fragmentSpreadTargetDefinedRule
|
, fragmentSpreadTargetDefinedRule
|
||||||
, noFragmentCyclesRule
|
, noFragmentCyclesRule
|
||||||
|
, possibleFragmentSpreadsRule
|
||||||
-- Values
|
-- Values
|
||||||
|
, valuesOfCorrectTypeRule
|
||||||
, knownInputFieldNamesRule
|
, knownInputFieldNamesRule
|
||||||
, uniqueInputFieldNamesRule
|
, uniqueInputFieldNamesRule
|
||||||
, providedRequiredInputFieldsRule
|
, providedRequiredInputFieldsRule
|
||||||
|
@ -104,6 +112,7 @@ specifiedRules =
|
||||||
, variablesAreInputTypesRule
|
, variablesAreInputTypesRule
|
||||||
, noUndefinedVariablesRule
|
, noUndefinedVariablesRule
|
||||||
, noUnusedVariablesRule
|
, noUnusedVariablesRule
|
||||||
|
, variablesInAllowedPositionRule
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Definition must be OperationDefinition or FragmentDefinition.
|
-- | Definition must be OperationDefinition or FragmentDefinition.
|
||||||
|
@ -320,10 +329,8 @@ fragmentSpreadTypeExistenceRule :: forall m. Rule m
|
||||||
fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
|
fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
|
||||||
Full.FragmentSpreadSelection fragmentSelection
|
Full.FragmentSpreadSelection fragmentSelection
|
||||||
| Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do
|
| 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
|
types' <- asks $ Schema.types . schema
|
||||||
|
typeCondition <- findSpreadTarget fragmentName
|
||||||
case HashMap.lookup typeCondition types' of
|
case HashMap.lookup typeCondition types' of
|
||||||
Nothing -> pure $ Error
|
Nothing -> pure $ Error
|
||||||
{ message = spreadError fragmentName typeCondition
|
{ message = spreadError fragmentName typeCondition
|
||||||
|
@ -342,10 +349,6 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
|
||||||
Just _ -> lift mempty
|
Just _ -> lift mempty
|
||||||
_ -> lift mempty
|
_ -> lift mempty
|
||||||
where
|
where
|
||||||
extractTypeCondition (viewFragment -> Just fragmentDefinition) =
|
|
||||||
let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition
|
|
||||||
in Just typeCondition
|
|
||||||
extractTypeCondition _ = Nothing
|
|
||||||
spreadError fragmentName typeCondition = concat
|
spreadError fragmentName typeCondition = concat
|
||||||
[ "Fragment \""
|
[ "Fragment \""
|
||||||
, Text.unpack fragmentName
|
, Text.unpack fragmentName
|
||||||
|
@ -451,8 +454,7 @@ filterSelections applyFilter selections
|
||||||
noFragmentCyclesRule :: forall m. Rule m
|
noFragmentCyclesRule :: forall m. Rule m
|
||||||
noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
||||||
Full.FragmentDefinition fragmentName _ _ selections location' -> do
|
Full.FragmentDefinition fragmentName _ _ selections location' -> do
|
||||||
state <- evalStateT (collectFields selections)
|
state <- evalStateT (collectCycles selections) (0, fragmentName)
|
||||||
(0, fragmentName)
|
|
||||||
let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)
|
let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)
|
||||||
case reverse spreadPath of
|
case reverse spreadPath of
|
||||||
x : _ | x == fragmentName -> pure $ Error
|
x : _ | x == fragmentName -> pure $ Error
|
||||||
|
@ -467,10 +469,10 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
||||||
}
|
}
|
||||||
_ -> lift mempty
|
_ -> lift mempty
|
||||||
where
|
where
|
||||||
collectFields :: Traversable t
|
collectCycles :: Traversable t
|
||||||
=> t Full.Selection
|
=> t Full.Selection
|
||||||
-> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
|
-> 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
|
forEach accumulator = \case
|
||||||
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
|
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
|
||||||
Full.InlineFragmentSelection fragmentSelection ->
|
Full.InlineFragmentSelection fragmentSelection ->
|
||||||
|
@ -487,15 +489,15 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
||||||
then pure newAccumulator
|
then pure newAccumulator
|
||||||
else collectFromSpread fragmentName newAccumulator
|
else collectFromSpread fragmentName newAccumulator
|
||||||
forInline accumulator (Full.InlineFragment _ _ selections _) =
|
forInline accumulator (Full.InlineFragment _ _ selections _) =
|
||||||
(accumulator <>) <$> collectFields selections
|
(accumulator <>) <$> collectCycles selections
|
||||||
forField accumulator (Full.Field _ _ _ _ selections _) =
|
forField accumulator (Full.Field _ _ _ _ selections _) =
|
||||||
(accumulator <>) <$> collectFields selections
|
(accumulator <>) <$> collectCycles selections
|
||||||
collectFromSpread fragmentName accumulator = do
|
collectFromSpread fragmentName accumulator = do
|
||||||
ast' <- lift $ asks ast
|
ast' <- lift $ asks ast
|
||||||
case findFragmentDefinition fragmentName ast' of
|
case findFragmentDefinition fragmentName ast' of
|
||||||
Nothing -> pure accumulator
|
Nothing -> pure accumulator
|
||||||
Just (Full.FragmentDefinition _ _ _ selections _) ->
|
Just (Full.FragmentDefinition _ _ _ selections _) ->
|
||||||
(accumulator <>) <$> collectFields selections
|
(accumulator <>) <$> collectCycles selections
|
||||||
|
|
||||||
findFragmentDefinition :: Text
|
findFragmentDefinition :: Text
|
||||||
-> NonEmpty Full.Definition
|
-> NonEmpty Full.Definition
|
||||||
|
@ -531,15 +533,22 @@ uniqueDirectiveNamesRule = DirectivesRule
|
||||||
extract (Full.Directive directiveName _ location') =
|
extract (Full.Directive directiveName _ location') =
|
||||||
(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
|
filterDuplicates extract nodeType = Seq.fromList
|
||||||
. fmap makeError
|
. fmap makeError
|
||||||
. filter ((> 1) . length)
|
. filter ((> 1) . length)
|
||||||
. groupBy equalByName
|
. groupSorted getName
|
||||||
. sortOn getName
|
|
||||||
where
|
where
|
||||||
getName = fst . extract
|
getName = fst . extract
|
||||||
equalByName lhs rhs = getName lhs == getName rhs
|
|
||||||
makeError directives' = Error
|
makeError directives' = Error
|
||||||
{ message = makeMessage $ head directives'
|
{ message = makeMessage $ head directives'
|
||||||
, locations = snd . extract <$> directives'
|
, locations = snd . extract <$> directives'
|
||||||
|
@ -647,12 +656,9 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
|
||||||
lift $ lift $ mapArguments arguments <> mapDirectives directives'
|
lift $ lift $ mapArguments arguments <> mapDirectives directives'
|
||||||
variableFilter (Full.FragmentSpreadSelection spread)
|
variableFilter (Full.FragmentSpreadSelection spread)
|
||||||
| Full.FragmentSpread fragmentName _ _ <- spread = do
|
| Full.FragmentSpread fragmentName _ _ <- spread = do
|
||||||
definitions <- lift $ asks ast
|
nonVisitedFragmentDefinition <- visitFragmentDefinition fragmentName
|
||||||
visited <- gets (HashSet.member fragmentName)
|
case nonVisitedFragmentDefinition of
|
||||||
modify (HashSet.insert fragmentName)
|
Just fragmentDefinition -> diveIntoSpread fragmentDefinition
|
||||||
case find (isSpreadTarget fragmentName) definitions of
|
|
||||||
Just (viewFragment -> Just fragmentDefinition)
|
|
||||||
| not visited -> diveIntoSpread fragmentDefinition
|
|
||||||
_ -> lift $ lift mempty
|
_ -> lift $ lift mempty
|
||||||
diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _)
|
diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _)
|
||||||
= filterSelections' selections
|
= filterSelections' selections
|
||||||
|
@ -710,7 +716,7 @@ fieldsOnCorrectTypeRule = FieldRule fieldRule
|
||||||
fieldRule parentType (Full.Field _ fieldName _ _ _ location')
|
fieldRule parentType (Full.Field _ fieldName _ _ _ location')
|
||||||
| Just objectType <- parentType
|
| Just objectType <- parentType
|
||||||
, Nothing <- Type.lookupTypeField fieldName objectType
|
, Nothing <- Type.lookupTypeField fieldName objectType
|
||||||
, Just typeName <- compositeTypeName objectType = pure $ Error
|
, Just typeName <- typeNameIfComposite objectType = pure $ Error
|
||||||
{ message = errorMessage fieldName typeName
|
{ message = errorMessage fieldName typeName
|
||||||
, locations = [location']
|
, locations = [location']
|
||||||
}
|
}
|
||||||
|
@ -723,20 +729,17 @@ fieldsOnCorrectTypeRule = FieldRule fieldRule
|
||||||
, "\"."
|
, "\"."
|
||||||
]
|
]
|
||||||
|
|
||||||
compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name
|
compositeTypeName :: forall m. Type.CompositeType m -> Full.Name
|
||||||
compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
|
compositeTypeName (Type.CompositeObjectType (Out.ObjectType typeName _ _ _)) =
|
||||||
Just typeName
|
typeName
|
||||||
compositeTypeName (Out.InterfaceBaseType interfaceType) =
|
compositeTypeName (Type.CompositeInterfaceType interfaceType) =
|
||||||
let Out.InterfaceType typeName _ _ _ = interfaceType
|
let Out.InterfaceType typeName _ _ _ = interfaceType
|
||||||
in Just typeName
|
in typeName
|
||||||
compositeTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) =
|
compositeTypeName (Type.CompositeUnionType (Out.UnionType typeName _ _)) =
|
||||||
Just typeName
|
typeName
|
||||||
compositeTypeName (Out.ScalarBaseType _) =
|
|
||||||
Nothing
|
typeNameIfComposite :: forall m. Out.Type m -> Maybe Full.Name
|
||||||
compositeTypeName (Out.EnumBaseType _) =
|
typeNameIfComposite = fmap compositeTypeName . Type.outToComposite
|
||||||
Nothing
|
|
||||||
compositeTypeName (Out.ListBaseType wrappedType) =
|
|
||||||
compositeTypeName wrappedType
|
|
||||||
|
|
||||||
-- | Field selections on scalars or enums are never allowed, because they are
|
-- | Field selections on scalars or enums are never allowed, because they are
|
||||||
-- the leaf nodes of any GraphQL query.
|
-- the leaf nodes of any GraphQL query.
|
||||||
|
@ -794,7 +797,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
||||||
where
|
where
|
||||||
fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ _)
|
fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ _)
|
||||||
| Just typeField <- Type.lookupTypeField fieldName objectType
|
| Just typeField <- Type.lookupTypeField fieldName objectType
|
||||||
, Just typeName <- compositeTypeName objectType =
|
, Just typeName <- typeNameIfComposite objectType =
|
||||||
lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
|
lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
|
||||||
fieldRule _ _ = lift mempty
|
fieldRule _ _ = lift mempty
|
||||||
go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors
|
go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors
|
||||||
|
@ -1013,3 +1016,590 @@ providedRequiredInputFieldsRule = ValueRule go constGo
|
||||||
, Text.unpack typeName
|
, Text.unpack typeName
|
||||||
, "\" is required, but it was not provided."
|
, "\" 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:
|
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