Compare commits
8 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | 4b59da2fcb | |
Eugen Wissner | 7e78f98f09 | |
Eugen Wissner | eebad8a27f | |
Eugen Wissner | e6a6926e18 | |
Eugen Wissner | 7355533268 | |
Eugen Wissner | 54dbf1df16 | |
Eugen Wissner | 1a788a6261 | |
Eugen Wissner | c60dd98fc5 |
23
CHANGELOG.md
23
CHANGELOG.md
|
@ -6,7 +6,20 @@ 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/).
|
||||||
|
|
||||||
## [Unreleased]
|
## [0.10.0.0] - 2020-08-29
|
||||||
|
## Changed
|
||||||
|
- `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`.
|
||||||
|
- The `Location` argument of `AST.Document.Definition.ExecutableDefinition` was
|
||||||
|
moved to `OperationDefinition` and `FragmentDefinition` since these are the
|
||||||
|
actual elements that have a location in the document.
|
||||||
|
- `Validate.Rules` get the whole validation context (AST and schema).
|
||||||
|
|
||||||
|
## Added
|
||||||
|
- `Validate.Validation` contains data structures and functions used by the
|
||||||
|
validator and concretet rules.
|
||||||
|
- `Validate.Rules`: operation validation rules.
|
||||||
|
|
||||||
|
## [0.9.0.0] - 2020-07-24
|
||||||
## Fixed
|
## Fixed
|
||||||
- Location of a parse error is returned in a singleton array with key
|
- Location of a parse error is returned in a singleton array with key
|
||||||
`locations`.
|
`locations`.
|
||||||
|
@ -21,13 +34,14 @@ and this project adheres to
|
||||||
- `Error.Error` is an error representation with a message and source location.
|
- `Error.Error` is an error representation with a message and source location.
|
||||||
- `Error.Response` represents a result of running a GraphQL query.
|
- `Error.Response` represents a result of running a GraphQL query.
|
||||||
- `Type.Schema` exports `Type` which lists all types possible in the schema.
|
- `Type.Schema` exports `Type` which lists all types possible in the schema.
|
||||||
- Parsing subscriptions (the execution always fails yet).
|
- Parsing subscriptions.
|
||||||
- `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and
|
- `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and
|
||||||
`Type.Out.SourceEventStream` define subscription resolvers.
|
`Type.Out.SourceEventStream` define subscription resolvers.
|
||||||
- `Error.ResolverException` is an exception that can be thrown by (field value
|
- `Error.ResolverException` is an exception that can be thrown by (field value
|
||||||
and event stream) resolvers to signalize an error. Other exceptions will
|
and event stream) resolvers to signalize an error. Other exceptions will
|
||||||
escape.
|
escape.
|
||||||
- `Test.Hspec.GraphQL` contains some test helpers.
|
- `Test.Hspec.GraphQL` contains some test helpers.
|
||||||
|
- `Validate` contains the validator and standard rules.
|
||||||
|
|
||||||
## Changed
|
## Changed
|
||||||
- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
|
- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
|
||||||
|
@ -56,8 +70,6 @@ and this project adheres to
|
||||||
## Removed
|
## Removed
|
||||||
- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
|
- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
|
||||||
represents possible resolver configurations.
|
represents possible resolver configurations.
|
||||||
- `Type.Out.Resolver`: It . Resolvers are a
|
|
||||||
part of the fields and are called `Trans.ResolverT`.
|
|
||||||
- `Execute.executeWithName`. `Execute.execute` takes the operation name and
|
- `Execute.executeWithName`. `Execute.execute` takes the operation name and
|
||||||
completely replaces `executeWithName`.
|
completely replaces `executeWithName`.
|
||||||
|
|
||||||
|
@ -322,7 +334,8 @@ and this project adheres to
|
||||||
### Added
|
### Added
|
||||||
- Data types for the GraphQL language.
|
- Data types for the GraphQL language.
|
||||||
|
|
||||||
[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...HEAD
|
[0.10.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.9.0.0...v0.10.0.0
|
||||||
|
[0.9.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...v0.9.0.0
|
||||||
[0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0
|
[0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0
|
||||||
[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0
|
[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0
|
||||||
[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0
|
[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0
|
||||||
|
|
114
README.md
114
README.md
|
@ -1,10 +1,9 @@
|
||||||
# Haskell GraphQL
|
# GraphQL implementation in Haskell
|
||||||
|
|
||||||
[![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)
|
[![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)
|
||||||
[![Build Status](https://github.com/caraus-ecms/graphql/workflows/Haskell%20CI/badge.svg)](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22)
|
[![Build Status](https://github.com/caraus-ecms/graphql/workflows/Haskell%20CI/badge.svg)](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22)
|
||||||
[![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)
|
[![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)
|
||||||
|
[![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org)
|
||||||
GraphQL implementation in Haskell.
|
|
||||||
|
|
||||||
This implementation is relatively low-level by design, it doesn't provide any
|
This implementation is relatively low-level by design, it doesn't provide any
|
||||||
mappings between the GraphQL types and Haskell's type system and avoids
|
mappings between the GraphQL types and Haskell's type system and avoids
|
||||||
|
@ -13,12 +12,19 @@ be built on top of it.
|
||||||
|
|
||||||
## State of the work
|
## State of the work
|
||||||
|
|
||||||
For now this only provides a parser and a printer for the GraphQL query language
|
For now this library provides:
|
||||||
and allows to execute queries and mutations using the given schema, but without
|
|
||||||
the validation step. But the idea is to be a Haskell port of
|
- 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).
|
[`graphql-js`](https://github.com/graphql/graphql-js).
|
||||||
|
|
||||||
For the list of currently missing features see issues marked as
|
For a more precise list of currently missing features see issues marked as
|
||||||
"[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)".
|
"[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)".
|
||||||
|
|
||||||
## Documentation
|
## Documentation
|
||||||
|
@ -29,6 +35,100 @@ API documentation is available through
|
||||||
You'll also find a small tutorial with some examples under
|
You'll also find a small tutorial with some examples under
|
||||||
[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
|
[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
|
||||||
|
|
||||||
|
### Getting started
|
||||||
|
|
||||||
|
We start with a simple GraphQL API that provides us with some famous and less
|
||||||
|
famous cites.
|
||||||
|
|
||||||
|
```graphql
|
||||||
|
"""
|
||||||
|
Root Query type.
|
||||||
|
"""
|
||||||
|
type Query {
|
||||||
|
"""
|
||||||
|
Provides a cite.
|
||||||
|
"""
|
||||||
|
cite: String!
|
||||||
|
}
|
||||||
|
```
|
||||||
|
|
||||||
|
This is called a GraphQL schema, it defines all queries supported by the API.
|
||||||
|
`Query` is the root query type. Every GraphQL API should define a query type.
|
||||||
|
|
||||||
|
`Query` has a single field `cite` that returns a `String`. The `!` after the
|
||||||
|
type denotes that the returned value cannot be `Null`. GraphQL fields are
|
||||||
|
nullable by default.
|
||||||
|
|
||||||
|
To be able to work with this schema, we are going to implement it in Haskell.
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
import Control.Exception (SomeException)
|
||||||
|
import qualified Data.Aeson as Aeson
|
||||||
|
import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Language.GraphQL
|
||||||
|
import Language.GraphQL.Type
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
|
||||||
|
-- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions.
|
||||||
|
-- Our first schema supports only queries.
|
||||||
|
schema :: Schema IO
|
||||||
|
schema = Schema
|
||||||
|
{ query = queryType, mutation = Nothing, subscription = Nothing }
|
||||||
|
|
||||||
|
-- GraphQL distinguishes between input and output types. Input types are field
|
||||||
|
-- argument types and they are defined in Language.GraphQL.Type.In. Output types
|
||||||
|
-- are result types, they are defined in Language.GraphQL.Type.Out. Root types
|
||||||
|
-- are always object types.
|
||||||
|
--
|
||||||
|
-- Here we define a type "Query". The second argument is an optional
|
||||||
|
-- description, the third one is the list of interfaces implemented by the
|
||||||
|
-- object type. The last argument is a field map. Keys are field names, values
|
||||||
|
-- are field definitions and resolvers. Resolvers are the functions, where the
|
||||||
|
-- actual logic lives, they return values for the respective fields.
|
||||||
|
queryType :: Out.ObjectType IO
|
||||||
|
queryType = Out.ObjectType "Query" (Just "Root Query type.") []
|
||||||
|
$ HashMap.singleton "cite" citeResolver
|
||||||
|
where
|
||||||
|
-- 'ValueResolver' is a 'Resolver' data constructor, it combines a field
|
||||||
|
-- definition with its resolver function. This function resolves a value for
|
||||||
|
-- a field (as opposed to the 'EventStreamResolver' used by subscriptions).
|
||||||
|
-- Our resolver just returns a constant value.
|
||||||
|
citeResolver = ValueResolver citeField
|
||||||
|
$ pure "Piscis primum a capite foetat"
|
||||||
|
-- The first argument is an optional field description. The second one is
|
||||||
|
-- the field type and the third one is for arguments (we have none in this
|
||||||
|
-- example).
|
||||||
|
--
|
||||||
|
-- GraphQL has named and wrapping types. String is a scalar, named type.
|
||||||
|
-- Named types are nullable by default. To make our "cite" field
|
||||||
|
-- non-nullable, we wrap it in the wrapping type, Non-Null.
|
||||||
|
citeField = Out.Field
|
||||||
|
(Just "Provides a cite.") (Out.NonNullScalarType string) HashMap.empty
|
||||||
|
|
||||||
|
-- Now we can execute a query. Since our schema defines only one field,
|
||||||
|
-- everything we can do is to ask to resolve it and give back the result.
|
||||||
|
-- Since subscriptions don't return plain values, the 'graphql' function returns
|
||||||
|
-- an 'Either'. 'Left' is for subscriptions, 'Right' is for queries and
|
||||||
|
-- mutations.
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
Right result <- graphql schema "{ cite }"
|
||||||
|
ByteString.Lazy.Char8.putStrLn $ Aeson.encode result
|
||||||
|
```
|
||||||
|
|
||||||
|
Executing this query produces the following JSON:
|
||||||
|
|
||||||
|
```json
|
||||||
|
{
|
||||||
|
"data": {
|
||||||
|
"cite": "Piscis primum a capite foetat"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
```
|
||||||
|
|
||||||
## Further information
|
## Further information
|
||||||
|
|
||||||
- [Contributing guidelines](CONTRIBUTING.md).
|
- [Contributing guidelines](CONTRIBUTING.md).
|
||||||
|
|
|
@ -4,10 +4,10 @@ cabal-version: 1.12
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: ba234bcfff46df053a3466359e32682c4592b88894911ecbe78bd00fa00929b5
|
-- hash: 3ef060c57424074b84204bae61ee0a63e3470a7a060c45a977ff2bcbe4df8775
|
||||||
|
|
||||||
name: graphql
|
name: graphql
|
||||||
version: 0.8.0.0
|
version: 0.10.0.0
|
||||||
synopsis: Haskell GraphQL implementation
|
synopsis: Haskell GraphQL implementation
|
||||||
description: This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
|
description: This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
|
||||||
category: Language
|
category: Language
|
||||||
|
@ -24,12 +24,10 @@ license-file: LICENSE
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
extra-source-files:
|
extra-source-files:
|
||||||
CHANGELOG.md
|
CHANGELOG.md
|
||||||
README.md
|
CONTRIBUTING.md
|
||||||
LICENSE
|
LICENSE
|
||||||
|
README.md
|
||||||
docs/tutorial/tutorial.lhs
|
docs/tutorial/tutorial.lhs
|
||||||
data-files:
|
|
||||||
tests/data/kitchen-sink.graphql
|
|
||||||
tests/data/kitchen-sink.min.graphql
|
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
|
@ -52,6 +50,7 @@ library
|
||||||
Language.GraphQL.Type.Out
|
Language.GraphQL.Type.Out
|
||||||
Language.GraphQL.Type.Schema
|
Language.GraphQL.Type.Schema
|
||||||
Language.GraphQL.Validate
|
Language.GraphQL.Validate
|
||||||
|
Language.GraphQL.Validate.Validation
|
||||||
Test.Hspec.GraphQL
|
Test.Hspec.GraphQL
|
||||||
other-modules:
|
other-modules:
|
||||||
Language.GraphQL.Execute.Execution
|
Language.GraphQL.Execute.Execution
|
||||||
|
@ -91,7 +90,6 @@ test-suite tasty
|
||||||
Language.GraphQL.ValidateSpec
|
Language.GraphQL.ValidateSpec
|
||||||
Test.DirectiveSpec
|
Test.DirectiveSpec
|
||||||
Test.FragmentSpec
|
Test.FragmentSpec
|
||||||
Test.KitchenSinkSpec
|
|
||||||
Test.RootOperationSpec
|
Test.RootOperationSpec
|
||||||
Test.StarWars.Data
|
Test.StarWars.Data
|
||||||
Test.StarWars.QuerySpec
|
Test.StarWars.QuerySpec
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
name: graphql
|
name: graphql
|
||||||
version: 0.8.0.0
|
version: 0.10.0.0
|
||||||
synopsis: Haskell GraphQL implementation
|
synopsis: Haskell GraphQL implementation
|
||||||
description:
|
description:
|
||||||
This package provides a rudimentary parser for the
|
This package provides a rudimentary parser for the
|
||||||
|
@ -17,14 +17,11 @@ author:
|
||||||
|
|
||||||
extra-source-files:
|
extra-source-files:
|
||||||
- CHANGELOG.md
|
- CHANGELOG.md
|
||||||
- README.md
|
- CONTRIBUTING.md
|
||||||
- LICENSE
|
- LICENSE
|
||||||
|
- README.md
|
||||||
- docs/tutorial/tutorial.lhs
|
- docs/tutorial/tutorial.lhs
|
||||||
|
|
||||||
data-files:
|
|
||||||
- tests/data/*.graphql
|
|
||||||
- tests/data/*.min.graphql
|
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
- aeson
|
- aeson
|
||||||
- base >= 4.7 && < 5
|
- base >= 4.7 && < 5
|
||||||
|
|
|
@ -1,3 +1,7 @@
|
||||||
|
{- 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/. -}
|
||||||
|
|
||||||
-- | Target AST for parser.
|
-- | Target AST for parser.
|
||||||
module Language.GraphQL.AST
|
module Language.GraphQL.AST
|
||||||
( module Language.GraphQL.AST.Document
|
( module Language.GraphQL.AST.Document
|
||||||
|
|
|
@ -1,5 +1,9 @@
|
||||||
|
{- 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/. -}
|
||||||
|
|
||||||
-- | Various parts of a GraphQL document can be annotated with directives.
|
-- | Various parts of a GraphQL document can be annotated with directives.
|
||||||
-- This module describes locations in a document where directives can appear.
|
-- This module describes locations in a document where directives can appear.
|
||||||
module Language.GraphQL.AST.DirectiveLocation
|
module Language.GraphQL.AST.DirectiveLocation
|
||||||
( DirectiveLocation(..)
|
( DirectiveLocation(..)
|
||||||
, ExecutableDirectiveLocation(..)
|
, ExecutableDirectiveLocation(..)
|
||||||
|
@ -7,8 +11,8 @@ module Language.GraphQL.AST.DirectiveLocation
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- | All directives can be splitted in two groups: directives used to annotate
|
-- | All directives can be splitted in two groups: directives used to annotate
|
||||||
-- various parts of executable definitions and the ones used in the schema
|
-- various parts of executable definitions and the ones used in the schema
|
||||||
-- definition.
|
-- definition.
|
||||||
data DirectiveLocation
|
data DirectiveLocation
|
||||||
= ExecutableDirectiveLocation ExecutableDirectiveLocation
|
= ExecutableDirectiveLocation ExecutableDirectiveLocation
|
||||||
| TypeSystemDirectiveLocation TypeSystemDirectiveLocation
|
| TypeSystemDirectiveLocation TypeSystemDirectiveLocation
|
||||||
|
|
|
@ -62,6 +62,12 @@ data Location = Location
|
||||||
, column :: Word
|
, column :: Word
|
||||||
} deriving (Eq, Show)
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance Ord Location where
|
||||||
|
compare (Location thisLine thisColumn) (Location thatLine thatColumn)
|
||||||
|
| thisLine < thatLine = LT
|
||||||
|
| thisLine > thatLine = GT
|
||||||
|
| otherwise = compare thisColumn thatColumn
|
||||||
|
|
||||||
-- ** Document
|
-- ** Document
|
||||||
|
|
||||||
-- | GraphQL document.
|
-- | GraphQL document.
|
||||||
|
@ -69,7 +75,7 @@ type Document = NonEmpty Definition
|
||||||
|
|
||||||
-- | All kinds of definitions that can occur in a GraphQL document.
|
-- | All kinds of definitions that can occur in a GraphQL document.
|
||||||
data Definition
|
data Definition
|
||||||
= ExecutableDefinition ExecutableDefinition Location
|
= ExecutableDefinition ExecutableDefinition
|
||||||
| TypeSystemDefinition TypeSystemDefinition Location
|
| TypeSystemDefinition TypeSystemDefinition Location
|
||||||
| TypeSystemExtension TypeSystemExtension Location
|
| TypeSystemExtension TypeSystemExtension Location
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
@ -84,13 +90,14 @@ data ExecutableDefinition
|
||||||
|
|
||||||
-- | Operation definition.
|
-- | Operation definition.
|
||||||
data OperationDefinition
|
data OperationDefinition
|
||||||
= SelectionSet SelectionSet
|
= SelectionSet SelectionSet Location
|
||||||
| OperationDefinition
|
| OperationDefinition
|
||||||
OperationType
|
OperationType
|
||||||
(Maybe Name)
|
(Maybe Name)
|
||||||
[VariableDefinition]
|
[VariableDefinition]
|
||||||
[Directive]
|
[Directive]
|
||||||
SelectionSet
|
SelectionSet
|
||||||
|
Location
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | GraphQL has 3 operation types:
|
-- | GraphQL has 3 operation types:
|
||||||
|
@ -195,7 +202,7 @@ type Alias = Name
|
||||||
|
|
||||||
-- | Fragment definition.
|
-- | Fragment definition.
|
||||||
data FragmentDefinition
|
data FragmentDefinition
|
||||||
= FragmentDefinition Name TypeCondition [Directive] SelectionSet
|
= FragmentDefinition Name TypeCondition [Directive] SelectionSet Location
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | Type condition.
|
-- | Type condition.
|
||||||
|
|
|
@ -50,8 +50,8 @@ document formatter defs
|
||||||
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
|
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
|
||||||
where
|
where
|
||||||
encodeDocument = foldr executableDefinition [] defs
|
encodeDocument = foldr executableDefinition [] defs
|
||||||
executableDefinition (ExecutableDefinition x _) acc =
|
executableDefinition (ExecutableDefinition executableDefinition') acc =
|
||||||
definition formatter x : acc
|
definition formatter executableDefinition' : acc
|
||||||
executableDefinition _ acc = acc
|
executableDefinition _ acc = acc
|
||||||
|
|
||||||
-- | Converts a t'ExecutableDefinition' into a string.
|
-- | Converts a t'ExecutableDefinition' into a string.
|
||||||
|
@ -68,12 +68,12 @@ definition formatter x
|
||||||
-- | Converts a 'OperationDefinition into a string.
|
-- | Converts a 'OperationDefinition into a string.
|
||||||
operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
|
operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
|
||||||
operationDefinition formatter = \case
|
operationDefinition formatter = \case
|
||||||
SelectionSet sels -> selectionSet formatter sels
|
SelectionSet sels _ -> selectionSet formatter sels
|
||||||
OperationDefinition Query name vars dirs sels ->
|
OperationDefinition Query name vars dirs sels _ ->
|
||||||
"query " <> node formatter name vars dirs sels
|
"query " <> node formatter name vars dirs sels
|
||||||
OperationDefinition Mutation name vars dirs sels ->
|
OperationDefinition Mutation name vars dirs sels _ ->
|
||||||
"mutation " <> node formatter name vars dirs sels
|
"mutation " <> node formatter name vars dirs sels
|
||||||
OperationDefinition Subscription name vars dirs sels ->
|
OperationDefinition Subscription name vars dirs sels _ ->
|
||||||
"subscription " <> node formatter name vars dirs sels
|
"subscription " <> node formatter name vars dirs sels
|
||||||
|
|
||||||
-- | Converts a Query or Mutation into a string.
|
-- | Converts a Query or Mutation into a string.
|
||||||
|
@ -190,7 +190,7 @@ inlineFragment formatter tc dirs sels = "... on "
|
||||||
<> selectionSet formatter sels
|
<> selectionSet formatter sels
|
||||||
|
|
||||||
fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
|
fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
|
||||||
fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
|
fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
|
||||||
= "fragment " <> Lazy.Text.fromStrict name
|
= "fragment " <> Lazy.Text.fromStrict name
|
||||||
<> " on " <> Lazy.Text.fromStrict tc
|
<> " on " <> Lazy.Text.fromStrict tc
|
||||||
<> optempty (directives formatter) dirs
|
<> optempty (directives formatter) dirs
|
||||||
|
|
|
@ -21,7 +21,8 @@ import Language.GraphQL.AST.DirectiveLocation
|
||||||
import Language.GraphQL.AST.Document
|
import Language.GraphQL.AST.Document
|
||||||
import Language.GraphQL.AST.Lexer
|
import Language.GraphQL.AST.Lexer
|
||||||
import Text.Megaparsec
|
import Text.Megaparsec
|
||||||
( SourcePos(..)
|
( MonadParsec(..)
|
||||||
|
, SourcePos(..)
|
||||||
, getSourcePos
|
, getSourcePos
|
||||||
, lookAhead
|
, lookAhead
|
||||||
, option
|
, option
|
||||||
|
@ -37,15 +38,11 @@ document = unicodeBOM
|
||||||
*> lexeme (NonEmpty.some definition)
|
*> lexeme (NonEmpty.some definition)
|
||||||
|
|
||||||
definition :: Parser Definition
|
definition :: Parser Definition
|
||||||
definition = executableDefinition'
|
definition = ExecutableDefinition <$> executableDefinition
|
||||||
<|> typeSystemDefinition'
|
<|> typeSystemDefinition'
|
||||||
<|> typeSystemExtension'
|
<|> typeSystemExtension'
|
||||||
<?> "Definition"
|
<?> "Definition"
|
||||||
where
|
where
|
||||||
executableDefinition' = do
|
|
||||||
location <- getLocation
|
|
||||||
definition' <- executableDefinition
|
|
||||||
pure $ ExecutableDefinition definition' location
|
|
||||||
typeSystemDefinition' = do
|
typeSystemDefinition' = do
|
||||||
location <- getLocation
|
location <- getLocation
|
||||||
definition' <- typeSystemDefinition
|
definition' <- typeSystemDefinition
|
||||||
|
@ -349,16 +346,22 @@ operationTypeDefinition = OperationTypeDefinition
|
||||||
<?> "OperationTypeDefinition"
|
<?> "OperationTypeDefinition"
|
||||||
|
|
||||||
operationDefinition :: Parser OperationDefinition
|
operationDefinition :: Parser OperationDefinition
|
||||||
operationDefinition = SelectionSet <$> selectionSet
|
operationDefinition = shorthand
|
||||||
<|> operationDefinition'
|
<|> operationDefinition'
|
||||||
<?> "OperationDefinition"
|
<?> "OperationDefinition"
|
||||||
where
|
where
|
||||||
operationDefinition'
|
shorthand = do
|
||||||
= OperationDefinition <$> operationType
|
location <- getLocation
|
||||||
<*> optional name
|
selectionSet' <- selectionSet
|
||||||
<*> variableDefinitions
|
pure $ SelectionSet selectionSet' location
|
||||||
<*> directives
|
operationDefinition' = do
|
||||||
<*> selectionSet
|
location <- getLocation
|
||||||
|
operationType' <- operationType
|
||||||
|
operationName <- optional name
|
||||||
|
variableDefinitions' <- variableDefinitions
|
||||||
|
directives' <- directives
|
||||||
|
selectionSet' <- selectionSet
|
||||||
|
pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location
|
||||||
|
|
||||||
operationType :: Parser OperationType
|
operationType :: Parser OperationType
|
||||||
operationType = Query <$ symbol "query"
|
operationType = Query <$ symbol "query"
|
||||||
|
@ -412,13 +415,15 @@ inlineFragment = InlineFragment
|
||||||
<?> "InlineFragment"
|
<?> "InlineFragment"
|
||||||
|
|
||||||
fragmentDefinition :: Parser FragmentDefinition
|
fragmentDefinition :: Parser FragmentDefinition
|
||||||
fragmentDefinition = FragmentDefinition
|
fragmentDefinition = label "FragmentDefinition" $ do
|
||||||
<$ symbol "fragment"
|
location <- getLocation
|
||||||
<*> name
|
_ <- symbol "fragment"
|
||||||
<*> typeCondition
|
fragmentName' <- name
|
||||||
<*> directives
|
typeCondition' <- typeCondition
|
||||||
<*> selectionSet
|
directives' <- directives
|
||||||
<?> "FragmentDefinition"
|
selectionSet' <- selectionSet
|
||||||
|
pure $ FragmentDefinition
|
||||||
|
fragmentName' typeCondition' directives' selectionSet' location
|
||||||
|
|
||||||
fragmentName :: Parser Name
|
fragmentName :: Parser Name
|
||||||
fragmentName = but (symbol "on") *> name <?> "FragmentName"
|
fragmentName = but (symbol "on") *> name <?> "FragmentName"
|
||||||
|
|
|
@ -1,3 +1,7 @@
|
||||||
|
{- 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 ExplicitForAll #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
|
@ -83,30 +83,6 @@ resolveAbstractType abstractType values'
|
||||||
_ -> pure Nothing
|
_ -> pure Nothing
|
||||||
| otherwise = pure Nothing
|
| otherwise = pure Nothing
|
||||||
|
|
||||||
doesFragmentTypeApply :: forall m
|
|
||||||
. CompositeType m
|
|
||||||
-> Out.ObjectType m
|
|
||||||
-> Bool
|
|
||||||
doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
|
|
||||||
fragmentType == objectType
|
|
||||||
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
|
|
||||||
instanceOf objectType $ AbstractInterfaceType fragmentType
|
|
||||||
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
|
|
||||||
instanceOf objectType $ AbstractUnionType fragmentType
|
|
||||||
|
|
||||||
instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
|
|
||||||
instanceOf objectType (AbstractInterfaceType interfaceType) =
|
|
||||||
let Out.ObjectType _ _ interfaces _ = objectType
|
|
||||||
in foldr go False interfaces
|
|
||||||
where
|
|
||||||
go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc =
|
|
||||||
acc || foldr go (interfaceType == objectInterfaceType) interfaces
|
|
||||||
instanceOf objectType (AbstractUnionType unionType) =
|
|
||||||
let Out.UnionType _ _ members = unionType
|
|
||||||
in foldr go False members
|
|
||||||
where
|
|
||||||
go unionMemberType acc = acc || objectType == unionMemberType
|
|
||||||
|
|
||||||
executeField :: (MonadCatch m, Serialize a)
|
executeField :: (MonadCatch m, Serialize a)
|
||||||
=> Out.Resolver m
|
=> Out.Resolver m
|
||||||
-> Type.Value
|
-> Type.Value
|
||||||
|
|
|
@ -255,18 +255,18 @@ defragment ast =
|
||||||
in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
|
in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
|
||||||
where
|
where
|
||||||
defragment' definition (operations, fragments')
|
defragment' definition (operations, fragments')
|
||||||
| (Full.ExecutableDefinition executable _) <- definition
|
| (Full.ExecutableDefinition executable) <- definition
|
||||||
, (Full.DefinitionOperation operation') <- executable =
|
, (Full.DefinitionOperation operation') <- executable =
|
||||||
(transform operation' : operations, fragments')
|
(transform operation' : operations, fragments')
|
||||||
| (Full.ExecutableDefinition executable _) <- definition
|
| (Full.ExecutableDefinition executable) <- definition
|
||||||
, (Full.DefinitionFragment fragment) <- executable
|
, (Full.DefinitionFragment fragment) <- executable
|
||||||
, (Full.FragmentDefinition name _ _ _) <- fragment =
|
, (Full.FragmentDefinition name _ _ _ _) <- fragment =
|
||||||
(operations, HashMap.insert name fragment fragments')
|
(operations, HashMap.insert name fragment fragments')
|
||||||
defragment' _ acc = acc
|
defragment' _ acc = acc
|
||||||
transform = \case
|
transform = \case
|
||||||
Full.OperationDefinition type' name variables directives' selections ->
|
Full.OperationDefinition type' name variables directives' selections _ ->
|
||||||
OperationDefinition type' name variables directives' selections
|
OperationDefinition type' name variables directives' selections
|
||||||
Full.SelectionSet selectionSet ->
|
Full.SelectionSet selectionSet _ ->
|
||||||
OperationDefinition Full.Query Nothing mempty mempty selectionSet
|
OperationDefinition Full.Query Nothing mempty mempty selectionSet
|
||||||
|
|
||||||
-- * Operation
|
-- * Operation
|
||||||
|
@ -324,8 +324,8 @@ selection (Full.InlineFragment type' directives' selections) = do
|
||||||
case type' of
|
case type' of
|
||||||
Nothing -> pure $ Left fragmentSelectionSet
|
Nothing -> pure $ Left fragmentSelectionSet
|
||||||
Just typeName -> do
|
Just typeName -> do
|
||||||
typeCondition' <- lookupTypeCondition typeName
|
types' <- gets types
|
||||||
case typeCondition' of
|
case lookupTypeCondition typeName types' of
|
||||||
Just typeCondition -> pure $
|
Just typeCondition -> pure $
|
||||||
selectionFragment typeCondition fragmentSelectionSet
|
selectionFragment typeCondition fragmentSelectionSet
|
||||||
Nothing -> pure $ Left mempty
|
Nothing -> pure $ Left mempty
|
||||||
|
@ -364,29 +364,17 @@ collectFragments = do
|
||||||
_ <- fragmentDefinition nextValue
|
_ <- fragmentDefinition nextValue
|
||||||
collectFragments
|
collectFragments
|
||||||
|
|
||||||
lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m))
|
|
||||||
lookupTypeCondition type' = do
|
|
||||||
types' <- gets types
|
|
||||||
case HashMap.lookup type' types' of
|
|
||||||
Just (ObjectType objectType) ->
|
|
||||||
lift $ pure $ Just $ CompositeObjectType objectType
|
|
||||||
Just (UnionType unionType) ->
|
|
||||||
lift $ pure $ Just $ CompositeUnionType unionType
|
|
||||||
Just (InterfaceType interfaceType) ->
|
|
||||||
lift $ pure $ Just $ CompositeInterfaceType interfaceType
|
|
||||||
_ -> lift $ pure Nothing
|
|
||||||
|
|
||||||
fragmentDefinition
|
fragmentDefinition
|
||||||
:: Full.FragmentDefinition
|
:: Full.FragmentDefinition
|
||||||
-> State (Replacement m) (Maybe (Fragment m))
|
-> State (Replacement m) (Maybe (Fragment m))
|
||||||
fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
|
fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do
|
||||||
modify deleteFragmentDefinition
|
modify deleteFragmentDefinition
|
||||||
fragmentSelection <- appendSelection selections
|
fragmentSelection <- appendSelection selections
|
||||||
compositeType <- lookupTypeCondition type'
|
types' <- gets types
|
||||||
|
|
||||||
case compositeType of
|
case lookupTypeCondition type' types' of
|
||||||
Just compositeType' -> do
|
Just compositeType -> do
|
||||||
let newValue = Fragment compositeType' fragmentSelection
|
let newValue = Fragment compositeType fragmentSelection
|
||||||
modify $ insertFragment newValue
|
modify $ insertFragment newValue
|
||||||
lift $ pure $ Just newValue
|
lift $ pure $ Just newValue
|
||||||
_ -> lift $ pure Nothing
|
_ -> lift $ pure Nothing
|
||||||
|
|
|
@ -1,3 +1,7 @@
|
||||||
|
{- 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 PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
|
|
@ -8,6 +8,9 @@ module Language.GraphQL.Type.Internal
|
||||||
( AbstractType(..)
|
( AbstractType(..)
|
||||||
, CompositeType(..)
|
, CompositeType(..)
|
||||||
, collectReferencedTypes
|
, collectReferencedTypes
|
||||||
|
, doesFragmentTypeApply
|
||||||
|
, instanceOf
|
||||||
|
, lookupTypeCondition
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
@ -89,3 +92,39 @@ collectReferencedTypes schema =
|
||||||
polymorphicTraverser interfaces fields
|
polymorphicTraverser interfaces fields
|
||||||
= flip (foldr visitFields) fields
|
= flip (foldr visitFields) fields
|
||||||
. flip (foldr traverseInterfaceType) interfaces
|
. flip (foldr traverseInterfaceType) interfaces
|
||||||
|
|
||||||
|
doesFragmentTypeApply :: forall m
|
||||||
|
. CompositeType m
|
||||||
|
-> Out.ObjectType m
|
||||||
|
-> Bool
|
||||||
|
doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
|
||||||
|
fragmentType == objectType
|
||||||
|
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
|
||||||
|
instanceOf objectType $ AbstractInterfaceType fragmentType
|
||||||
|
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
|
||||||
|
instanceOf objectType $ AbstractUnionType fragmentType
|
||||||
|
|
||||||
|
instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
|
||||||
|
instanceOf objectType (AbstractInterfaceType interfaceType) =
|
||||||
|
let Out.ObjectType _ _ interfaces _ = objectType
|
||||||
|
in foldr go False interfaces
|
||||||
|
where
|
||||||
|
go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc =
|
||||||
|
acc || foldr go (interfaceType == objectInterfaceType) interfaces
|
||||||
|
instanceOf objectType (AbstractUnionType unionType) =
|
||||||
|
let Out.UnionType _ _ members = unionType
|
||||||
|
in foldr go False members
|
||||||
|
where
|
||||||
|
go unionMemberType acc = acc || objectType == unionMemberType
|
||||||
|
|
||||||
|
lookupTypeCondition :: forall m
|
||||||
|
. Name
|
||||||
|
-> HashMap Name (Type m)
|
||||||
|
-> Maybe (CompositeType m)
|
||||||
|
lookupTypeCondition type' types' =
|
||||||
|
case HashMap.lookup type' types' of
|
||||||
|
Just (ObjectType objectType) -> Just $ CompositeObjectType objectType
|
||||||
|
Just (UnionType unionType) -> Just $ CompositeUnionType unionType
|
||||||
|
Just (InterfaceType interfaceType) ->
|
||||||
|
Just $ CompositeInterfaceType interfaceType
|
||||||
|
_ -> Nothing
|
||||||
|
|
|
@ -1,3 +1,7 @@
|
||||||
|
{- 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/. -}
|
||||||
|
|
||||||
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
||||||
-- functions for defining and manipulating schemas.
|
-- functions for defining and manipulating schemas.
|
||||||
module Language.GraphQL.Type.Schema
|
module Language.GraphQL.Type.Schema
|
||||||
|
|
|
@ -5,6 +5,7 @@
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
|
||||||
|
-- | GraphQL validator.
|
||||||
module Language.GraphQL.Validate
|
module Language.GraphQL.Validate
|
||||||
( Error(..)
|
( Error(..)
|
||||||
, Path(..)
|
, Path(..)
|
||||||
|
@ -12,66 +13,50 @@ module Language.GraphQL.Validate
|
||||||
, module Language.GraphQL.Validate.Rules
|
, module Language.GraphQL.Validate.Rules
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.Trans.Reader (Reader, asks, runReader)
|
import Control.Monad (foldM)
|
||||||
|
import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
|
||||||
import Data.Foldable (foldrM)
|
import Data.Foldable (foldrM)
|
||||||
import Data.Sequence (Seq(..), (><), (|>))
|
import Data.Sequence (Seq(..), (><), (|>))
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
import Data.Text (Text)
|
|
||||||
import Language.GraphQL.AST.Document
|
import Language.GraphQL.AST.Document
|
||||||
import Language.GraphQL.Type.Schema
|
import Language.GraphQL.Type.Internal
|
||||||
|
import Language.GraphQL.Type.Schema (Schema(..))
|
||||||
import Language.GraphQL.Validate.Rules
|
import Language.GraphQL.Validate.Rules
|
||||||
|
import Language.GraphQL.Validate.Validation
|
||||||
|
|
||||||
data Context m = Context
|
type ValidateT m = Reader (Validation m) (Seq Error)
|
||||||
{ ast :: Document
|
|
||||||
, schema :: Schema m
|
|
||||||
, rules :: [Rule]
|
|
||||||
}
|
|
||||||
|
|
||||||
type ValidateT m = Reader (Context m) (Seq Error)
|
-- | Validates a document and returns a list of found errors. If the returned
|
||||||
|
-- list is empty, the document is valid.
|
||||||
data Path
|
document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
|
||||||
= Segment Text
|
|
||||||
| Index Int
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
data Error = Error
|
|
||||||
{ message :: String
|
|
||||||
, locations :: [Location]
|
|
||||||
, path :: [Path]
|
|
||||||
} deriving (Eq, Show)
|
|
||||||
|
|
||||||
document :: forall m. Schema m -> [Rule] -> Document -> Seq Error
|
|
||||||
document schema' rules' document' =
|
document schema' rules' document' =
|
||||||
runReader (foldrM go Seq.empty document') context
|
runReader (foldrM go Seq.empty document') context
|
||||||
where
|
where
|
||||||
context = Context
|
context = Validation
|
||||||
{ ast = document'
|
{ ast = document'
|
||||||
, schema = schema'
|
, schema = schema'
|
||||||
|
, types = collectReferencedTypes schema'
|
||||||
, rules = rules'
|
, rules = rules'
|
||||||
}
|
}
|
||||||
go definition' accumulator = (accumulator ><) <$> definition definition'
|
go definition' accumulator = (accumulator ><) <$> definition definition'
|
||||||
|
|
||||||
definition :: forall m. Definition -> ValidateT m
|
definition :: forall m. Definition -> ValidateT m
|
||||||
definition = \case
|
definition = \case
|
||||||
definition'@(ExecutableDefinition executableDefinition' _) -> do
|
definition'@(ExecutableDefinition executableDefinition') -> do
|
||||||
applied <- applyRules definition'
|
applied <- applyRules definition'
|
||||||
children <- executableDefinition executableDefinition'
|
children <- executableDefinition executableDefinition'
|
||||||
pure $ children >< applied
|
pure $ children >< applied
|
||||||
definition' -> applyRules definition'
|
definition' -> applyRules definition'
|
||||||
where
|
where
|
||||||
applyRules definition' = foldr (ruleFilter definition') Seq.empty
|
applyRules definition' =
|
||||||
<$> asks rules
|
asks rules >>= foldM (ruleFilter definition') Seq.empty
|
||||||
ruleFilter definition' (DefinitionRule rule) accumulator
|
ruleFilter definition' accumulator (DefinitionRule rule) =
|
||||||
| Just message' <- rule definition' =
|
mapReaderT (runRule accumulator) $ rule definition'
|
||||||
accumulator |> Error
|
ruleFilter _ accumulator _ = pure accumulator
|
||||||
{ message = message'
|
|
||||||
, locations = [definitionLocation definition']
|
runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
|
||||||
, path = []
|
runRule accumulator (Just error') = pure $ accumulator |> error'
|
||||||
}
|
runRule accumulator Nothing = pure accumulator
|
||||||
| otherwise = accumulator
|
|
||||||
definitionLocation (ExecutableDefinition _ location) = location
|
|
||||||
definitionLocation (TypeSystemDefinition _ location) = location
|
|
||||||
definitionLocation (TypeSystemExtension _ location) = location
|
|
||||||
|
|
||||||
executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
|
executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
|
||||||
executableDefinition (DefinitionOperation definition') =
|
executableDefinition (DefinitionOperation definition') =
|
||||||
|
@ -80,10 +65,17 @@ executableDefinition (DefinitionFragment definition') =
|
||||||
fragmentDefinition definition'
|
fragmentDefinition definition'
|
||||||
|
|
||||||
operationDefinition :: forall m. OperationDefinition -> ValidateT m
|
operationDefinition :: forall m. OperationDefinition -> ValidateT m
|
||||||
operationDefinition (SelectionSet _operation) =
|
operationDefinition operation =
|
||||||
pure Seq.empty
|
asks rules >>= foldM ruleFilter Seq.empty
|
||||||
operationDefinition (OperationDefinition _type _name _variables _directives _selection) =
|
where
|
||||||
pure Seq.empty
|
ruleFilter accumulator (OperationDefinitionRule rule) =
|
||||||
|
mapReaderT (runRule accumulator) $ rule operation
|
||||||
|
ruleFilter accumulator _ = pure accumulator
|
||||||
|
|
||||||
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
|
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
|
||||||
fragmentDefinition _fragment = pure Seq.empty
|
fragmentDefinition fragment =
|
||||||
|
asks rules >>= foldM ruleFilter Seq.empty
|
||||||
|
where
|
||||||
|
ruleFilter accumulator (FragmentDefinitionRule rule) =
|
||||||
|
mapReaderT (runRule accumulator) $ rule fragment
|
||||||
|
ruleFilter accumulator _ = pure accumulator
|
||||||
|
|
|
@ -2,24 +2,214 @@
|
||||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
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/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
-- | This module contains default rules defined in the GraphQL specification.
|
||||||
module Language.GraphQL.Validate.Rules
|
module Language.GraphQL.Validate.Rules
|
||||||
( Rule(..)
|
( executableDefinitionsRule
|
||||||
, executableDefinitionsRule
|
, loneAnonymousOperationRule
|
||||||
|
, singleFieldSubscriptionsRule
|
||||||
, specifiedRules
|
, specifiedRules
|
||||||
|
, uniqueFragmentNamesRule
|
||||||
|
, uniqueOperationNamesRule
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Monad (foldM)
|
||||||
|
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||||
|
import Control.Monad.Trans.Reader (asks)
|
||||||
|
import Control.Monad.Trans.State (evalStateT, gets, modify)
|
||||||
|
import qualified Data.HashSet as HashSet
|
||||||
|
import qualified Data.Text as Text
|
||||||
import Language.GraphQL.AST.Document
|
import Language.GraphQL.AST.Document
|
||||||
|
import Language.GraphQL.Type.Internal
|
||||||
|
import qualified Language.GraphQL.Type.Schema as Schema
|
||||||
|
import Language.GraphQL.Validate.Validation
|
||||||
|
|
||||||
newtype Rule
|
-- | Default rules given in the specification.
|
||||||
= DefinitionRule (Definition -> Maybe String)
|
specifiedRules :: forall m. [Rule m]
|
||||||
|
|
||||||
specifiedRules :: [Rule]
|
|
||||||
specifiedRules =
|
specifiedRules =
|
||||||
[ executableDefinitionsRule
|
[ executableDefinitionsRule
|
||||||
|
, singleFieldSubscriptionsRule
|
||||||
|
, loneAnonymousOperationRule
|
||||||
|
, uniqueOperationNamesRule
|
||||||
|
, uniqueFragmentNamesRule
|
||||||
]
|
]
|
||||||
|
|
||||||
executableDefinitionsRule :: Rule
|
-- | Definition must be OperationDefinition or FragmentDefinition.
|
||||||
executableDefinitionsRule = DefinitionRule go
|
executableDefinitionsRule :: forall m. Rule m
|
||||||
|
executableDefinitionsRule = DefinitionRule $ \case
|
||||||
|
ExecutableDefinition _ -> lift Nothing
|
||||||
|
TypeSystemDefinition _ location -> pure $ error' location
|
||||||
|
TypeSystemExtension _ location -> pure $ error' location
|
||||||
where
|
where
|
||||||
go (ExecutableDefinition _definition _) = Nothing
|
error' location = Error
|
||||||
go _ = Just "Definition must be OperationDefinition or FragmentDefinition."
|
{ message =
|
||||||
|
"Definition must be OperationDefinition or FragmentDefinition."
|
||||||
|
, locations = [location]
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | Subscription operations must have exactly one root field.
|
||||||
|
singleFieldSubscriptionsRule :: forall m. Rule m
|
||||||
|
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
|
||||||
|
OperationDefinition Subscription name' _ _ rootFields location -> do
|
||||||
|
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
|
||||||
|
case HashSet.size groupedFieldSet of
|
||||||
|
1 -> lift Nothing
|
||||||
|
_
|
||||||
|
| Just name <- name' -> pure $ Error
|
||||||
|
{ message = unwords
|
||||||
|
[ "Subscription"
|
||||||
|
, Text.unpack name
|
||||||
|
, "must select only one top level field."
|
||||||
|
]
|
||||||
|
, locations = [location]
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
| otherwise -> pure $ Error
|
||||||
|
{ message = errorMessage
|
||||||
|
, locations = [location]
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
_ -> lift Nothing
|
||||||
|
where
|
||||||
|
errorMessage =
|
||||||
|
"Anonymous Subscription must select only one top level field."
|
||||||
|
collectFields selectionSet = foldM forEach HashSet.empty selectionSet
|
||||||
|
forEach accumulator (Field alias name _ directives _)
|
||||||
|
| any skip directives = pure accumulator
|
||||||
|
| Just aliasedName <- alias = pure
|
||||||
|
$ HashSet.insert aliasedName accumulator
|
||||||
|
| otherwise = pure $ HashSet.insert name accumulator
|
||||||
|
forEach accumulator (FragmentSpread fragmentName directives)
|
||||||
|
| any skip directives = pure accumulator
|
||||||
|
| otherwise = do
|
||||||
|
inVisitetFragments <- gets $ HashSet.member fragmentName
|
||||||
|
if inVisitetFragments
|
||||||
|
then pure accumulator
|
||||||
|
else collectFromSpread fragmentName accumulator
|
||||||
|
forEach accumulator (InlineFragment typeCondition' directives selectionSet)
|
||||||
|
| any skip directives = pure accumulator
|
||||||
|
| Just typeCondition <- typeCondition' =
|
||||||
|
collectFromFragment typeCondition selectionSet accumulator
|
||||||
|
| otherwise = HashSet.union accumulator
|
||||||
|
<$> collectFields selectionSet
|
||||||
|
skip (Directive "skip" [Argument "if" (Boolean True)]) = True
|
||||||
|
skip (Directive "include" [Argument "if" (Boolean False)]) = True
|
||||||
|
skip _ = False
|
||||||
|
findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing
|
||||||
|
| DefinitionFragment fragmentDefinition <- executableDefinition =
|
||||||
|
Just fragmentDefinition
|
||||||
|
findFragmentDefinition _ accumulator = accumulator
|
||||||
|
collectFromFragment typeCondition selectionSet accumulator = do
|
||||||
|
types' <- lift $ asks types
|
||||||
|
schema' <- lift $ asks schema
|
||||||
|
case lookupTypeCondition typeCondition types' of
|
||||||
|
Nothing -> pure accumulator
|
||||||
|
Just compositeType
|
||||||
|
| Just objectType <- Schema.subscription schema'
|
||||||
|
, True <- doesFragmentTypeApply compositeType objectType ->
|
||||||
|
HashSet.union accumulator<$> collectFields selectionSet
|
||||||
|
| otherwise -> pure accumulator
|
||||||
|
collectFromSpread fragmentName accumulator = do
|
||||||
|
modify $ HashSet.insert fragmentName
|
||||||
|
ast' <- lift $ asks ast
|
||||||
|
case foldr findFragmentDefinition Nothing ast' of
|
||||||
|
Nothing -> pure accumulator
|
||||||
|
Just (FragmentDefinition _ typeCondition _ selectionSet _) ->
|
||||||
|
collectFromFragment typeCondition selectionSet accumulator
|
||||||
|
|
||||||
|
-- | GraphQL allows a short‐hand form for defining query operations when only
|
||||||
|
-- that one operation exists in the document.
|
||||||
|
loneAnonymousOperationRule :: forall m. Rule m
|
||||||
|
loneAnonymousOperationRule = OperationDefinitionRule $ \case
|
||||||
|
SelectionSet _ thisLocation -> check thisLocation
|
||||||
|
OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation
|
||||||
|
_ -> lift Nothing
|
||||||
|
where
|
||||||
|
check thisLocation = asks ast
|
||||||
|
>>= lift . foldr (filterAnonymousOperations thisLocation) Nothing
|
||||||
|
filterAnonymousOperations thisLocation definition Nothing
|
||||||
|
| (viewOperation -> Just operationDefinition) <- definition =
|
||||||
|
compareAnonymousOperations thisLocation operationDefinition
|
||||||
|
filterAnonymousOperations _ _ accumulator = accumulator
|
||||||
|
compareAnonymousOperations thisLocation = \case
|
||||||
|
OperationDefinition _ _ _ _ _ thatLocation
|
||||||
|
| thisLocation /= thatLocation -> pure $ error' thisLocation
|
||||||
|
SelectionSet _ thatLocation
|
||||||
|
| thisLocation /= thatLocation -> pure $ error' thisLocation
|
||||||
|
_ -> Nothing
|
||||||
|
error' location = Error
|
||||||
|
{ message =
|
||||||
|
"This anonymous operation must be the only defined operation."
|
||||||
|
, locations = [location]
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | Each named operation definition must be unique within a document when
|
||||||
|
-- referred to by its name.
|
||||||
|
uniqueOperationNamesRule :: forall m. Rule m
|
||||||
|
uniqueOperationNamesRule = OperationDefinitionRule $ \case
|
||||||
|
OperationDefinition _ (Just thisName) _ _ _ thisLocation ->
|
||||||
|
findDuplicates (filterByName thisName) thisLocation (error' thisName)
|
||||||
|
_ -> lift Nothing
|
||||||
|
where
|
||||||
|
error' operationName = concat
|
||||||
|
[ "There can be only one operation named \""
|
||||||
|
, Text.unpack operationName
|
||||||
|
, "\"."
|
||||||
|
]
|
||||||
|
filterByName thisName definition' accumulator
|
||||||
|
| (viewOperation -> Just operationDefinition) <- definition'
|
||||||
|
, OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition
|
||||||
|
, thisName == thatName = thatLocation : accumulator
|
||||||
|
| otherwise = accumulator
|
||||||
|
|
||||||
|
findDuplicates :: (Definition -> [Location] -> [Location])
|
||||||
|
-> Location
|
||||||
|
-> String
|
||||||
|
-> RuleT m
|
||||||
|
findDuplicates filterByName thisLocation errorMessage = do
|
||||||
|
ast' <- asks ast
|
||||||
|
let locations' = foldr filterByName [] ast'
|
||||||
|
if length locations' > 1 && head locations' == thisLocation
|
||||||
|
then pure $ error' locations'
|
||||||
|
else lift Nothing
|
||||||
|
where
|
||||||
|
error' locations' = Error
|
||||||
|
{ message = errorMessage
|
||||||
|
, locations = locations'
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
|
||||||
|
viewOperation :: Definition -> Maybe OperationDefinition
|
||||||
|
viewOperation definition
|
||||||
|
| ExecutableDefinition executableDefinition <- definition
|
||||||
|
, DefinitionOperation operationDefinition <- executableDefinition =
|
||||||
|
Just operationDefinition
|
||||||
|
viewOperation _ = Nothing
|
||||||
|
|
||||||
|
-- | Fragment definitions are referenced in fragment spreads by name. To avoid
|
||||||
|
-- ambiguity, each fragment’s name must be unique within a document.
|
||||||
|
--
|
||||||
|
-- Inline fragments are not considered fragment definitions, and are unaffected
|
||||||
|
-- by this validation rule.
|
||||||
|
uniqueFragmentNamesRule :: forall m. Rule m
|
||||||
|
uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
|
||||||
|
FragmentDefinition thisName _ _ _ thisLocation ->
|
||||||
|
findDuplicates (filterByName thisName) thisLocation (error' thisName)
|
||||||
|
where
|
||||||
|
error' fragmentName = concat
|
||||||
|
[ "There can be only one fragment named \""
|
||||||
|
, Text.unpack fragmentName
|
||||||
|
, "\"."
|
||||||
|
]
|
||||||
|
filterByName thisName definition accumulator
|
||||||
|
| ExecutableDefinition executableDefinition <- definition
|
||||||
|
, DefinitionFragment fragmentDefinition <- executableDefinition
|
||||||
|
, FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition
|
||||||
|
, thisName == thatName = thatLocation : accumulator
|
||||||
|
| otherwise = accumulator
|
||||||
|
|
|
@ -0,0 +1,54 @@
|
||||||
|
{- 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/. -}
|
||||||
|
|
||||||
|
-- | Definitions used by the validation rules and the validator itself.
|
||||||
|
module Language.GraphQL.Validate.Validation
|
||||||
|
( Error(..)
|
||||||
|
, Path(..)
|
||||||
|
, Rule(..)
|
||||||
|
, RuleT
|
||||||
|
, Validation(..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Reader (ReaderT(..))
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Language.GraphQL.AST.Document
|
||||||
|
import Language.GraphQL.Type.Schema (Schema)
|
||||||
|
import qualified Language.GraphQL.Type.Schema as Schema
|
||||||
|
|
||||||
|
-- | If an error can be associated to a particular field in the GraphQL result,
|
||||||
|
-- it must contain an entry with the key path that details the path of the
|
||||||
|
-- response field which experienced the error. This allows clients to identify
|
||||||
|
-- whether a null result is intentional or caused by a runtime error.
|
||||||
|
data Path
|
||||||
|
= Segment Text -- ^ Field name.
|
||||||
|
| Index Int -- ^ List index if a field returned a list.
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- | Validation error.
|
||||||
|
data Error = Error
|
||||||
|
{ message :: String
|
||||||
|
, locations :: [Location]
|
||||||
|
, path :: [Path]
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- | Validation rule context.
|
||||||
|
data Validation m = Validation
|
||||||
|
{ ast :: Document
|
||||||
|
, schema :: Schema m
|
||||||
|
, types :: HashMap Name (Schema.Type m)
|
||||||
|
, rules :: [Rule m]
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | 'Rule' assigns a function to each AST node that can be validated. If the
|
||||||
|
-- validation fails, the function should return an error message, or 'Nothing'
|
||||||
|
-- otherwise.
|
||||||
|
data Rule m
|
||||||
|
= DefinitionRule (Definition -> RuleT m)
|
||||||
|
| OperationDefinitionRule (OperationDefinition -> RuleT m)
|
||||||
|
| FragmentDefinitionRule (FragmentDefinition -> RuleT m)
|
||||||
|
|
||||||
|
-- | Monad transformer used by the rules.
|
||||||
|
type RuleT m = ReaderT (Validation m) Maybe Error
|
|
@ -11,6 +11,7 @@ module Test.Hspec.GraphQL
|
||||||
, shouldResolveTo
|
, shouldResolveTo
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.Catch (MonadCatch)
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
@ -18,8 +19,8 @@ import Language.GraphQL.Error
|
||||||
import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)
|
import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)
|
||||||
|
|
||||||
-- | Asserts that a query resolves to some value.
|
-- | Asserts that a query resolves to some value.
|
||||||
shouldResolveTo
|
shouldResolveTo :: MonadCatch m
|
||||||
:: Either (ResponseEventStream IO Aeson.Value) Aeson.Object
|
=> Either (ResponseEventStream m Aeson.Value) Aeson.Object
|
||||||
-> Aeson.Object
|
-> Aeson.Object
|
||||||
-> Expectation
|
-> Expectation
|
||||||
shouldResolveTo (Right actual) expected = actual `shouldBe` expected
|
shouldResolveTo (Right actual) expected = actual `shouldBe` expected
|
||||||
|
@ -27,8 +28,8 @@ shouldResolveTo _ _ = expectationFailure
|
||||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||||
|
|
||||||
-- | Asserts that the response doesn't contain any errors.
|
-- | Asserts that the response doesn't contain any errors.
|
||||||
shouldResolve
|
shouldResolve :: MonadCatch m
|
||||||
:: (Text -> IO (Either (ResponseEventStream IO Aeson.Value) Aeson.Object))
|
=> (Text -> IO (Either (ResponseEventStream m Aeson.Value) Aeson.Object))
|
||||||
-> Text
|
-> Text
|
||||||
-> Expectation
|
-> Expectation
|
||||||
shouldResolve executor query = do
|
shouldResolve executor query = do
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
resolver: lts-16.5
|
resolver: lts-16.11
|
||||||
|
|
||||||
packages:
|
packages:
|
||||||
- .
|
- .
|
||||||
|
|
|
@ -123,7 +123,9 @@ spec = do
|
||||||
it "indents block strings in arguments" $
|
it "indents block strings in arguments" $
|
||||||
let arguments = [Argument "message" (String "line1\nline2")]
|
let arguments = [Argument "message" (String "line1\nline2")]
|
||||||
field = Field Nothing "field" arguments [] []
|
field = Field Nothing "field" arguments [] []
|
||||||
operation = DefinitionOperation $ SelectionSet $ pure field
|
operation = DefinitionOperation
|
||||||
|
$ SelectionSet (pure field)
|
||||||
|
$ Location 0 0
|
||||||
in definition pretty operation `shouldBe` [r|{
|
in definition pretty operation `shouldBe` [r|{
|
||||||
field(message: """
|
field(message: """
|
||||||
line1
|
line1
|
||||||
|
|
|
@ -1,3 +1,7 @@
|
||||||
|
{- 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 OverloadedStrings #-}
|
||||||
module Language.GraphQL.ErrorSpec
|
module Language.GraphQL.ErrorSpec
|
||||||
( spec
|
( spec
|
||||||
|
|
|
@ -1,3 +1,7 @@
|
||||||
|
{- 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 OverloadedStrings #-}
|
||||||
module Language.GraphQL.Execute.CoerceSpec
|
module Language.GraphQL.Execute.CoerceSpec
|
||||||
( spec
|
( spec
|
||||||
|
|
|
@ -1,3 +1,7 @@
|
||||||
|
{- 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 OverloadedStrings #-}
|
||||||
module Language.GraphQL.Type.OutSpec
|
module Language.GraphQL.Type.OutSpec
|
||||||
( spec
|
( spec
|
||||||
|
|
|
@ -148,7 +148,7 @@ validate queryString =
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec =
|
spec =
|
||||||
describe "document" $
|
describe "document" $ do
|
||||||
it "rejects type definitions" $
|
it "rejects type definitions" $
|
||||||
let queryString = [r|
|
let queryString = [r|
|
||||||
query getDogName {
|
query getDogName {
|
||||||
|
@ -169,3 +169,115 @@ spec =
|
||||||
, path = []
|
, path = []
|
||||||
}
|
}
|
||||||
in validate queryString `shouldBe` Seq.singleton expected
|
in validate queryString `shouldBe` Seq.singleton 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]
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` Seq.singleton 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]
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` Seq.singleton 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]
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` Seq.singleton 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]
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` Seq.singleton 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]
|
||||||
|
, path = []
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` Seq.singleton expected
|
||||||
|
|
|
@ -1,69 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
module Test.KitchenSinkSpec
|
|
||||||
( spec
|
|
||||||
) where
|
|
||||||
|
|
||||||
import qualified Data.Text.IO as Text.IO
|
|
||||||
import qualified Data.Text.Lazy.IO as Text.Lazy.IO
|
|
||||||
import qualified Data.Text.Lazy as Lazy (Text)
|
|
||||||
import qualified Language.GraphQL.AST.Encoder as Encoder
|
|
||||||
import qualified Language.GraphQL.AST.Parser as Parser
|
|
||||||
import Paths_graphql (getDataFileName)
|
|
||||||
import Test.Hspec (Spec, describe, it)
|
|
||||||
import Test.Hspec.Megaparsec (parseSatisfies)
|
|
||||||
import Text.Megaparsec (parse)
|
|
||||||
import Text.RawString.QQ (r)
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = describe "Kitchen Sink" $ do
|
|
||||||
it "minifies the query" $ do
|
|
||||||
dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
|
|
||||||
minFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
|
|
||||||
expected <- Text.Lazy.IO.readFile minFileName
|
|
||||||
|
|
||||||
shouldNormalize Encoder.minified dataFileName expected
|
|
||||||
|
|
||||||
it "pretty prints the query" $ do
|
|
||||||
dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
|
|
||||||
let expected = [r|query queryName($foo: ComplexType, $site: Site = MOBILE) {
|
|
||||||
whoever123is: node(id: [123, 456]) {
|
|
||||||
id
|
|
||||||
... on User @defer {
|
|
||||||
field2 {
|
|
||||||
id
|
|
||||||
alias: field1(first: 10, after: $foo) @include(if: $foo) {
|
|
||||||
id
|
|
||||||
...frag
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
mutation likeStory {
|
|
||||||
like(story: 123) @defer {
|
|
||||||
story {
|
|
||||||
id
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
fragment frag on Friend {
|
|
||||||
foo(size: $size, bar: $b, obj: {key: "value"})
|
|
||||||
}
|
|
||||||
|
|
||||||
{
|
|
||||||
unnamed(truthy: true, falsey: false)
|
|
||||||
query
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
|
|
||||||
shouldNormalize Encoder.pretty dataFileName expected
|
|
||||||
|
|
||||||
shouldNormalize :: Encoder.Formatter -> FilePath -> Lazy.Text -> IO ()
|
|
||||||
shouldNormalize formatter dataFileName expected = do
|
|
||||||
actual <- Text.IO.readFile dataFileName
|
|
||||||
parse Parser.document dataFileName actual `parseSatisfies` condition
|
|
||||||
where
|
|
||||||
condition = (expected ==) . Encoder.document formatter
|
|
|
@ -1,38 +0,0 @@
|
||||||
# Copyright (c) 2015, Facebook, Inc.
|
|
||||||
# All rights reserved.
|
|
||||||
#
|
|
||||||
# This source code is licensed under the BSD-style license found in the
|
|
||||||
# LICENSE file in the root directory of this source tree. An additional grant
|
|
||||||
# of patent rights can be found in the PATENTS file in the same directory.
|
|
||||||
|
|
||||||
query queryName($foo: ComplexType, $site: Site = MOBILE) {
|
|
||||||
whoever123is: node(id: [123, 456]) {
|
|
||||||
id, # Inline test comment
|
|
||||||
... on User @defer {
|
|
||||||
field2 {
|
|
||||||
id,
|
|
||||||
alias: field1(first: 10, after: $foo) @include(if: $foo) {
|
|
||||||
id,
|
|
||||||
...frag
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
mutation likeStory {
|
|
||||||
like(story: 123) @defer {
|
|
||||||
story {
|
|
||||||
id
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
fragment frag on Friend {
|
|
||||||
foo(size: $size, bar: $b, obj: {key: "value"})
|
|
||||||
}
|
|
||||||
|
|
||||||
{
|
|
||||||
unnamed(truthy: true, falsey: false),
|
|
||||||
query
|
|
||||||
}
|
|
|
@ -1 +0,0 @@
|
||||||
query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:"value"})}{unnamed(truthy:true,falsey:false),query}
|
|
Loading…
Reference in New Issue