Compare commits
78 Commits
Author | SHA1 | Date | |
---|---|---|---|
2215799cf7
|
|||
497edf326d
|
|||
663e4f3521
|
|||
324a4c55ff
|
|||
7ea76865e6
|
|||
2dcefff76a
|
|||
27a5a0b44e
|
|||
97627ffc36
|
|||
6f7bb10a62
|
|||
fda4b4fce4
|
|||
5abc377e9d
|
|||
67720f9ebe
|
|||
cdb2aa76b6
|
|||
b056b4256f
|
|||
ba07f8298b
|
|||
1834e5c41e | |||
01b30a71da
|
|||
b40d8a7e1e
|
|||
4b5e25a4d8
|
|||
a4e648d5aa
|
|||
6e32112be4
|
|||
388af30b51
|
|||
e02463f452
|
|||
9d85379826
|
|||
9b11300d23
|
|||
1c4584abdd
|
|||
e071553e75
|
|||
e731c7db07
|
|||
303cf18d77
|
|||
6b8346e527
|
|||
303f84ed41
|
|||
d2ea9fb467
|
|||
809f446ff1
|
|||
b1b6bfcdb9
|
|||
59aa010f0b | |||
b1c5a568dd
|
|||
5ffe8c72fa
|
|||
a961b168db | |||
a1cda38e20 | |||
7c78497e04 | |||
fdc43e4e25 | |||
2fdf04f54a
|
|||
3ed7dcd401
|
|||
408dfb4301
|
|||
3b69dac371
|
|||
2834360411
|
|||
83f2dc1a2d
|
|||
3b0da4f3d7
|
|||
d83f75b341
|
|||
85d876e131
|
|||
05fa5df558
|
|||
9021f3a25d
|
|||
025331a9ee
|
|||
ab4808c44d
|
|||
bb4375313e
|
|||
70dedb6911
|
|||
a96d4e6ef3
|
|||
3ce6e7da46
|
|||
a5cf0a32e8
|
|||
2f9881bb21
|
|||
bf2e4925b4
|
|||
2321d1a1bc
|
|||
2f19093803
|
|||
0dac9701bc
|
|||
0d25f482dd
|
|||
a2401d563b
|
|||
8503c0f288 | |||
05e6aa4c95 | |||
647547206f
|
|||
0c8edae90a | |||
73585dde85
|
|||
1f7bd92d11 | |||
16cbe3fc28
|
|||
f20cd02048
|
|||
116aa1f6bb
|
|||
df078a59d0
|
|||
930b8f10b7
|
|||
0047a13bc0
|
3
.gitea/deploy.awk
Normal file
3
.gitea/deploy.awk
Normal file
@ -0,0 +1,3 @@
|
||||
END {
|
||||
system("cabal upload --username belka --password "ENVIRON["HACKAGE_PASSWORD"]" "$0)
|
||||
}
|
33
.gitea/workflows/build.yml
Normal file
33
.gitea/workflows/build.yml
Normal file
@ -0,0 +1,33 @@
|
||||
name: Build
|
||||
|
||||
on:
|
||||
push:
|
||||
branches:
|
||||
- '**'
|
||||
pull_request:
|
||||
branches: [master]
|
||||
|
||||
jobs:
|
||||
audit:
|
||||
runs-on: buildenv
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- run: hlint -- src tests
|
||||
|
||||
test:
|
||||
runs-on: buildenv
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- name: Install dependencies
|
||||
run: cabal update
|
||||
- name: Prepare system
|
||||
run: cabal build graphql-test --enable-tests
|
||||
- run: cabal test --test-show-details=streaming --enable-tests
|
||||
|
||||
doc:
|
||||
runs-on: buildenv
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- name: Install dependencies
|
||||
run: cabal update
|
||||
- run: cabal haddock --enable-documentation
|
17
.gitea/workflows/release.yml
Normal file
17
.gitea/workflows/release.yml
Normal file
@ -0,0 +1,17 @@
|
||||
name: Release
|
||||
|
||||
on:
|
||||
push:
|
||||
tags:
|
||||
- '**'
|
||||
|
||||
jobs:
|
||||
release:
|
||||
runs-on: buildenv
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- name: Upload a candidate
|
||||
env:
|
||||
HACKAGE_PASSWORD: ${{ secrets.HACKAGE_PASSWORD }}
|
||||
run: |
|
||||
cabal sdist | awk -f .gitea/deploy.awk
|
139
CHANGELOG.md
139
CHANGELOG.md
@ -6,6 +6,99 @@ The format is based on
|
||||
and this project adheres to
|
||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||
|
||||
## [1.5.0.1] - 2025-06-19
|
||||
### Fixed
|
||||
- Allow any 2.x QuickCheck version.
|
||||
- Make the lexer and parser safe.
|
||||
|
||||
## [1.5.0.0] - 2024-12-03
|
||||
### Removed
|
||||
- Remove deprecated 'gql' quasi quoter.
|
||||
|
||||
### Changed
|
||||
- Validate the subscription root not to be an introspection field
|
||||
(`singleFieldSubscriptionsRule`).
|
||||
|
||||
## [1.4.0.0] - 2024-10-26
|
||||
### Changed
|
||||
- `Schema.Directive` is extended to contain a boolean argument, representing
|
||||
repeatable directives. The parser can parse repeatable directive definitions.
|
||||
Validation allows repeatable directives.
|
||||
- `AST.Document.Directive` is a record.
|
||||
- `gql` quasi quoter is deprecated (moved to graphql-spice package).
|
||||
|
||||
### Fixed
|
||||
- `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF).
|
||||
|
||||
### Added
|
||||
- @specifiedBy directive.
|
||||
|
||||
## [1.3.0.0] - 2024-05-01
|
||||
### Changed
|
||||
- Remove deprecated `runCollectErrs`, `Resolution`, `CollectErrsT` from the
|
||||
`Error` module.
|
||||
|
||||
## [1.2.0.3] - 2024-01-09
|
||||
### Fixed
|
||||
- Fix corrupted source distribution.
|
||||
|
||||
## [1.2.0.2] - 2024-01-09
|
||||
### Fixed
|
||||
- `gql` removes not only leading `\n` but also `\r`.
|
||||
- Fix non nullable type string representation in executor error messages.
|
||||
- Fix input objects not being coerced to lists.
|
||||
- Fix used variables are not found in the properties of input objects.
|
||||
|
||||
## [1.2.0.1] - 2023-04-25
|
||||
### Fixed
|
||||
- Support hspec 2.11.
|
||||
|
||||
## [1.2.0.0] - 2023-02-28
|
||||
### Added
|
||||
- Schema printing.
|
||||
- `Semigroup` and `Monoid` instances for `AST.Document.Description`.
|
||||
- Support for vector 0.13.0.0 and transformers 0.6.1.0.
|
||||
|
||||
### Fixed
|
||||
- Fix resolvers returning a list in the reverse order.
|
||||
|
||||
### Removed
|
||||
- GHC 8 support.
|
||||
- Cabal -json flag.
|
||||
- `Test.Hspec.GraphQL`: moved to `graphql-spice` package.
|
||||
- CPP `ifdef WITH_JSON` blocks.
|
||||
|
||||
## [1.1.0.0] - 2022-12-24
|
||||
### Changed
|
||||
- Removed deprecated `Language.GraphQL.Error` functions: `addErr`, `addErrMsg`,
|
||||
`singleError`.
|
||||
- Deprecate `Resolution`, `CollectErrsT` and `runCollectErrs` in the `Error`
|
||||
module. It was already noted in the documentation that these symbols are
|
||||
deprecated, now a pragma is added.
|
||||
- `Language.GraphQL`: Added information about the *json* flag and switching to
|
||||
*graphql-spice* for JSON support.
|
||||
|
||||
### Added
|
||||
- Partial schema printing: operation type encoder.
|
||||
|
||||
## [1.0.3.0] - 2022-03-27
|
||||
### Fixed
|
||||
- Index position in error path. (Index and Segment paths of a field have been
|
||||
swapped).
|
||||
- Parsing empty list as an argument.
|
||||
|
||||
### Added
|
||||
- quickCheck Parser test for arguments. Arbitrary instances for Language.GraphQL.AST.Document.
|
||||
- Enhanced query error messages. Add tests for these cases.
|
||||
- Allow version 2.0 of the text package.
|
||||
|
||||
## [1.0.2.0] - 2021-12-26
|
||||
### Added
|
||||
- `Serialize` instance for `Type.Definition.Value`.
|
||||
- `VariableValue` instance for `Type.Definition.Value`.
|
||||
- `Json` build flag, enabled by default. JSON and Aeson support can be disabled
|
||||
by disabling this flag.
|
||||
|
||||
## [1.0.1.0] - 2021-09-27
|
||||
### Added
|
||||
- Custom `Show` instance for `Type.Definition.Value` (for error
|
||||
@ -354,7 +447,6 @@ and this project adheres to
|
||||
- `Language.GraphQL.Schema`: `enum`, `enumA`, `wrappedEnum` and `wrappedEnumA`.
|
||||
Use `scalar`, `scalarA`, `wrappedScalar` and `wrappedScalarA` instead.
|
||||
|
||||
|
||||
## [0.5.1.0] - 2019-10-22
|
||||
### Deprecated
|
||||
- `Language.GraphQL.AST.Arguments`. Use `[Language.GraphQL.AST.Argument]`
|
||||
@ -459,20 +551,31 @@ and this project adheres to
|
||||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[1.0.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.1.0&rev_to=v1.0.0.0
|
||||
[1.0.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.0.0&rev_to=v0.11.1.0
|
||||
[0.11.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.1.0&rev_to=v0.11.0.0
|
||||
[0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0
|
||||
[0.10.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.10.0.0&rev_to=v0.9.0.0
|
||||
[0.9.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.9.0.0&rev_to=v0.8.0.0
|
||||
[0.8.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.8.0.0&rev_to=v0.7.0.0
|
||||
[0.7.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.7.0.0&rev_to=v0.6.1.0
|
||||
[0.6.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.6.1.0&rev_to=v0.6.0.0
|
||||
[0.6.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.6.0.0&rev_to=v0.5.1.0
|
||||
[0.5.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.1.0&rev_to=v0.5.0.1
|
||||
[0.5.0.1]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.0.1&rev_to=v0.5.0.0
|
||||
[0.5.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.0.0&rev_to=v0.4.0.0
|
||||
[0.4.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.4.0.0&rev_to=v0.3
|
||||
[0.3]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.3&rev_to=v0.2.1
|
||||
[0.2.1]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.2.1&rev_to=v0.2
|
||||
[0.2]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.2&rev_to=v0.1
|
||||
[1.5.0.1]: https://git.caraus.tech/OSS/graphql/compare/v1.5.0.0...v1.5.0.1
|
||||
[1.5.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.4.0.0...v1.5.0.0
|
||||
[1.4.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.3.0.0...v1.4.0.0
|
||||
[1.3.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.3...v1.3.0.0
|
||||
[1.2.0.3]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.2...v1.2.0.3
|
||||
[1.2.0.2]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.1...v1.2.0.2
|
||||
[1.2.0.1]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.0...v1.2.0.1
|
||||
[1.2.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.1.0.0...v1.2.0.0
|
||||
[1.1.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.3.0...v1.1.0.0
|
||||
[1.0.3.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.2.0...v1.0.3.0
|
||||
[1.0.2.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.1.0...v1.0.2.0
|
||||
[1.0.1.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.0.0...v1.0.1.0
|
||||
[1.0.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.11.1.0...v1.0.0.0
|
||||
[0.11.1.0]: https://git.caraus.tech/OSS/graphql/compare/v0.11.0.0...v0.11.1.0
|
||||
[0.11.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.10.0.0...v0.11.0.0
|
||||
[0.10.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.9.0.0...v0.10.0.0
|
||||
[0.9.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.8.0.0...v0.9.0.0
|
||||
[0.8.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.7.0.0...v0.8.0.0
|
||||
[0.7.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.6.1.0...v0.7.0.0
|
||||
[0.6.1.0]: https://git.caraus.tech/OSS/graphql/compare/v0.6.0.0...v0.6.1.0
|
||||
[0.6.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.5.1.0...v0.6.0.0
|
||||
[0.5.1.0]: https://git.caraus.tech/OSS/graphql/compare/v0.5.0.1...v0.5.1.0
|
||||
[0.5.0.1]: https://git.caraus.tech/OSS/graphql/compare/v0.5.0.0...v0.5.0.1
|
||||
[0.5.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.4.0.0...v0.5.0.0
|
||||
[0.4.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.3...v0.4.0.0
|
||||
[0.3]: https://git.caraus.tech/OSS/graphql/compare/v0.2.1...v0.3
|
||||
[0.2.1]: https://git.caraus.tech/OSS/graphql/compare/v0.2...v0.2.1
|
||||
[0.2]: https://git.caraus.tech/OSS/graphql/compare/v0.1...v0.2
|
||||
|
@ -1,15 +1,12 @@
|
||||
# GraphQL implementation in Haskell
|
||||
|
||||
[](https://www.simplehaskell.org)
|
||||
[](https://build.caraus.tech/go/pipelines)
|
||||
|
||||
See https://www.caraus.tech/projects/pub-graphql.
|
||||
See https://git.caraus.tech/OSS/graphql.
|
||||
|
||||
Report issues on the
|
||||
[bug tracker](https://www.caraus.tech/projects/pub-graphql/issues).
|
||||
[bug tracker](https://git.caraus.tech/OSS/graphql/issues).
|
||||
|
||||
API documentation is available through
|
||||
[Hackage](https://hackage.haskell.org/package/graphql).
|
||||
|
||||
Further documentation will be made available in the
|
||||
[Wiki](https://www.caraus.tech/projects/pub-graphql/wiki).
|
||||
[Wiki](https://git.caraus.tech/OSS/graphql/wiki).
|
||||
|
146
graphql.cabal
146
graphql.cabal
@ -1,110 +1,108 @@
|
||||
cabal-version: 2.2
|
||||
cabal-version: 3.0
|
||||
|
||||
name: graphql
|
||||
version: 1.0.1.0
|
||||
version: 1.5.0.1
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
category: Language
|
||||
homepage: https://www.caraus.tech/projects/pub-graphql
|
||||
bug-reports: https://www.caraus.tech/projects/pub-graphql/issues
|
||||
homepage: https://git.caraus.tech/OSS/graphql
|
||||
bug-reports: https://git.caraus.tech/OSS/graphql/issues
|
||||
author: Danny Navarro <j@dannynavarro.net>,
|
||||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
maintainer: belka@caraus.de
|
||||
copyright: (c) 2019-2021 Eugen Wissner,
|
||||
copyright: (c) 2019-2025 Eugen Wissner,
|
||||
(c) 2015-2017 J. Daniel Navarro
|
||||
license: MPL-2.0 AND BSD-3-Clause
|
||||
license-files: LICENSE,
|
||||
LICENSE.MPL
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
tested-with:
|
||||
GHC == 8.10.7
|
||||
, GHC == 9.0.1
|
||||
GHC == 9.10.1
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git://caraus.tech/pub/graphql.git
|
||||
location: https://git.caraus.tech/OSS/graphql.git
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Language.GraphQL
|
||||
Language.GraphQL.AST
|
||||
Language.GraphQL.AST.DirectiveLocation
|
||||
Language.GraphQL.AST.Document
|
||||
Language.GraphQL.AST.Encoder
|
||||
Language.GraphQL.AST.Lexer
|
||||
Language.GraphQL.AST.Parser
|
||||
Language.GraphQL.Error
|
||||
Language.GraphQL.Execute
|
||||
Language.GraphQL.Execute.Coerce
|
||||
Language.GraphQL.Execute.OrderedMap
|
||||
Language.GraphQL.TH
|
||||
Language.GraphQL.Type
|
||||
Language.GraphQL.Type.In
|
||||
Language.GraphQL.Type.Out
|
||||
Language.GraphQL.Type.Schema
|
||||
Language.GraphQL.Validate
|
||||
Language.GraphQL.Validate.Validation
|
||||
Test.Hspec.GraphQL
|
||||
Language.GraphQL
|
||||
Language.GraphQL.AST
|
||||
Language.GraphQL.AST.DirectiveLocation
|
||||
Language.GraphQL.AST.Document
|
||||
Language.GraphQL.AST.Encoder
|
||||
Language.GraphQL.AST.Lexer
|
||||
Language.GraphQL.AST.Parser
|
||||
Language.GraphQL.Error
|
||||
Language.GraphQL.Execute
|
||||
Language.GraphQL.Execute.Coerce
|
||||
Language.GraphQL.Execute.OrderedMap
|
||||
Language.GraphQL.Type
|
||||
Language.GraphQL.Type.In
|
||||
Language.GraphQL.Type.Out
|
||||
Language.GraphQL.Type.Schema
|
||||
Language.GraphQL.Validate
|
||||
Language.GraphQL.Validate.Validation
|
||||
other-modules:
|
||||
Language.GraphQL.Execute.Transform
|
||||
Language.GraphQL.Type.Definition
|
||||
Language.GraphQL.Type.Internal
|
||||
Language.GraphQL.Validate.Rules
|
||||
Language.GraphQL.Execute.Transform
|
||||
Language.GraphQL.Type.Definition
|
||||
Language.GraphQL.Type.Internal
|
||||
Language.GraphQL.Validate.Rules
|
||||
hs-source-dirs:
|
||||
src
|
||||
src
|
||||
ghc-options: -Wall
|
||||
|
||||
build-depends:
|
||||
aeson >= 1.5.6 && < 1.6
|
||||
, base >= 4.7 && < 5
|
||||
, conduit >= 1.3.4 && < 1.4
|
||||
, containers >= 0.6.2 && < 0.7
|
||||
, exceptions >= 0.10.4 && < 0.11
|
||||
, hspec-expectations >= 0.8.2 && < 0.9
|
||||
, megaparsec >= 9.0.1 && < 9.1
|
||||
, parser-combinators >= 1.3.0 && < 1.4
|
||||
, scientific >= 0.3.7 && < 0.4
|
||||
, template-haskell >= 2.16 && < 2.18
|
||||
, text >= 1.2.4 && < 1.3
|
||||
, transformers >= 0.5.6 && < 0.6
|
||||
, unordered-containers >= 0.2.14 && < 0.3
|
||||
, vector >= 0.12.3 && < 0.13
|
||||
base >= 4.15 && < 5,
|
||||
conduit ^>= 1.3.4,
|
||||
containers >= 0.6 && < 0.8,
|
||||
exceptions ^>= 0.10.4,
|
||||
megaparsec >= 9.0 && < 10,
|
||||
parser-combinators >= 1.3 && < 2,
|
||||
text >= 1.2 && < 3,
|
||||
transformers >= 0.5.6 && < 0.7,
|
||||
unordered-containers ^>= 0.2.14,
|
||||
vector >= 0.12 && < 0.14
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite graphql-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Language.GraphQL.AST.DocumentSpec
|
||||
Language.GraphQL.AST.EncoderSpec
|
||||
Language.GraphQL.AST.LexerSpec
|
||||
Language.GraphQL.AST.ParserSpec
|
||||
Language.GraphQL.ErrorSpec
|
||||
Language.GraphQL.Execute.CoerceSpec
|
||||
Language.GraphQL.Execute.OrderedMapSpec
|
||||
Language.GraphQL.ExecuteSpec
|
||||
Language.GraphQL.Type.OutSpec
|
||||
Language.GraphQL.Validate.RulesSpec
|
||||
Test.DirectiveSpec
|
||||
Test.FragmentSpec
|
||||
Test.RootOperationSpec
|
||||
Language.GraphQL.AST.DocumentSpec
|
||||
Language.GraphQL.AST.EncoderSpec
|
||||
Language.GraphQL.AST.LexerSpec
|
||||
Language.GraphQL.AST.ParserSpec
|
||||
Language.GraphQL.AST.Arbitrary
|
||||
Language.GraphQL.ErrorSpec
|
||||
Language.GraphQL.Execute.CoerceSpec
|
||||
Language.GraphQL.Execute.OrderedMapSpec
|
||||
Language.GraphQL.ExecuteSpec
|
||||
Language.GraphQL.Type.OutSpec
|
||||
Language.GraphQL.Validate.RulesSpec
|
||||
Schemas.HeroSchema
|
||||
hs-source-dirs:
|
||||
tests
|
||||
tests
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
|
||||
|
||||
build-depends:
|
||||
QuickCheck >= 2.14.1 && < 2.15
|
||||
, aeson
|
||||
, base >= 4.8 && < 5
|
||||
, conduit
|
||||
, exceptions
|
||||
, graphql
|
||||
, hspec >= 2.8.2 && < 2.9
|
||||
, hspec-megaparsec >= 2.2.0 && < 2.3
|
||||
, megaparsec
|
||||
, scientific
|
||||
, text
|
||||
, unordered-containers
|
||||
QuickCheck >= 2.14 && < 3,
|
||||
base,
|
||||
conduit,
|
||||
exceptions,
|
||||
graphql,
|
||||
hspec >= 2.10.9 && < 2.12,
|
||||
hspec-expectations ^>= 0.8.2,
|
||||
hspec-megaparsec ^>= 2.2.0,
|
||||
megaparsec,
|
||||
text,
|
||||
unordered-containers,
|
||||
containers,
|
||||
vector
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover
|
||||
default-language: Haskell2010
|
||||
|
@ -1,75 +1,46 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | This module provides the functions to parse and execute @GraphQL@ queries.
|
||||
module Language.GraphQL
|
||||
( graphql
|
||||
, graphqlSubs
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST
|
||||
import qualified Data.Text as Text
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute
|
||||
import qualified Language.GraphQL.Validate as Validate
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import Prelude hiding (null)
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||
-- executed using the given 'Schema'.
|
||||
graphql :: MonadCatch m
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
|
||||
graphql schema = graphqlSubs schema mempty mempty
|
||||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the substitution is
|
||||
-- applied to the query and the query is then executed using to the given
|
||||
-- 'Schema'.
|
||||
graphqlSubs :: MonadCatch m
|
||||
--
|
||||
-- An operation name can be given if the document contains multiple operations.
|
||||
graphql :: (MonadCatch m, VariableValue a, Serialize b)
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Maybe Text -- ^ Operation name.
|
||||
-> Aeson.Object -- ^ Variable substitution function.
|
||||
-> HashMap Full.Name a -- ^ Variable substitution function.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
|
||||
graphqlSubs schema operationName variableValues document' =
|
||||
case parse document "" document' of
|
||||
Left errorBundle -> pure . formatResponse <$> parseError errorBundle
|
||||
-> m (Either (ResponseEventStream m b) (Response b)) -- ^ Response.
|
||||
graphql schema operationName variableValues document' =
|
||||
case parse Full.document "" document' of
|
||||
Left errorBundle -> pure <$> parseError errorBundle
|
||||
Right parsed ->
|
||||
case validate parsed of
|
||||
Seq.Empty -> fmap formatResponse
|
||||
<$> execute schema operationName variableValues parsed
|
||||
Seq.Empty -> execute schema operationName variableValues parsed
|
||||
errors -> pure $ pure
|
||||
$ HashMap.singleton "errors"
|
||||
$ Aeson.toJSON
|
||||
$ Response null
|
||||
$ fromValidationError <$> errors
|
||||
where
|
||||
validate = Validate.document schema Validate.specifiedRules
|
||||
formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data''
|
||||
formatResponse (Response data'' errors') = HashMap.fromList
|
||||
[ ("data", data'')
|
||||
, ("errors", Aeson.toJSON $ fromError <$> errors')
|
||||
]
|
||||
fromError Error{..} = Aeson.object $ catMaybes
|
||||
[ Just ("message", Aeson.toJSON message)
|
||||
, toMaybe fromLocation "locations" locations
|
||||
, toMaybe fromPath "path" path
|
||||
]
|
||||
fromValidationError Validate.Error{..} = Aeson.object
|
||||
[ ("message", Aeson.toJSON message)
|
||||
, ("locations", Aeson.listValue fromLocation locations)
|
||||
]
|
||||
toMaybe _ _ [] = Nothing
|
||||
toMaybe f key xs = Just (key, Aeson.listValue f xs)
|
||||
fromPath (Segment segment) = Aeson.String segment
|
||||
fromPath (Index index) = Aeson.toJSON index
|
||||
fromLocation Location{..} = Aeson.object
|
||||
[ ("line", Aeson.toJSON line)
|
||||
, ("column", Aeson.toJSON column)
|
||||
]
|
||||
fromValidationError Validate.Error{..} = Error
|
||||
{ message = Text.pack message
|
||||
, locations = locations
|
||||
, path = []
|
||||
}
|
||||
|
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | Target AST for parser.
|
||||
|
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | 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.
|
||||
module Language.GraphQL.AST.DirectiveLocation
|
||||
( DirectiveLocation(..)
|
||||
|
@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
|
||||
@ -49,6 +50,8 @@ module Language.GraphQL.AST.Document
|
||||
, Value(..)
|
||||
, VariableDefinition(..)
|
||||
, escape
|
||||
, showVariableName
|
||||
, showVariable
|
||||
) where
|
||||
|
||||
import Data.Char (ord)
|
||||
@ -339,6 +342,12 @@ data VariableDefinition =
|
||||
VariableDefinition Name Type (Maybe (Node ConstValue)) Location
|
||||
deriving (Eq, Show)
|
||||
|
||||
showVariableName :: VariableDefinition -> String
|
||||
showVariableName (VariableDefinition name _ _ _) = "$" <> Text.unpack name
|
||||
|
||||
showVariable :: VariableDefinition -> String
|
||||
showVariable var@(VariableDefinition _ type' _ _) = showVariableName var <> ":" <> " " <> show type'
|
||||
|
||||
-- ** Type References
|
||||
|
||||
-- | Type representation.
|
||||
@ -363,8 +372,8 @@ data NonNullType
|
||||
deriving Eq
|
||||
|
||||
instance Show NonNullType where
|
||||
show (NonNullTypeNamed typeName) = '!' : Text.unpack typeName
|
||||
show (NonNullTypeList listType) = concat ["![", show listType, "]"]
|
||||
show (NonNullTypeNamed typeName) = Text.unpack $ typeName <> "!"
|
||||
show (NonNullTypeList listType) = concat ["[", show listType, "]!"]
|
||||
|
||||
-- ** Directives
|
||||
|
||||
@ -372,7 +381,11 @@ instance Show NonNullType where
|
||||
--
|
||||
-- Directives begin with "@", can accept arguments, and can be applied to the
|
||||
-- most GraphQL elements, providing additional information.
|
||||
data Directive = Directive Name [Argument] Location deriving (Eq, Show)
|
||||
data Directive = Directive
|
||||
{ name :: Name
|
||||
, arguments :: [Argument]
|
||||
, location :: Location
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- * Type System
|
||||
|
||||
@ -397,7 +410,7 @@ data TypeSystemDefinition
|
||||
= SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition)
|
||||
| TypeDefinition TypeDefinition
|
||||
| DirectiveDefinition
|
||||
Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)
|
||||
Description Name ArgumentsDefinition Bool (NonEmpty DirectiveLocation)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Type System Extensions
|
||||
@ -456,18 +469,23 @@ data SchemaExtension
|
||||
newtype Description = Description (Maybe Text)
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Semigroup Description
|
||||
where
|
||||
Description lhs <> Description rhs = Description $ lhs <> rhs
|
||||
|
||||
instance Monoid Description
|
||||
where
|
||||
mempty = Description mempty
|
||||
|
||||
-- ** Types
|
||||
|
||||
-- | Type definitions describe various user-defined types.
|
||||
data TypeDefinition
|
||||
= ScalarTypeDefinition Description Name [Directive]
|
||||
| ObjectTypeDefinition
|
||||
Description
|
||||
Name
|
||||
(ImplementsInterfaces [])
|
||||
[Directive]
|
||||
[FieldDefinition]
|
||||
| InterfaceTypeDefinition Description Name [Directive] [FieldDefinition]
|
||||
Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition]
|
||||
| InterfaceTypeDefinition
|
||||
Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition]
|
||||
| UnionTypeDefinition Description Name [Directive] (UnionMemberTypes [])
|
||||
| EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
|
||||
| InputObjectTypeDefinition
|
||||
|
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | This module defines a minifier and a printer for the @GraphQL@ language.
|
||||
@ -11,12 +12,14 @@ module Language.GraphQL.AST.Encoder
|
||||
, directive
|
||||
, document
|
||||
, minified
|
||||
, operationType
|
||||
, pretty
|
||||
, type'
|
||||
, typeSystemDefinition
|
||||
, value
|
||||
) where
|
||||
|
||||
import Data.Foldable (fold)
|
||||
import Data.Foldable (fold, Foldable (..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
@ -27,6 +30,7 @@ import qualified Data.Text.Lazy.Builder as Builder
|
||||
import Data.Text.Lazy.Builder.Int (decimal)
|
||||
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||
|
||||
-- | Instructs the encoder whether the GraphQL document should be minified or
|
||||
-- pretty printed.
|
||||
@ -34,7 +38,7 @@ import qualified Language.GraphQL.AST.Document as Full
|
||||
-- Use 'pretty' or 'minified' to construct the formatter.
|
||||
data Formatter
|
||||
= Minified
|
||||
| Pretty Word
|
||||
| Pretty !Word
|
||||
|
||||
-- | Constructs a formatter for pretty printing.
|
||||
pretty :: Formatter
|
||||
@ -53,7 +57,248 @@ document formatter defs
|
||||
encodeDocument = foldr executableDefinition [] defs
|
||||
executableDefinition (Full.ExecutableDefinition executableDefinition') acc =
|
||||
definition formatter executableDefinition' : acc
|
||||
executableDefinition _ acc = acc
|
||||
executableDefinition (Full.TypeSystemDefinition typeSystemDefinition' _location) acc =
|
||||
typeSystemDefinition formatter typeSystemDefinition' : acc
|
||||
executableDefinition (Full.TypeSystemExtension typeSystemExtension' _location) acc =
|
||||
typeSystemExtension formatter typeSystemExtension' : acc
|
||||
|
||||
directiveLocation :: DirectiveLocation.DirectiveLocation -> Lazy.Text
|
||||
directiveLocation = Lazy.Text.pack . show
|
||||
|
||||
withLineBreak :: Formatter -> Lazy.Text.Text -> Lazy.Text.Text
|
||||
withLineBreak formatter encodeDefinition
|
||||
| Pretty _ <- formatter = Lazy.Text.snoc encodeDefinition '\n'
|
||||
| Minified <- formatter = encodeDefinition
|
||||
|
||||
typeSystemExtension :: Formatter -> Full.TypeSystemExtension -> Lazy.Text
|
||||
typeSystemExtension formatter = \case
|
||||
Full.SchemaExtension schemaExtension' ->
|
||||
schemaExtension formatter schemaExtension'
|
||||
Full.TypeExtension typeExtension' -> typeExtension formatter typeExtension'
|
||||
|
||||
schemaExtension :: Formatter -> Full.SchemaExtension -> Lazy.Text
|
||||
schemaExtension formatter = \case
|
||||
Full.SchemaOperationExtension operationDirectives operationTypeDefinitions' ->
|
||||
withLineBreak formatter
|
||||
$ "extend schema "
|
||||
<> optempty (directives formatter) operationDirectives
|
||||
<> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
|
||||
Full.SchemaDirectivesExtension operationDirectives -> "extend schema "
|
||||
<> optempty (directives formatter) (NonEmpty.toList operationDirectives)
|
||||
|
||||
typeExtension :: Formatter -> Full.TypeExtension -> Lazy.Text
|
||||
typeExtension formatter = \case
|
||||
Full.ScalarTypeExtension name' directives'
|
||||
-> "extend scalar "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> directives formatter (NonEmpty.toList directives')
|
||||
Full.ObjectTypeFieldsDefinitionExtension name' ifaces' directives' fields'
|
||||
-> "extend type "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')
|
||||
Full.ObjectTypeDirectivesExtension name' ifaces' directives'
|
||||
-> "extend type "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
Full.ObjectTypeImplementsInterfacesExtension name' ifaces'
|
||||
-> "extend type "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||
Full.InterfaceTypeFieldsDefinitionExtension name' directives' fields'
|
||||
-> "extend interface "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')
|
||||
Full.InterfaceTypeDirectivesExtension name' directives'
|
||||
-> "extend interface "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
Full.UnionTypeUnionMemberTypesExtension name' directives' members'
|
||||
-> "extend union "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> unionMemberTypes formatter members'
|
||||
Full.UnionTypeDirectivesExtension name' directives'
|
||||
-> "extend union "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
Full.EnumTypeEnumValuesDefinitionExtension name' directives' members'
|
||||
-> "extend enum "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (enumValueDefinition formatter) (NonEmpty.toList members')
|
||||
Full.EnumTypeDirectivesExtension name' directives'
|
||||
-> "extend enum "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
Full.InputObjectTypeInputFieldsDefinitionExtension name' directives' fields'
|
||||
-> "extend input "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (inputValueDefinition nextFormatter) (NonEmpty.toList fields')
|
||||
Full.InputObjectTypeDirectivesExtension name' directives'
|
||||
-> "extend input "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
where
|
||||
nextFormatter = incrementIndent formatter
|
||||
|
||||
-- | Converts a t'Full.TypeSystemDefinition' into a string.
|
||||
typeSystemDefinition :: Formatter -> Full.TypeSystemDefinition -> Lazy.Text
|
||||
typeSystemDefinition formatter = \case
|
||||
Full.SchemaDefinition operationDirectives operationTypeDefinitions' ->
|
||||
withLineBreak formatter
|
||||
$ "schema "
|
||||
<> optempty (directives formatter) operationDirectives
|
||||
<> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
|
||||
Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
|
||||
Full.DirectiveDefinition description' name' arguments' repeatable locations
|
||||
-> description formatter description'
|
||||
<> "@"
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> argumentsDefinition formatter arguments'
|
||||
<> (if repeatable then " repeatable" else mempty)
|
||||
<> " on"
|
||||
<> pipeList formatter (directiveLocation <$> locations)
|
||||
|
||||
operationTypeDefinition :: Formatter -> Full.OperationTypeDefinition -> Lazy.Text.Text
|
||||
operationTypeDefinition formatter (Full.OperationTypeDefinition operationType' namedType')
|
||||
= indentLine (incrementIndent formatter)
|
||||
<> operationType formatter operationType'
|
||||
<> colon formatter
|
||||
<> Lazy.Text.fromStrict namedType'
|
||||
|
||||
fieldDefinition :: Formatter -> Full.FieldDefinition -> Lazy.Text.Text
|
||||
fieldDefinition formatter fieldDefinition' =
|
||||
let Full.FieldDefinition description' name' arguments' type'' directives' = fieldDefinition'
|
||||
in optempty (description formatter) description'
|
||||
<> indentLine formatter
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> argumentsDefinition formatter arguments'
|
||||
<> colon formatter
|
||||
<> type' type''
|
||||
<> optempty (directives formatter) directives'
|
||||
|
||||
argumentsDefinition :: Formatter -> Full.ArgumentsDefinition -> Lazy.Text.Text
|
||||
argumentsDefinition formatter (Full.ArgumentsDefinition arguments') =
|
||||
parensCommas formatter (argumentDefinition formatter) arguments'
|
||||
|
||||
argumentDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text
|
||||
argumentDefinition formatter definition' =
|
||||
let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'
|
||||
in optempty (description formatter) description'
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> colon formatter
|
||||
<> type' type''
|
||||
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
|
||||
<> directives formatter directives'
|
||||
|
||||
inputValueDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text
|
||||
inputValueDefinition formatter definition' =
|
||||
let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'
|
||||
in optempty (description formatter) description'
|
||||
<> indentLine formatter
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> colon formatter
|
||||
<> type' type''
|
||||
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
|
||||
<> directives formatter directives'
|
||||
|
||||
typeDefinition :: Formatter -> Full.TypeDefinition -> Lazy.Text
|
||||
typeDefinition formatter = \case
|
||||
Full.ScalarTypeDefinition description' name' directives'
|
||||
-> optempty (description formatter) description'
|
||||
<> "scalar "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
Full.ObjectTypeDefinition description' name' ifaces' directives' fields'
|
||||
-> optempty (description formatter) description'
|
||||
<> "type "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (fieldDefinition nextFormatter) fields'
|
||||
Full.InterfaceTypeDefinition description' name' ifaces' directives' fields'
|
||||
-> optempty (description formatter) description'
|
||||
<> "interface "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (fieldDefinition nextFormatter) fields'
|
||||
Full.UnionTypeDefinition description' name' directives' members'
|
||||
-> optempty (description formatter) description'
|
||||
<> "union "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> unionMemberTypes formatter members'
|
||||
Full.EnumTypeDefinition description' name' directives' members'
|
||||
-> optempty (description formatter) description'
|
||||
<> "enum "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (enumValueDefinition formatter) members'
|
||||
Full.InputObjectTypeDefinition description' name' directives' fields'
|
||||
-> optempty (description formatter) description'
|
||||
<> "input "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (inputValueDefinition nextFormatter) fields'
|
||||
where
|
||||
nextFormatter = incrementIndent formatter
|
||||
|
||||
implementsInterfaces :: Foldable t => Full.ImplementsInterfaces t -> Lazy.Text
|
||||
implementsInterfaces (Full.ImplementsInterfaces interfaces)
|
||||
| null interfaces = mempty
|
||||
| otherwise = Lazy.Text.fromStrict
|
||||
$ Text.append "implements "
|
||||
$ Text.intercalate " & "
|
||||
$ toList interfaces
|
||||
|
||||
unionMemberTypes :: Foldable t => Formatter -> Full.UnionMemberTypes t -> Lazy.Text
|
||||
unionMemberTypes formatter (Full.UnionMemberTypes memberTypes)
|
||||
| null memberTypes = mempty
|
||||
| otherwise = Lazy.Text.append "="
|
||||
$ pipeList formatter
|
||||
$ Lazy.Text.fromStrict
|
||||
<$> toList memberTypes
|
||||
|
||||
pipeList :: Foldable t => Formatter -> t Lazy.Text -> Lazy.Text
|
||||
pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList
|
||||
pipeList (Pretty _) = Lazy.Text.concat
|
||||
. fmap (("\n" <> indentSymbol <> "| ") <>)
|
||||
. toList
|
||||
|
||||
enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text
|
||||
enumValueDefinition (Pretty _) enumValue =
|
||||
let Full.EnumValueDefinition description' name' directives' = enumValue
|
||||
formatter = Pretty 1
|
||||
in description formatter description'
|
||||
<> indentLine formatter
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> directives formatter directives'
|
||||
enumValueDefinition Minified enumValue =
|
||||
let Full.EnumValueDefinition description' name' directives' = enumValue
|
||||
in description Minified description'
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> directives Minified directives'
|
||||
|
||||
description :: Formatter -> Full.Description -> Lazy.Text.Text
|
||||
description _formatter (Full.Description Nothing) = ""
|
||||
description formatter (Full.Description (Just description')) =
|
||||
stringValue formatter description'
|
||||
|
||||
-- | Converts a t'Full.ExecutableDefinition' into a string.
|
||||
definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
|
||||
@ -99,9 +344,9 @@ variableDefinition formatter variableDefinition' =
|
||||
let Full.VariableDefinition variableName variableType defaultValue' _ =
|
||||
variableDefinition'
|
||||
in variable variableName
|
||||
<> eitherFormat formatter ": " ":"
|
||||
<> colon formatter
|
||||
<> type' variableType
|
||||
<> maybe mempty (defaultValue formatter) (Full.node <$> defaultValue')
|
||||
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
|
||||
|
||||
defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text
|
||||
defaultValue formatter val
|
||||
@ -126,20 +371,26 @@ indent :: (Integral a) => a -> Lazy.Text
|
||||
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
|
||||
|
||||
selection :: Formatter -> Full.Selection -> Lazy.Text
|
||||
selection formatter = Lazy.Text.append indent' . encodeSelection
|
||||
selection formatter = Lazy.Text.append (indentLine formatter')
|
||||
. encodeSelection
|
||||
where
|
||||
encodeSelection (Full.FieldSelection fieldSelection) =
|
||||
field incrementIndent fieldSelection
|
||||
field formatter' fieldSelection
|
||||
encodeSelection (Full.InlineFragmentSelection fragmentSelection) =
|
||||
inlineFragment incrementIndent fragmentSelection
|
||||
inlineFragment formatter' fragmentSelection
|
||||
encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =
|
||||
fragmentSpread incrementIndent fragmentSelection
|
||||
incrementIndent
|
||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||
| otherwise = Minified
|
||||
indent'
|
||||
| Pretty indentation <- formatter = indent $ indentation + 1
|
||||
| otherwise = ""
|
||||
fragmentSpread formatter' fragmentSelection
|
||||
formatter' = incrementIndent formatter
|
||||
|
||||
indentLine :: Formatter -> Lazy.Text
|
||||
indentLine formatter
|
||||
| Pretty indentation <- formatter = indent indentation
|
||||
| otherwise = ""
|
||||
|
||||
incrementIndent :: Formatter -> Formatter
|
||||
incrementIndent formatter
|
||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||
| otherwise = Minified
|
||||
|
||||
colon :: Formatter -> Lazy.Text
|
||||
colon formatter = eitherFormat formatter ": " ":"
|
||||
@ -197,8 +448,10 @@ directive formatter (Full.Directive name args _)
|
||||
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
|
||||
|
||||
directives :: Formatter -> [Full.Directive] -> Lazy.Text
|
||||
directives Minified = spaces (directive Minified)
|
||||
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
|
||||
directives Minified values = spaces (directive Minified) values
|
||||
directives formatter values
|
||||
| null values = ""
|
||||
| otherwise = Lazy.Text.cons ' ' $ spaces (directive formatter) values
|
||||
|
||||
-- | Converts a 'Full.Value' into a string.
|
||||
value :: Formatter -> Full.Value -> Lazy.Text
|
||||
@ -294,6 +547,12 @@ nonNullType :: Full.NonNullType -> Lazy.Text
|
||||
nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
||||
nonNullType (Full.NonNullTypeList x) = listType x <> "!"
|
||||
|
||||
-- | Produces lowercase operation type: query, mutation or subscription.
|
||||
operationType :: Formatter -> Full.OperationType -> Lazy.Text
|
||||
operationType _formatter Full.Query = "query"
|
||||
operationType _formatter Full.Mutation = "mutation"
|
||||
operationType _formatter Full.Subscription = "subscription"
|
||||
|
||||
-- * Internal
|
||||
|
||||
between :: Char -> Char -> Lazy.Text -> Lazy.Text
|
||||
|
@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | This module defines a bunch of small parsers used to parse individual
|
||||
-- lexemes.
|
||||
@ -29,7 +31,8 @@ module Language.GraphQL.AST.Lexer
|
||||
, unicodeBOM
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..), liftA2)
|
||||
import Control.Applicative (Alternative(..))
|
||||
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
||||
import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord)
|
||||
import Data.Foldable (foldl')
|
||||
import Data.List (dropWhileEnd)
|
||||
@ -37,27 +40,28 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec ( Parsec
|
||||
, (<?>)
|
||||
, between
|
||||
, chunk
|
||||
, chunkToTokens
|
||||
, notFollowedBy
|
||||
, oneOf
|
||||
, option
|
||||
, optional
|
||||
, satisfy
|
||||
, sepBy
|
||||
, skipSome
|
||||
, takeP
|
||||
, takeWhile1P
|
||||
, try
|
||||
)
|
||||
import Text.Megaparsec
|
||||
( Parsec
|
||||
, (<?>)
|
||||
, between
|
||||
, chunk
|
||||
, chunkToTokens
|
||||
, notFollowedBy
|
||||
, oneOf
|
||||
, option
|
||||
, optional
|
||||
, satisfy
|
||||
, skipSome
|
||||
, takeP
|
||||
, takeWhile1P
|
||||
, try
|
||||
)
|
||||
import Text.Megaparsec.Char (char, digitChar, space1)
|
||||
import qualified Text.Megaparsec.Char.Lexer as Lexer
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Control.Monad (void)
|
||||
|
||||
-- | Standard parser.
|
||||
-- Accepts the type of the parsed token.
|
||||
@ -93,7 +97,7 @@ dollar = symbol "$"
|
||||
|
||||
-- | Parser for "@".
|
||||
at :: Parser ()
|
||||
at = symbol "@" >> pure ()
|
||||
at = void $ symbol "@"
|
||||
|
||||
-- | Parser for "&".
|
||||
amp :: Parser T.Text
|
||||
@ -101,7 +105,7 @@ amp = symbol "&"
|
||||
|
||||
-- | Parser for ":".
|
||||
colon :: Parser ()
|
||||
colon = symbol ":" >> pure ()
|
||||
colon = void $ symbol ":"
|
||||
|
||||
-- | Parser for "=".
|
||||
equals :: Parser T.Text
|
||||
@ -141,12 +145,13 @@ blockString :: Parser T.Text
|
||||
blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
|
||||
where
|
||||
stringValue = do
|
||||
byLine <- sepBy (many blockStringCharacter) lineTerminator
|
||||
let indentSize = foldr countIndent 0 $ tail byLine
|
||||
withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)
|
||||
byLine <- NonEmpty.sepBy1 (many blockStringCharacter) lineTerminator
|
||||
let indentSize = foldr countIndent 0 $ NonEmpty.tail byLine
|
||||
withoutIndent = NonEmpty.head byLine
|
||||
: (removeIndent indentSize <$> NonEmpty.tail byLine)
|
||||
withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent
|
||||
|
||||
return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
|
||||
pure $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
|
||||
removeEmptyLine [] = True
|
||||
removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)
|
||||
removeEmptyLine _ = False
|
||||
@ -179,10 +184,10 @@ name :: Parser T.Text
|
||||
name = do
|
||||
firstLetter <- nameFirstLetter
|
||||
rest <- many $ nameFirstLetter <|> digitChar
|
||||
_ <- spaceConsumer
|
||||
return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
|
||||
where
|
||||
nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
|
||||
void spaceConsumer
|
||||
pure $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
|
||||
where
|
||||
nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
|
||||
|
||||
isChunkDelimiter :: Char -> Bool
|
||||
isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']
|
||||
@ -196,31 +201,31 @@ lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"
|
||||
isSourceCharacter :: Char -> Bool
|
||||
isSourceCharacter = isSourceCharacter' . ord
|
||||
where
|
||||
isSourceCharacter' code = code >= 0x0020
|
||||
|| code == 0x0009
|
||||
|| code == 0x000a
|
||||
|| code == 0x000d
|
||||
isSourceCharacter' code
|
||||
= code >= 0x0020
|
||||
|| elem code [0x0009, 0x000a, 0x000d]
|
||||
|
||||
escapeSequence :: Parser Char
|
||||
escapeSequence = do
|
||||
_ <- char '\\'
|
||||
void $ char '\\'
|
||||
escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']
|
||||
case escaped of
|
||||
'b' -> return '\b'
|
||||
'f' -> return '\f'
|
||||
'n' -> return '\n'
|
||||
'r' -> return '\r'
|
||||
't' -> return '\t'
|
||||
'u' -> chr . foldl' step 0
|
||||
. chunkToTokens (Proxy :: Proxy T.Text)
|
||||
<$> takeP Nothing 4
|
||||
_ -> return escaped
|
||||
'b' -> pure '\b'
|
||||
'f' -> pure '\f'
|
||||
'n' -> pure '\n'
|
||||
'r' -> pure '\r'
|
||||
't' -> pure '\t'
|
||||
'u' -> chr
|
||||
. foldl' step 0
|
||||
. chunkToTokens (Proxy :: Proxy T.Text)
|
||||
<$> takeP Nothing 4
|
||||
_ -> pure escaped
|
||||
where
|
||||
step accumulator = (accumulator * 16 +) . digitToInt
|
||||
|
||||
-- | Parser for the "Byte Order Mark".
|
||||
unicodeBOM :: Parser ()
|
||||
unicodeBOM = optional (char '\xfeff') >> pure ()
|
||||
unicodeBOM = void $ optional $ char '\xfeff'
|
||||
|
||||
-- | Parses "extend" followed by a 'symbol'. It is used by schema extensions.
|
||||
extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a
|
||||
|
@ -2,13 +2,15 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | @GraphQL@ document parser.
|
||||
module Language.GraphQL.AST.Parser
|
||||
( document
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..), liftA2, optional)
|
||||
import Control.Applicative (Alternative(..), optional)
|
||||
import Control.Applicative.Combinators (sepBy1)
|
||||
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
@ -27,6 +29,7 @@ import Text.Megaparsec
|
||||
, unPos
|
||||
, (<?>)
|
||||
)
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
-- | Parser for the GraphQL documents.
|
||||
document :: Parser Full.Document
|
||||
@ -82,6 +85,7 @@ directiveDefinition description' = Full.DirectiveDefinition description'
|
||||
<* at
|
||||
<*> name
|
||||
<*> argumentsDefinition
|
||||
<*> (isJust <$> optional (symbol "repeatable"))
|
||||
<* symbol "on"
|
||||
<*> directiveLocations
|
||||
<?> "DirectiveDefinition"
|
||||
@ -212,6 +216,7 @@ interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||
interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
|
||||
<$ symbol "interface"
|
||||
<*> name
|
||||
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> directives
|
||||
<*> braces (many fieldDefinition)
|
||||
<?> "InterfaceTypeDefinition"
|
||||
@ -450,8 +455,8 @@ value = Full.Variable <$> variable
|
||||
<|> Full.Null <$ nullValue
|
||||
<|> Full.String <$> stringValue
|
||||
<|> Full.Enum <$> try enumValue
|
||||
<|> Full.List <$> brackets (some $ valueNode value)
|
||||
<|> Full.Object <$> braces (some $ objectField $ valueNode value)
|
||||
<|> Full.List <$> brackets (many $ valueNode value)
|
||||
<|> Full.Object <$> braces (many $ objectField $ valueNode value)
|
||||
<?> "Value"
|
||||
|
||||
constValue :: Parser Full.ConstValue
|
||||
|
@ -8,31 +8,22 @@
|
||||
|
||||
-- | Error handling.
|
||||
module Language.GraphQL.Error
|
||||
( CollectErrsT
|
||||
, Error(..)
|
||||
( Error(..)
|
||||
, Path(..)
|
||||
, Resolution(..)
|
||||
, ResolverException(..)
|
||||
, Response(..)
|
||||
, ResponseEventStream
|
||||
, addErr
|
||||
, addErrMsg
|
||||
, parseError
|
||||
, runCollectErrs
|
||||
, singleError
|
||||
) where
|
||||
|
||||
import Conduit
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Trans.State (StateT, modify, runStateT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Location(..), Name)
|
||||
import Language.GraphQL.AST (Location(..))
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import Prelude hiding (null)
|
||||
import Text.Megaparsec
|
||||
( ParseErrorBundle(..)
|
||||
@ -100,57 +91,3 @@ instance Show ResolverException where
|
||||
show (ResolverException e) = show e
|
||||
|
||||
instance Exception ResolverException
|
||||
|
||||
-- * Deprecated
|
||||
|
||||
-- | Runs the given query computation, but collects the errors into an error
|
||||
-- list, which is then sent back with the data.
|
||||
--
|
||||
-- /runCollectErrs was part of the old executor and isn't used anymore, it will
|
||||
-- be deprecated in the future and removed./
|
||||
runCollectErrs :: (Monad m, Serialize a)
|
||||
=> HashMap Name (Schema.Type m)
|
||||
-> CollectErrsT m a
|
||||
-> m (Response a)
|
||||
runCollectErrs types' res = do
|
||||
(dat, Resolution{..}) <- runStateT res
|
||||
$ Resolution{ errors = Seq.empty, types = types' }
|
||||
pure $ Response dat errors
|
||||
|
||||
-- | Executor context.
|
||||
--
|
||||
-- /Resolution was part of the old executor and isn't used anymore, it will be
|
||||
-- deprecated in the future and removed./
|
||||
data Resolution m = Resolution
|
||||
{ errors :: Seq Error
|
||||
, types :: HashMap Name (Schema.Type m)
|
||||
}
|
||||
|
||||
-- | A wrapper to pass error messages around.
|
||||
--
|
||||
-- /CollectErrsT was part of the old executor and isn't used anymore, it will be
|
||||
-- deprecated in the future and removed./
|
||||
type CollectErrsT m = StateT (Resolution m) m
|
||||
|
||||
-- | Adds an error to the list of errors.
|
||||
{-# DEPRECATED #-}
|
||||
addErr :: Monad m => Error -> CollectErrsT m ()
|
||||
addErr v = modify appender
|
||||
where
|
||||
appender :: Monad m => Resolution m -> Resolution m
|
||||
appender resolution@Resolution{..} = resolution{ errors = errors |> v }
|
||||
|
||||
{-# DEPRECATED #-}
|
||||
makeErrorMessage :: Text -> Error
|
||||
makeErrorMessage s = Error s [] []
|
||||
|
||||
-- | Constructs a response object containing only the error with the given
|
||||
-- message.
|
||||
{-# DEPRECATED #-}
|
||||
singleError :: Serialize a => Text -> Response a
|
||||
singleError message = Response null $ Seq.singleton $ Error message [] []
|
||||
|
||||
-- | Convenience function for just wrapping an error message.
|
||||
{-# DEPRECATED #-}
|
||||
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
|
||||
addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
|
||||
|
@ -39,6 +39,7 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Sequence (Seq)
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Typeable (cast)
|
||||
@ -61,6 +62,7 @@ import Language.GraphQL.Error
|
||||
, ResponseEventStream
|
||||
)
|
||||
import Prelude hiding (null)
|
||||
import Language.GraphQL.AST.Document (showVariableName)
|
||||
|
||||
newtype ExecutorT m a = ExecutorT
|
||||
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
|
||||
@ -187,35 +189,47 @@ data QueryError
|
||||
| CoercionError Full.VariableDefinition
|
||||
| UnknownInputType Full.VariableDefinition
|
||||
|
||||
type ExecuteHandler m a e = e -> ExecutorT m a
|
||||
|
||||
tell :: Monad m => Seq Error -> ExecutorT m ()
|
||||
tell = ExecutorT . lift . Writer.tell
|
||||
|
||||
operationNameErrorText :: Text
|
||||
operationNameErrorText = Text.unlines
|
||||
[ "Named operations must be provided with the name of the desired operation."
|
||||
, "See https://spec.graphql.org/June2018/#sec-Language.Document description."
|
||||
]
|
||||
|
||||
queryError :: QueryError -> Error
|
||||
queryError OperationNameRequired =
|
||||
Error{ message = "Operation name is required.", locations = [], path = [] }
|
||||
let queryErrorMessage = "Operation name is required. " <> operationNameErrorText
|
||||
in Error{ message = queryErrorMessage, locations = [], path = [] }
|
||||
queryError (OperationNotFound operationName) =
|
||||
let queryErrorMessage = Text.concat
|
||||
[ "Operation \""
|
||||
, Text.pack operationName
|
||||
, "\" not found."
|
||||
let queryErrorMessage = Text.unlines
|
||||
[ Text.concat
|
||||
[ "Operation \""
|
||||
, Text.pack operationName
|
||||
, "\" is not found in the named operations you've provided. "
|
||||
]
|
||||
, operationNameErrorText
|
||||
]
|
||||
in Error{ message = queryErrorMessage, locations = [], path = [] }
|
||||
queryError (CoercionError variableDefinition) =
|
||||
let Full.VariableDefinition variableName _ _ location = variableDefinition
|
||||
let (Full.VariableDefinition _ _ _ location) = variableDefinition
|
||||
queryErrorMessage = Text.concat
|
||||
[ "Failed to coerce the variable \""
|
||||
, variableName
|
||||
, "\"."
|
||||
[ "Failed to coerce the variable "
|
||||
, Text.pack $ Full.showVariable variableDefinition
|
||||
, "."
|
||||
]
|
||||
in Error{ message = queryErrorMessage, locations = [location], path = [] }
|
||||
queryError (UnknownInputType variableDefinition) =
|
||||
let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition
|
||||
let Full.VariableDefinition _ variableTypeName _ location = variableDefinition
|
||||
queryErrorMessage = Text.concat
|
||||
[ "Variable \""
|
||||
, variableName
|
||||
, "\" has unknown type \""
|
||||
[ "Variable "
|
||||
, Text.pack $ showVariableName variableDefinition
|
||||
, " has unknown type "
|
||||
, Text.pack $ show variableTypeName
|
||||
, "\"."
|
||||
, "."
|
||||
]
|
||||
in Error{ message = queryErrorMessage, locations = [location], path = [] }
|
||||
|
||||
@ -301,8 +315,7 @@ executeQuery topSelections schema = do
|
||||
pure $ Response data' errors
|
||||
|
||||
handleException :: (MonadCatch m, Serialize a)
|
||||
=> FieldException
|
||||
-> ExecutorT m a
|
||||
=> ExecuteHandler m a FieldException
|
||||
handleException (FieldException fieldLocation errorPath next) =
|
||||
let newError = constructError next fieldLocation errorPath
|
||||
in tell (Seq.singleton newError) >> pure null
|
||||
@ -375,44 +388,42 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
|
||||
, Handler (resolverHandler fieldLocation)
|
||||
]
|
||||
where
|
||||
fieldErrorPath = fieldsSegment fields : errorPath
|
||||
inputCoercionHandler :: (MonadCatch m, Serialize a)
|
||||
=> Full.Location
|
||||
-> InputCoercionException
|
||||
-> ExecutorT m a
|
||||
-> ExecuteHandler m a InputCoercionException
|
||||
inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) =
|
||||
let argumentLocation = getField @"location" valueNode
|
||||
in exceptionHandler argumentLocation e
|
||||
inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e
|
||||
resultHandler :: (MonadCatch m, Serialize a)
|
||||
=> Full.Location
|
||||
-> ResultException
|
||||
-> ExecutorT m a
|
||||
-> ExecuteHandler m a ResultException
|
||||
resultHandler = exceptionHandler
|
||||
resolverHandler :: (MonadCatch m, Serialize a)
|
||||
=> Full.Location
|
||||
-> ResolverException
|
||||
-> ExecutorT m a
|
||||
-> ExecuteHandler m a ResolverException
|
||||
resolverHandler = exceptionHandler
|
||||
nullResultHandler :: (MonadCatch m, Serialize a)
|
||||
=> FieldException
|
||||
-> ExecutorT m a
|
||||
nullResultHandler :: (MonadCatch m, Serialize a) => ExecuteHandler m a FieldException
|
||||
nullResultHandler e@(FieldException fieldLocation errorPath' next) =
|
||||
let newError = constructError next fieldLocation errorPath'
|
||||
in if Out.isNonNullType fieldType
|
||||
then throwM e
|
||||
else returnError newError
|
||||
exceptionHandler :: (Exception e, MonadCatch m, Serialize a)
|
||||
=> Full.Location
|
||||
-> ExecuteHandler m a e
|
||||
exceptionHandler errorLocation e =
|
||||
let newPath = fieldsSegment fields : errorPath
|
||||
newError = constructError e errorLocation newPath
|
||||
let newError = constructError e errorLocation fieldErrorPath
|
||||
in if Out.isNonNullType fieldType
|
||||
then throwM $ FieldException errorLocation newPath e
|
||||
then throwM $ FieldException errorLocation fieldErrorPath e
|
||||
else returnError newError
|
||||
returnError newError = tell (Seq.singleton newError) >> pure null
|
||||
go fieldName inputArguments = do
|
||||
argumentValues <- coerceArgumentValues argumentTypes inputArguments
|
||||
resolvedValue <-
|
||||
resolveFieldValue resolveFunction objectValue fieldName argumentValues
|
||||
completeValue fieldType fields errorPath resolvedValue
|
||||
completeValue fieldType fields fieldErrorPath resolvedValue
|
||||
(resolverField, resolveFunction) = resolverPair
|
||||
Out.Field _ fieldType argumentTypes = resolverField
|
||||
|
||||
@ -445,6 +456,7 @@ resolveAbstractType abstractType values'
|
||||
_ -> pure Nothing
|
||||
| otherwise = pure Nothing
|
||||
|
||||
-- https://spec.graphql.org/October2021/#sec-Value-Completion
|
||||
completeValue :: (MonadCatch m, Serialize a)
|
||||
=> Out.Type m
|
||||
-> NonEmpty (Transform.Field m)
|
||||
@ -454,12 +466,12 @@ completeValue :: (MonadCatch m, Serialize a)
|
||||
completeValue (Out.isNonNullType -> False) _ _ Type.Null =
|
||||
pure null
|
||||
completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)
|
||||
= foldM go (0, []) list >>= coerceResult outputType . List . snd
|
||||
= foldM go Vector.empty list >>= coerceResult outputType . List . Vector.toList
|
||||
where
|
||||
go (index, accumulator) listItem = do
|
||||
let updatedPath = Index index : errorPath
|
||||
completedValue <- completeValue listType fields updatedPath listItem
|
||||
pure (index + 1, completedValue : accumulator)
|
||||
go accumulator listItem =
|
||||
let updatedPath = Index (Vector.length accumulator) : errorPath
|
||||
in Vector.snoc accumulator
|
||||
<$> completeValue listType fields updatedPath listItem
|
||||
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
|
||||
coerceResult outputType $ Int int
|
||||
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
|
||||
@ -476,8 +488,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
|
||||
$ ValueCompletionException (show outputType)
|
||||
$ Type.Enum enum
|
||||
completeValue (Out.ObjectBaseType objectType) fields errorPath result
|
||||
= executeSelectionSet (mergeSelectionSets fields) objectType result
|
||||
$ fieldsSegment fields : errorPath
|
||||
= executeSelectionSet (mergeSelectionSets fields) objectType result errorPath
|
||||
completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result
|
||||
| Type.Object objectMap <- result = do
|
||||
let abstractType = Type.Internal.AbstractInterfaceType interfaceType
|
||||
@ -544,33 +555,24 @@ coerceArgumentValues argumentDefinitions argumentValues =
|
||||
$ Just inputValue
|
||||
| otherwise -> throwM
|
||||
$ InputCoercionException (Text.unpack argumentName) variableType Nothing
|
||||
|
||||
matchFieldValues' = matchFieldValues coerceArgumentValue
|
||||
$ Full.node <$> argumentValues
|
||||
coerceArgumentValue inputType (Transform.Int integer) =
|
||||
coerceInputLiteral inputType (Type.Int integer)
|
||||
coerceArgumentValue inputType (Transform.Boolean boolean) =
|
||||
coerceInputLiteral inputType (Type.Boolean boolean)
|
||||
coerceArgumentValue inputType (Transform.String string) =
|
||||
coerceInputLiteral inputType (Type.String string)
|
||||
coerceArgumentValue inputType (Transform.Float float) =
|
||||
coerceInputLiteral inputType (Type.Float float)
|
||||
coerceArgumentValue inputType (Transform.Enum enum) =
|
||||
coerceInputLiteral inputType (Type.Enum enum)
|
||||
coerceArgumentValue inputType Transform.Null
|
||||
| In.isNonNullType inputType = Nothing
|
||||
| otherwise = coerceInputLiteral inputType Type.Null
|
||||
coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
|
||||
let coerceItem = coerceArgumentValue inputType
|
||||
in Type.List <$> traverse coerceItem list
|
||||
coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
|
||||
| In.InputObjectType _ _ inputFields <- inputType =
|
||||
let go = forEachField object
|
||||
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
|
||||
in Type.Object <$> resultMap
|
||||
coerceArgumentValue _ (Transform.Variable variable) = pure variable
|
||||
coerceArgumentValue _ _ = Nothing
|
||||
forEachField object variableName (In.InputField _ variableType defaultValue) =
|
||||
matchFieldValues coerceArgumentValue object variableName variableType defaultValue
|
||||
|
||||
coerceArgumentValue inputType transform =
|
||||
coerceInputLiteral inputType $ extractArgumentValue transform
|
||||
|
||||
extractArgumentValue (Transform.Int integer) = Type.Int integer
|
||||
extractArgumentValue (Transform.Boolean boolean) = Type.Boolean boolean
|
||||
extractArgumentValue (Transform.String string) = Type.String string
|
||||
extractArgumentValue (Transform.Float float) = Type.Float float
|
||||
extractArgumentValue (Transform.Enum enum) = Type.Enum enum
|
||||
extractArgumentValue Transform.Null = Type.Null
|
||||
extractArgumentValue (Transform.List list) =
|
||||
Type.List $ extractArgumentValue <$> list
|
||||
extractArgumentValue (Transform.Object object) =
|
||||
Type.Object $ extractArgumentValue <$> object
|
||||
extractArgumentValue (Transform.Variable variable) = variable
|
||||
|
||||
collectFields :: Monad m
|
||||
=> Out.ObjectType m
|
||||
|
@ -15,7 +15,6 @@ module Language.GraphQL.Execute.Coerce
|
||||
, matchFieldValues
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Int (Int32)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
@ -24,7 +23,6 @@ import Data.Text (Text)
|
||||
import qualified Data.Text.Lazy as Text.Lazy
|
||||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
|
||||
import Data.Scientific (toBoundedInteger, toRealFloat)
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
|
||||
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
|
||||
@ -61,20 +59,13 @@ class VariableValue a where
|
||||
-> a -- ^ Variable value being coerced.
|
||||
-> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise.
|
||||
|
||||
instance VariableValue Aeson.Value where
|
||||
coerceVariableValue _ Aeson.Null = Just Type.Null
|
||||
coerceVariableValue (In.ScalarBaseType scalarType) value
|
||||
| (Aeson.String stringValue) <- value = Just $ Type.String stringValue
|
||||
| (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
|
||||
| (Aeson.Number numberValue) <- value
|
||||
, (Type.ScalarType "Float" _) <- scalarType =
|
||||
Just $ Type.Float $ toRealFloat numberValue
|
||||
| (Aeson.Number numberValue) <- value = -- ID or Int
|
||||
Type.Int <$> toBoundedInteger numberValue
|
||||
coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
|
||||
instance VariableValue Type.Value where
|
||||
coerceVariableValue _ Type.Null = Just Type.Null
|
||||
coerceVariableValue (In.ScalarBaseType _) value = Just value
|
||||
coerceVariableValue (In.EnumBaseType _) (Type.Enum stringValue) =
|
||||
Just $ Type.Enum stringValue
|
||||
coerceVariableValue (In.InputObjectBaseType objectType) value
|
||||
| (Aeson.Object objectValue) <- value = do
|
||||
| (Type.Object objectValue) <- value = do
|
||||
let (In.InputObjectType _ _ inputFields) = objectType
|
||||
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
|
||||
if HashMap.null newObjectValue
|
||||
@ -94,14 +85,9 @@ instance VariableValue Aeson.Value where
|
||||
pure (newObjectValue, insert coerced)
|
||||
Nothing -> Just (objectValue, resultMap)
|
||||
coerceVariableValue (In.ListBaseType listType) value
|
||||
| (Aeson.Array arrayValue) <- value =
|
||||
Type.List <$> foldr foldVector (Just []) arrayValue
|
||||
| (Type.List arrayValue) <- value =
|
||||
Type.List <$> traverse (coerceVariableValue listType) arrayValue
|
||||
| otherwise = coerceVariableValue listType value
|
||||
where
|
||||
foldVector _ Nothing = Nothing
|
||||
foldVector variableValue (Just list) = do
|
||||
coerced <- coerceVariableValue listType variableValue
|
||||
pure $ coerced : list
|
||||
coerceVariableValue _ _ = Nothing
|
||||
|
||||
-- | Looks up a value by name in the given map, coerces it and inserts into the
|
||||
@ -161,7 +147,7 @@ coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)
|
||||
| member enumValue type' = Just $ Type.Enum enumValue
|
||||
where
|
||||
member value (Type.EnumType _ _ members) = HashMap.member value members
|
||||
coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) =
|
||||
coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) =
|
||||
let (In.InputObjectType _ _ inputFields) = type'
|
||||
in Type.Object
|
||||
<$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields
|
||||
@ -216,23 +202,23 @@ data Output a
|
||||
instance forall a. IsString (Output a) where
|
||||
fromString = String . fromString
|
||||
|
||||
instance Serialize Aeson.Value where
|
||||
instance Serialize Type.Value where
|
||||
null = Type.Null
|
||||
serialize (Out.ScalarBaseType scalarType) value
|
||||
| Type.ScalarType "Int" _ <- scalarType
|
||||
, Int int <- value = Just $ Aeson.toJSON int
|
||||
, Int int <- value = Just $ Type.Int int
|
||||
| Type.ScalarType "Float" _ <- scalarType
|
||||
, Float float <- value = Just $ Aeson.toJSON float
|
||||
, Float float <- value = Just $ Type.Float float
|
||||
| Type.ScalarType "String" _ <- scalarType
|
||||
, String string <- value = Just $ Aeson.String string
|
||||
, String string <- value = Just $ Type.String string
|
||||
| Type.ScalarType "ID" _ <- scalarType
|
||||
, String string <- value = Just $ Aeson.String string
|
||||
, String string <- value = Just $ Type.String string
|
||||
| Type.ScalarType "Boolean" _ <- scalarType
|
||||
, Boolean boolean <- value = Just $ Aeson.Bool boolean
|
||||
serialize _ (Enum enum) = Just $ Aeson.String enum
|
||||
serialize _ (List list) = Just $ Aeson.toJSON list
|
||||
, Boolean boolean <- value = Just $ Type.Boolean boolean
|
||||
serialize _ (Enum enum) = Just $ Type.Enum enum
|
||||
serialize _ (List list) = Just $ Type.List list
|
||||
serialize _ (Object object) = Just
|
||||
$ Aeson.object
|
||||
$ OrderedMap.toList
|
||||
$ Aeson.toJSON <$> object
|
||||
$ Type.Object
|
||||
$ HashMap.fromList
|
||||
$ OrderedMap.toList object
|
||||
serialize _ _ = Nothing
|
||||
null = Aeson.Null
|
||||
|
@ -1,38 +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/. -}
|
||||
|
||||
-- | Template Haskell helpers.
|
||||
module Language.GraphQL.TH
|
||||
( gql
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter(..))
|
||||
import Language.Haskell.TH (Exp(..), Lit(..))
|
||||
|
||||
stripIndentation :: String -> String
|
||||
stripIndentation code = reverse
|
||||
$ dropNewlines
|
||||
$ reverse
|
||||
$ unlines
|
||||
$ indent spaces <$> lines withoutLeadingNewlines
|
||||
where
|
||||
indent 0 xs = xs
|
||||
indent count (' ' : xs) = indent (count - 1) xs
|
||||
indent _ xs = xs
|
||||
withoutLeadingNewlines = dropNewlines code
|
||||
dropNewlines = dropWhile (== '\n')
|
||||
spaces = length $ takeWhile (== ' ') withoutLeadingNewlines
|
||||
|
||||
-- | Removes leading and trailing newlines. Indentation of the first line is
|
||||
-- removed from each line of the string.
|
||||
gql :: QuasiQuoter
|
||||
gql = QuasiQuoter
|
||||
{ quoteExp = pure . LitE . StringL . stripIndentation
|
||||
, quotePat = const
|
||||
$ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)"
|
||||
, quoteType = const
|
||||
$ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)"
|
||||
, quoteDec = const
|
||||
$ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)"
|
||||
}
|
@ -3,6 +3,7 @@
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | Types that can be used as both input and output types.
|
||||
@ -18,6 +19,8 @@ module Language.GraphQL.Type.Definition
|
||||
, float
|
||||
, id
|
||||
, int
|
||||
, showNonNullType
|
||||
, showNonNullListType
|
||||
, selection
|
||||
, string
|
||||
) where
|
||||
@ -207,3 +210,11 @@ include = handle include'
|
||||
(Just (Boolean True)) -> Include directive'
|
||||
_ -> Skip
|
||||
include' directive' = Continue directive'
|
||||
|
||||
showNonNullType :: Show a => a -> String
|
||||
showNonNullType = (++ "!") . show
|
||||
|
||||
showNonNullListType :: Show a => a -> String
|
||||
showNonNullListType listType =
|
||||
let representation = show listType
|
||||
in concat ["[", representation, "]!"]
|
||||
|
@ -3,6 +3,7 @@
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
@ -66,13 +67,15 @@ instance Show Type where
|
||||
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, "]"]
|
||||
show (NonNullScalarType scalarType) = Definition.showNonNullType scalarType
|
||||
show (NonNullEnumType enumType) = Definition.showNonNullType enumType
|
||||
show (NonNullInputObjectType inputObjectType) =
|
||||
Definition.showNonNullType inputObjectType
|
||||
show (NonNullListType baseType) = Definition.showNonNullListType baseType
|
||||
|
||||
-- | Field argument definition.
|
||||
data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
|
||||
deriving Eq
|
||||
|
||||
-- | Field argument definitions.
|
||||
type Arguments = HashMap Name Argument
|
||||
|
@ -48,7 +48,11 @@ data Type m
|
||||
deriving Eq
|
||||
|
||||
-- | Directive definition.
|
||||
data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments
|
||||
--
|
||||
-- A definition consists of an optional description, arguments, whether the
|
||||
-- directive is repeatable, and the allowed directive locations.
|
||||
data Directive = Directive (Maybe Text) In.Arguments Bool [DirectiveLocation]
|
||||
deriving Eq
|
||||
|
||||
-- | Directive definitions.
|
||||
type Directives = HashMap Full.Name Directive
|
||||
|
@ -115,12 +115,12 @@ instance forall a. Show (Type a) where
|
||||
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, "]"]
|
||||
show (NonNullScalarType scalarType) = showNonNullType scalarType
|
||||
show (NonNullEnumType enumType) = showNonNullType enumType
|
||||
show (NonNullObjectType inputObjectType) = showNonNullType inputObjectType
|
||||
show (NonNullInterfaceType interfaceType) = showNonNullType interfaceType
|
||||
show (NonNullUnionType unionType) = showNonNullType unionType
|
||||
show (NonNullListType baseType) = showNonNullListType baseType
|
||||
|
||||
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
|
||||
pattern ScalarBaseType :: forall m. ScalarType -> Type m
|
||||
|
@ -85,15 +85,16 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
|
||||
[ ("skip", skipDirective)
|
||||
, ("include", includeDirective)
|
||||
, ("deprecated", deprecatedDirective)
|
||||
, ("specifiedBy", specifiedByDirective)
|
||||
]
|
||||
includeDirective =
|
||||
Directive includeDescription skipIncludeLocations includeArguments
|
||||
Directive includeDescription includeArguments False skipIncludeLocations
|
||||
includeArguments = HashMap.singleton "if"
|
||||
$ In.Argument (Just "Included when true.") ifType Nothing
|
||||
includeDescription = Just
|
||||
"Directs the executor to include this field or fragment only when the \
|
||||
\`if` argument is true."
|
||||
skipDirective = Directive skipDescription skipIncludeLocations skipArguments
|
||||
skipDirective = Directive skipDescription skipArguments False skipIncludeLocations
|
||||
skipArguments = HashMap.singleton "if"
|
||||
$ In.Argument (Just "skipped when true.") ifType Nothing
|
||||
ifType = In.NonNullScalarType Definition.boolean
|
||||
@ -106,16 +107,15 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
|
||||
, ExecutableDirectiveLocation DirectiveLocation.InlineFragment
|
||||
]
|
||||
deprecatedDirective =
|
||||
Directive deprecatedDescription deprecatedLocations deprecatedArguments
|
||||
Directive deprecatedDescription deprecatedArguments False deprecatedLocations
|
||||
reasonDescription = Just
|
||||
"Explains why this element was deprecated, usually also including a \
|
||||
\suggestion for how to access supported similar data. Formatted using \
|
||||
\the Markdown syntax, as specified by \
|
||||
\[CommonMark](https://commonmark.org/).'"
|
||||
deprecatedArguments = HashMap.singleton "reason"
|
||||
$ In.Argument reasonDescription reasonType
|
||||
$ In.Argument reasonDescription (In.NamedScalarType Definition.string)
|
||||
$ Just "No longer supported"
|
||||
reasonType = In.NamedScalarType Definition.string
|
||||
deprecatedDescription = Just
|
||||
"Marks an element of a GraphQL schema as no longer supported."
|
||||
deprecatedLocations =
|
||||
@ -124,6 +124,16 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
|
||||
, TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
|
||||
, TypeSystemDirectiveLocation DirectiveLocation.EnumValue
|
||||
]
|
||||
specifiedByDirective =
|
||||
Directive specifiedByDescription specifiedByArguments False specifiedByLocations
|
||||
urlDescription = Just
|
||||
"The URL that specifies the behavior of this scalar."
|
||||
specifiedByArguments = HashMap.singleton "url"
|
||||
$ In.Argument urlDescription (In.NonNullScalarType Definition.string) Nothing
|
||||
specifiedByDescription = Just
|
||||
"Exposes a URL that specifies the behavior of this scalar."
|
||||
specifiedByLocations =
|
||||
[TypeSystemDirectiveLocation DirectiveLocation.Scalar]
|
||||
|
||||
-- | Traverses the schema and finds all referenced types.
|
||||
collectReferencedTypes :: forall m
|
||||
@ -205,5 +215,5 @@ collectImplementations = HashMap.foldr go HashMap.empty
|
||||
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
|
||||
add implementation (Out.InterfaceType typeName _ _ _) =
|
||||
HashMap.insertWith (++) typeName [implementation]
|
||||
|
@ -200,7 +200,7 @@ typeSystemDefinition context rule = \case
|
||||
directives context rule schemaLocation directives'
|
||||
Full.TypeDefinition typeDefinition' ->
|
||||
typeDefinition context rule typeDefinition'
|
||||
Full.DirectiveDefinition _ _ arguments' _ ->
|
||||
Full.DirectiveDefinition _ _ arguments' _ _ ->
|
||||
argumentsDefinition context rule arguments'
|
||||
|
||||
typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
|
||||
@ -210,7 +210,7 @@ typeDefinition context rule = \case
|
||||
Full.ObjectTypeDefinition _ _ _ directives' fields
|
||||
-> directives context rule objectLocation directives'
|
||||
>< foldMap (fieldDefinition context rule) fields
|
||||
Full.InterfaceTypeDefinition _ _ directives' fields
|
||||
Full.InterfaceTypeDefinition _ _ _ directives' fields
|
||||
-> directives context rule interfaceLocation directives'
|
||||
>< foldMap (fieldDefinition context rule) fields
|
||||
Full.UnionTypeDefinition _ _ directives' _ ->
|
||||
@ -283,7 +283,7 @@ operationDefinition rule context operation
|
||||
schema' = Validation.schema context
|
||||
queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'
|
||||
types' = Schema.types schema'
|
||||
|
||||
|
||||
typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
|
||||
typeToOut (Schema.ObjectType objectType) =
|
||||
Just $ Out.NamedObjectType objectType
|
||||
@ -403,7 +403,7 @@ arguments :: forall m
|
||||
-> Seq (Validation.RuleT m)
|
||||
arguments rule argumentTypes = foldMap forEach . Seq.fromList
|
||||
where
|
||||
forEach argument'@(Full.Argument argumentName _ _) =
|
||||
forEach argument'@(Full.Argument argumentName _ _) =
|
||||
let argumentType = HashMap.lookup argumentName argumentTypes
|
||||
in argument rule argumentType argument'
|
||||
|
||||
@ -482,4 +482,4 @@ directive context rule (Full.Directive directiveName arguments' _) =
|
||||
$ Validation.schema context
|
||||
in arguments rule argumentTypes arguments'
|
||||
where
|
||||
directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes
|
||||
directiveArguments (Schema.Directive _ argumentTypes _ _) = argumentTypes
|
||||
|
@ -2,11 +2,13 @@
|
||||
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 DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
-- | This module contains default rules defined in the GraphQL specification.
|
||||
@ -48,19 +50,21 @@ import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT)
|
||||
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Foldable (find, fold, foldl', toList)
|
||||
import Data.Foldable (Foldable(..), find)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.List (groupBy, sortBy, sortOn)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.List (sortBy)
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Ord (comparing)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import GHC.Records (HasField(..))
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.Internal as Type
|
||||
@ -133,26 +137,29 @@ singleFieldSubscriptionsRule :: forall m. Rule m
|
||||
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
|
||||
Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do
|
||||
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
|
||||
case HashSet.size groupedFieldSet of
|
||||
1 -> lift mempty
|
||||
_
|
||||
| Just name <- name' -> pure $ Error
|
||||
{ message = concat
|
||||
[ "Subscription \""
|
||||
, Text.unpack name
|
||||
, "\" must select only one top level field."
|
||||
]
|
||||
, locations = [location']
|
||||
}
|
||||
| otherwise -> pure $ Error
|
||||
{ message = errorMessage
|
||||
, locations = [location']
|
||||
}
|
||||
case HashSet.toList groupedFieldSet of
|
||||
[rootName]
|
||||
| Text.isPrefixOf "__" rootName -> makeError location' name'
|
||||
"exactly one top level field, which must not be an introspection field."
|
||||
| otherwise -> lift mempty
|
||||
[] -> makeError location' name' "exactly one top level field."
|
||||
_ -> makeError location' name' "only one top level field."
|
||||
_ -> lift mempty
|
||||
where
|
||||
errorMessage =
|
||||
"Anonymous Subscription must select only one top level field."
|
||||
collectFields selectionSet = foldM forEach HashSet.empty selectionSet
|
||||
makeError location' (Just operationName) errorLine = pure $ Error
|
||||
{ message = concat
|
||||
[ "Subscription \""
|
||||
, Text.unpack operationName
|
||||
, "\" must select "
|
||||
, errorLine
|
||||
]
|
||||
, locations = [location']
|
||||
}
|
||||
makeError location' Nothing errorLine = pure $ Error
|
||||
{ message = "Anonymous Subscription must select " <> errorLine
|
||||
, locations = [location']
|
||||
}
|
||||
collectFields = foldM forEach HashSet.empty
|
||||
forEach accumulator = \case
|
||||
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
|
||||
Full.FragmentSpreadSelection fragmentSelection ->
|
||||
@ -250,14 +257,16 @@ findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])
|
||||
-> Full.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 mempty
|
||||
findDuplicates filterByName thisLocation errorMessage =
|
||||
asks ast >>= go . foldr filterByName []
|
||||
where
|
||||
error' locations' = Error
|
||||
go locations' =
|
||||
case locations' of
|
||||
headLocation : otherLocations -- length locations' > 1
|
||||
| not $ null otherLocations
|
||||
, headLocation == thisLocation -> pure $ makeError locations'
|
||||
_ -> lift mempty
|
||||
makeError locations' = Error
|
||||
{ message = errorMessage
|
||||
, locations = locations'
|
||||
}
|
||||
@ -472,7 +481,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
||||
collectCycles :: Traversable t
|
||||
=> t Full.Selection
|
||||
-> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
|
||||
collectCycles selectionSet = foldM forEach HashMap.empty selectionSet
|
||||
collectCycles = foldM forEach HashMap.empty
|
||||
forEach accumulator = \case
|
||||
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
|
||||
Full.InlineFragmentSelection fragmentSelection ->
|
||||
@ -527,16 +536,20 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
||||
-- used, the expected metadata or behavior becomes ambiguous, therefore only one
|
||||
-- of each directive is allowed per location.
|
||||
uniqueDirectiveNamesRule :: forall m. Rule m
|
||||
uniqueDirectiveNamesRule = DirectivesRule
|
||||
$ const $ lift . filterDuplicates extract "directive"
|
||||
uniqueDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
|
||||
definitions' <- asks $ Schema.directives . schema
|
||||
let filterNonRepeatable = flip HashSet.member nonRepeatableSet
|
||||
. getField @"name"
|
||||
nonRepeatableSet =
|
||||
HashMap.foldlWithKey foldNonRepeatable HashSet.empty definitions'
|
||||
lift $ filterDuplicates extract "directive"
|
||||
$ filter filterNonRepeatable directives'
|
||||
where
|
||||
extract (Full.Directive directiveName _ location') =
|
||||
(directiveName, location')
|
||||
|
||||
groupSorted :: forall a. (a -> Text) -> [a] -> [[a]]
|
||||
groupSorted getName = groupBy equalByName . sortOn getName
|
||||
where
|
||||
equalByName lhs rhs = getName lhs == getName rhs
|
||||
foldNonRepeatable hashSet directiveName' (Schema.Directive _ _ False _) =
|
||||
HashSet.insert directiveName' hashSet
|
||||
foldNonRepeatable hashSet _ _ = hashSet
|
||||
extract (Full.Directive directiveName' _ location') =
|
||||
(directiveName', location')
|
||||
|
||||
filterDuplicates :: forall a
|
||||
. (a -> (Text, Full.Location))
|
||||
@ -546,12 +559,12 @@ filterDuplicates :: forall a
|
||||
filterDuplicates extract nodeType = Seq.fromList
|
||||
. fmap makeError
|
||||
. filter ((> 1) . length)
|
||||
. groupSorted getName
|
||||
. NonEmpty.groupAllWith getName
|
||||
where
|
||||
getName = fst . extract
|
||||
makeError directives' = Error
|
||||
{ message = makeMessage $ head directives'
|
||||
, locations = snd . extract <$> directives'
|
||||
{ message = makeMessage $ NonEmpty.head directives'
|
||||
, locations = snd . extract <$> toList directives'
|
||||
}
|
||||
makeMessage directive = concat
|
||||
[ "There can be only one "
|
||||
@ -618,6 +631,10 @@ noUndefinedVariablesRule =
|
||||
, "\"."
|
||||
]
|
||||
|
||||
-- Used to find the difference between defined and used variables. The first
|
||||
-- argument are variables defined in the operation, the second argument are
|
||||
-- variables used in the query. It should return the difference between these
|
||||
-- 2 sets.
|
||||
type UsageDifference
|
||||
= HashMap Full.Name [Full.Location]
|
||||
-> HashMap Full.Name [Full.Location]
|
||||
@ -664,11 +681,17 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
|
||||
= filterSelections' selections
|
||||
>>= lift . mapReaderT (<> mapDirectives directives') . pure
|
||||
findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments
|
||||
mapArguments = Seq.fromList . mapMaybe findArgumentVariables
|
||||
mapArguments = Seq.fromList . (>>= findArgumentVariables)
|
||||
mapDirectives = foldMap findDirectiveVariables
|
||||
findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) =
|
||||
Just (value', [location])
|
||||
findArgumentVariables _ = Nothing
|
||||
|
||||
findArgumentVariables (Full.Argument _ value _) = findNodeVariables value
|
||||
findNodeVariables Full.Node{ node = value, ..} = findValueVariables location value
|
||||
|
||||
findValueVariables location (Full.Variable value') = [(value', [location])]
|
||||
findValueVariables _ (Full.List values) = values >>= findNodeVariables
|
||||
findValueVariables _ (Full.Object fields) = fields
|
||||
>>= findNodeVariables . getField @"value"
|
||||
findValueVariables _ _ = []
|
||||
makeError operationName (variableName, locations') = Error
|
||||
{ message = errorMessage operationName variableName
|
||||
, locations = locations'
|
||||
@ -702,8 +725,7 @@ uniqueInputFieldNamesRule =
|
||||
where
|
||||
go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields
|
||||
go _ = mempty
|
||||
filterFieldDuplicates fields =
|
||||
filterDuplicates getFieldName "input field" fields
|
||||
filterFieldDuplicates = filterDuplicates getFieldName "input field"
|
||||
getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location')
|
||||
constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields
|
||||
constGo _ = mempty
|
||||
@ -821,7 +843,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
||||
. Schema.directives . schema
|
||||
Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments
|
||||
case available of
|
||||
Just (Schema.Directive _ _ definitions)
|
||||
Just (Schema.Directive _ definitions _ _)
|
||||
| not $ HashMap.member argumentName definitions ->
|
||||
pure $ makeError argumentName directiveName location'
|
||||
_ -> lift mempty
|
||||
@ -837,23 +859,23 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
||||
, "\"."
|
||||
]
|
||||
|
||||
-- | GraphQL servers define what directives they support. For each usage of a
|
||||
-- directive, the directive must be available on that server.
|
||||
-- | GraphQL services define what directives they support. For each usage of a
|
||||
-- directive, the directive must be available on that service.
|
||||
knownDirectiveNamesRule :: Rule m
|
||||
knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
|
||||
definitions' <- asks $ Schema.directives . schema
|
||||
let directiveSet = HashSet.fromList $ fmap directiveName directives'
|
||||
let definitionSet = HashSet.fromList $ HashMap.keys definitions'
|
||||
let difference = HashSet.difference directiveSet definitionSet
|
||||
let undefined' = filter (definitionFilter difference) directives'
|
||||
let directiveSet = HashSet.fromList $ fmap (getField @"name") directives'
|
||||
definitionSet = HashSet.fromList $ HashMap.keys definitions'
|
||||
difference = HashSet.difference directiveSet definitionSet
|
||||
undefined' = filter (definitionFilter difference) directives'
|
||||
lift $ Seq.fromList $ makeError <$> undefined'
|
||||
where
|
||||
definitionFilter :: HashSet Full.Name -> Full.Directive -> Bool
|
||||
definitionFilter difference = flip HashSet.member difference
|
||||
. directiveName
|
||||
directiveName (Full.Directive directiveName' _ _) = directiveName'
|
||||
makeError (Full.Directive directiveName' _ location') = Error
|
||||
{ message = errorMessage directiveName'
|
||||
, locations = [location']
|
||||
. getField @"name"
|
||||
makeError Full.Directive{..} = Error
|
||||
{ message = errorMessage name
|
||||
, locations = [location]
|
||||
}
|
||||
errorMessage directiveName' = concat
|
||||
[ "Unknown directive \"@"
|
||||
@ -890,9 +912,9 @@ knownInputFieldNamesRule = ValueRule go constGo
|
||||
, "\"."
|
||||
]
|
||||
|
||||
-- | GraphQL servers define what directives they support and where they support
|
||||
-- | GraphQL services define what directives they support and where they support
|
||||
-- them. For each usage of a directive, the directive must be used in a location
|
||||
-- that the server has declared support for.
|
||||
-- that the service has declared support for.
|
||||
directivesInValidLocationsRule :: Rule m
|
||||
directivesInValidLocationsRule = DirectivesRule directivesRule
|
||||
where
|
||||
@ -901,7 +923,7 @@ directivesInValidLocationsRule = DirectivesRule directivesRule
|
||||
maybeDefinition <- asks
|
||||
$ HashMap.lookup directiveName . Schema.directives . schema
|
||||
case maybeDefinition of
|
||||
Just (Schema.Directive _ allowedLocations _)
|
||||
Just (Schema.Directive _ _ _ allowedLocations)
|
||||
| directiveLocation `notElem` allowedLocations -> pure $ Error
|
||||
{ message = errorMessage directiveName directiveLocation
|
||||
, locations = [location]
|
||||
@ -931,7 +953,7 @@ providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule
|
||||
available <- asks
|
||||
$ HashMap.lookup directiveName . Schema.directives . schema
|
||||
case available of
|
||||
Just (Schema.Directive _ _ definitions) ->
|
||||
Just (Schema.Directive _ definitions _ _) ->
|
||||
let forEach = go (directiveMessage directiveName) arguments location'
|
||||
in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
|
||||
_ -> lift mempty
|
||||
@ -1045,18 +1067,12 @@ overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case
|
||||
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{})
|
||||
@ -1083,10 +1099,6 @@ overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case
|
||||
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
|
||||
@ -1331,8 +1343,8 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
|
||||
-> Type.CompositeType m
|
||||
-> t Full.Selection
|
||||
-> ValidationState m (Seq Error)
|
||||
visitSelectionSet variables selectionType selections =
|
||||
foldM (evaluateSelection variables selectionType) mempty selections
|
||||
visitSelectionSet variables selectionType =
|
||||
foldM (evaluateSelection variables selectionType) mempty
|
||||
evaluateFieldSelection variables selections accumulator = \case
|
||||
Just newParentType -> do
|
||||
let folder = evaluateSelection variables newParentType
|
||||
@ -1399,7 +1411,7 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
|
||||
let Full.Directive directiveName arguments _ = directive
|
||||
directiveDefinitions <- lift $ asks $ Schema.directives . schema
|
||||
case HashMap.lookup directiveName directiveDefinitions of
|
||||
Just (Schema.Directive _ _ directiveArguments) ->
|
||||
Just (Schema.Directive _ directiveArguments _ _) ->
|
||||
mapArguments variables directiveArguments arguments
|
||||
Nothing -> pure mempty
|
||||
mapArguments variables argumentTypes = fmap fold
|
||||
@ -1552,9 +1564,9 @@ valuesOfCorrectTypeRule = ValueRule go constGo
|
||||
toConst Full.Null = Just Full.ConstNull
|
||||
toConst (Full.Enum enum) = Just $ Full.ConstEnum enum
|
||||
toConst (Full.List values) =
|
||||
Just $ Full.ConstList $ catMaybes $ toConstNode <$> values
|
||||
Just $ Full.ConstList $ mapMaybe toConstNode values
|
||||
toConst (Full.Object fields) = Just $ Full.ConstObject
|
||||
$ catMaybes $ constObjectField <$> fields
|
||||
$ mapMaybe constObjectField fields
|
||||
constObjectField Full.ObjectField{..}
|
||||
| Just constValue <- toConstNode value =
|
||||
Just $ Full.ObjectField name constValue location
|
||||
@ -1617,4 +1629,3 @@ valuesOfCorrectTypeRule = ValueRule go constGo
|
||||
}
|
||||
| otherwise -> mempty
|
||||
_ -> checkResult
|
||||
|
||||
|
@ -1,41 +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 ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Test helpers.
|
||||
module Test.Hspec.GraphQL
|
||||
( shouldResolve
|
||||
, shouldResolveTo
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.Error
|
||||
import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)
|
||||
|
||||
-- | Asserts that a query resolves to some value.
|
||||
shouldResolveTo :: MonadCatch m
|
||||
=> Either (ResponseEventStream m Aeson.Value) Aeson.Object
|
||||
-> Aeson.Object
|
||||
-> Expectation
|
||||
shouldResolveTo (Right actual) expected = actual `shouldBe` expected
|
||||
shouldResolveTo _ _ = expectationFailure
|
||||
"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.
|
||||
shouldResolve :: MonadCatch m
|
||||
=> (Text -> IO (Either (ResponseEventStream m Aeson.Value) Aeson.Object))
|
||||
-> Text
|
||||
-> Expectation
|
||||
shouldResolve executor query = do
|
||||
actual <- executor query
|
||||
case actual of
|
||||
Right response ->
|
||||
response `shouldNotSatisfy` HashMap.member "errors"
|
||||
_ -> expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
130
tests/Language/GraphQL/AST/Arbitrary.hs
Normal file
130
tests/Language/GraphQL/AST/Arbitrary.hs
Normal file
@ -0,0 +1,130 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Language.GraphQL.AST.Arbitrary
|
||||
( AnyArgument(..)
|
||||
, AnyLocation(..)
|
||||
, AnyName(..)
|
||||
, AnyNode(..)
|
||||
, AnyObjectField(..)
|
||||
, AnyValue(..)
|
||||
, printArgument
|
||||
) where
|
||||
|
||||
import qualified Language.GraphQL.AST.Document as Doc
|
||||
import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))
|
||||
import Test.QuickCheck (oneof, elements, listOf, resize, NonEmptyList (..))
|
||||
import Test.QuickCheck.Gen (Gen (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Functor ((<&>))
|
||||
|
||||
newtype AnyPrintableChar = AnyPrintableChar
|
||||
{ getAnyPrintableChar :: Char
|
||||
} deriving (Eq, Show)
|
||||
|
||||
alpha :: String
|
||||
alpha = ['a'..'z'] <> ['A'..'Z']
|
||||
|
||||
num :: String
|
||||
num = ['0'..'9']
|
||||
|
||||
instance Arbitrary AnyPrintableChar where
|
||||
arbitrary = AnyPrintableChar <$> elements chars
|
||||
where
|
||||
chars = alpha <> num <> ['_']
|
||||
|
||||
newtype AnyPrintableText = AnyPrintableText
|
||||
{ getAnyPrintableText :: Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyPrintableText where
|
||||
arbitrary = do
|
||||
nonEmptyStr <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList AnyPrintableChar))
|
||||
pure $ AnyPrintableText
|
||||
$ Text.pack
|
||||
$ map getAnyPrintableChar nonEmptyStr
|
||||
|
||||
-- https://spec.graphql.org/June2018/#Name
|
||||
newtype AnyName = AnyName
|
||||
{ getAnyName :: Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyName where
|
||||
arbitrary = do
|
||||
firstChar <- elements $ alpha <> ['_']
|
||||
rest <- (arbitrary :: Gen [AnyPrintableChar])
|
||||
pure $ AnyName
|
||||
$ Text.pack
|
||||
$ firstChar : map getAnyPrintableChar rest
|
||||
|
||||
newtype AnyLocation = AnyLocation
|
||||
{ getAnyLocation :: Doc.Location
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyLocation where
|
||||
arbitrary = AnyLocation <$> (Doc.Location <$> arbitrary <*> arbitrary)
|
||||
|
||||
newtype AnyNode a = AnyNode
|
||||
{ getAnyNode :: Doc.Node a
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyNode a) where
|
||||
arbitrary = do
|
||||
(AnyLocation location') <- arbitrary
|
||||
node' <- flip Doc.Node location' <$> arbitrary
|
||||
pure $ AnyNode node'
|
||||
|
||||
newtype AnyObjectField a = AnyObjectField
|
||||
{ getAnyObjectField :: Doc.ObjectField a
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyObjectField a) where
|
||||
arbitrary = do
|
||||
name' <- getAnyName <$> arbitrary
|
||||
value' <- getAnyNode <$> arbitrary
|
||||
location' <- getAnyLocation <$> arbitrary
|
||||
pure $ AnyObjectField $ Doc.ObjectField name' value' location'
|
||||
|
||||
newtype AnyValue = AnyValue
|
||||
{ getAnyValue :: Doc.Value
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyValue
|
||||
where
|
||||
arbitrary =
|
||||
let variableGen :: Gen Doc.Value
|
||||
variableGen = Doc.Variable . getAnyName <$> arbitrary
|
||||
listGen :: Gen [Doc.Node Doc.Value]
|
||||
listGen = (resize 5 . listOf) nodeGen
|
||||
nodeGen :: Gen (Doc.Node Doc.Value)
|
||||
nodeGen = fmap getAnyNode arbitrary <&> fmap getAnyValue
|
||||
objectGen :: Gen [Doc.ObjectField Doc.Value]
|
||||
objectGen = resize 1
|
||||
$ fmap getNonEmpty arbitrary
|
||||
<&> map (fmap getAnyValue . getAnyObjectField)
|
||||
in AnyValue <$> oneof
|
||||
[ variableGen
|
||||
, Doc.Int <$> arbitrary
|
||||
, Doc.Float <$> arbitrary
|
||||
, Doc.String . getAnyPrintableText <$> arbitrary
|
||||
, Doc.Boolean <$> arbitrary
|
||||
, MkGen $ \_ _ -> Doc.Null
|
||||
, Doc.Enum . getAnyName <$> arbitrary
|
||||
, Doc.List <$> listGen
|
||||
, Doc.Object <$> objectGen
|
||||
]
|
||||
|
||||
newtype AnyArgument a = AnyArgument
|
||||
{ getAnyArgument :: Doc.Argument
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyArgument a) where
|
||||
arbitrary = do
|
||||
name' <- getAnyName <$> arbitrary
|
||||
(AnyValue value') <- arbitrary
|
||||
(AnyLocation location') <- arbitrary
|
||||
pure $ AnyArgument $ Doc.Argument name' (Doc.Node value' location') location'
|
||||
|
||||
printArgument :: AnyArgument AnyValue -> Text
|
||||
printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) =
|
||||
name' <> ": " <> (Text.pack . show) value'
|
@ -18,3 +18,9 @@ spec = do
|
||||
]
|
||||
expected = "{ field1: 1.2, field2: null }"
|
||||
in show object `shouldBe` expected
|
||||
|
||||
describe "Description" $
|
||||
it "keeps content when merging with no description" $
|
||||
let expected = Description $ Just "Left description"
|
||||
actual = expected <> Description Nothing
|
||||
in actual `shouldBe` expected
|
||||
|
@ -1,25 +1,22 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Language.GraphQL.AST.EncoderSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import Language.GraphQL.AST.Encoder
|
||||
import Language.GraphQL.TH
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
|
||||
import Test.QuickCheck (choose, oneof, forAll)
|
||||
import qualified Data.Text.Lazy as Text.Lazy
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "value" $ do
|
||||
context "null value" $ do
|
||||
let testNull formatter = value formatter Full.Null `shouldBe` "null"
|
||||
it "minified" $ testNull minified
|
||||
it "pretty" $ testNull pretty
|
||||
|
||||
context "minified" $ do
|
||||
it "encodes null" $
|
||||
value minified Full.Null `shouldBe` "null"
|
||||
it "escapes \\" $
|
||||
value minified (Full.String "\\") `shouldBe` "\"\\\\\""
|
||||
it "escapes double quotes" $
|
||||
@ -45,113 +42,95 @@ spec = do
|
||||
it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\""
|
||||
|
||||
context "pretty" $ do
|
||||
it "encodes null" $
|
||||
value pretty Full.Null `shouldBe` "null"
|
||||
|
||||
it "uses strings for short string values" $
|
||||
value pretty (Full.String "Short text") `shouldBe` "\"Short text\""
|
||||
it "uses block strings for text with new lines, with newline symbol" $
|
||||
let expected = [gql|
|
||||
"""
|
||||
Line 1
|
||||
Line 2
|
||||
"""
|
||||
|]
|
||||
let expected = "\"\"\"\n\
|
||||
\ Line 1\n\
|
||||
\ Line 2\n\
|
||||
\\"\"\""
|
||||
actual = value pretty $ Full.String "Line 1\nLine 2"
|
||||
in actual `shouldBe` expected
|
||||
it "uses block strings for text with new lines, with CR symbol" $
|
||||
let expected = [gql|
|
||||
"""
|
||||
Line 1
|
||||
Line 2
|
||||
"""
|
||||
|]
|
||||
let expected = "\"\"\"\n\
|
||||
\ Line 1\n\
|
||||
\ Line 2\n\
|
||||
\\"\"\""
|
||||
actual = value pretty $ Full.String "Line 1\rLine 2"
|
||||
in actual `shouldBe` expected
|
||||
it "uses block strings for text with new lines, with CR symbol followed by newline" $
|
||||
let expected = [gql|
|
||||
"""
|
||||
Line 1
|
||||
Line 2
|
||||
"""
|
||||
|]
|
||||
let expected = "\"\"\"\n\
|
||||
\ Line 1\n\
|
||||
\ Line 2\n\
|
||||
\\"\"\""
|
||||
actual = value pretty $ Full.String "Line 1\r\nLine 2"
|
||||
in actual `shouldBe` expected
|
||||
it "encodes as one line string if has escaped symbols" $ do
|
||||
let
|
||||
genNotAllowedSymbol = oneof
|
||||
[ choose ('\x0000', '\x0008')
|
||||
, choose ('\x000B', '\x000C')
|
||||
, choose ('\x000E', '\x001F')
|
||||
, pure '\x007F'
|
||||
]
|
||||
|
||||
let genNotAllowedSymbol = oneof
|
||||
[ choose ('\x0000', '\x0008')
|
||||
, choose ('\x000B', '\x000C')
|
||||
, choose ('\x000E', '\x001F')
|
||||
, pure '\x007F'
|
||||
]
|
||||
forAll genNotAllowedSymbol $ \x -> do
|
||||
let
|
||||
rawValue = "Short \n" <> Text.Lazy.cons x "text"
|
||||
encoded = value pretty
|
||||
$ Full.String $ Text.Lazy.toStrict rawValue
|
||||
shouldStartWith (Text.Lazy.unpack encoded) "\""
|
||||
shouldEndWith (Text.Lazy.unpack encoded) "\""
|
||||
shouldNotContain (Text.Lazy.unpack encoded) "\"\"\""
|
||||
let rawValue = "Short \n" <> Text.Lazy.cons x "text"
|
||||
encoded = Text.Lazy.unpack
|
||||
$ value pretty
|
||||
$ Full.String
|
||||
$ Text.Lazy.toStrict rawValue
|
||||
shouldStartWith encoded "\""
|
||||
shouldEndWith encoded "\""
|
||||
shouldNotContain encoded "\"\"\""
|
||||
|
||||
it "Hello world" $
|
||||
let actual = value pretty
|
||||
$ Full.String "Hello,\n World!\n\nYours,\n GraphQL."
|
||||
expected = [gql|
|
||||
"""
|
||||
Hello,
|
||||
World!
|
||||
|
||||
Yours,
|
||||
GraphQL.
|
||||
"""
|
||||
|]
|
||||
expected = "\"\"\"\n\
|
||||
\ Hello,\n\
|
||||
\ World!\n\
|
||||
\\n\
|
||||
\ Yours,\n\
|
||||
\ GraphQL.\n\
|
||||
\\"\"\""
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "has only newlines" $
|
||||
let actual = value pretty $ Full.String "\n"
|
||||
expected = [gql|
|
||||
"""
|
||||
|
||||
|
||||
"""
|
||||
|]
|
||||
expected = "\"\"\"\n\n\n\"\"\""
|
||||
in actual `shouldBe` expected
|
||||
it "has newlines and one symbol at the begining" $
|
||||
let actual = value pretty $ Full.String "a\n\n"
|
||||
expected = [gql|
|
||||
"""
|
||||
a
|
||||
|
||||
|
||||
"""|]
|
||||
expected = "\"\"\"\n\
|
||||
\ a\n\
|
||||
\\n\
|
||||
\\n\
|
||||
\\"\"\""
|
||||
in actual `shouldBe` expected
|
||||
it "has newlines and one symbol at the end" $
|
||||
let actual = value pretty $ Full.String "\n\na"
|
||||
expected = [gql|
|
||||
"""
|
||||
|
||||
|
||||
a
|
||||
"""
|
||||
|]
|
||||
expected = "\"\"\"\n\
|
||||
\\n\
|
||||
\\n\
|
||||
\ a\n\
|
||||
\\"\"\""
|
||||
in actual `shouldBe` expected
|
||||
it "has newlines and one symbol in the middle" $
|
||||
let actual = value pretty $ Full.String "\na\n"
|
||||
expected = [gql|
|
||||
"""
|
||||
|
||||
a
|
||||
|
||||
"""
|
||||
|]
|
||||
expected = "\"\"\"\n\
|
||||
\\n\
|
||||
\ a\n\
|
||||
\\n\
|
||||
\\"\"\""
|
||||
in actual `shouldBe` expected
|
||||
it "skip trailing whitespaces" $
|
||||
let actual = value pretty $ Full.String " Short\ntext "
|
||||
expected = [gql|
|
||||
"""
|
||||
Short
|
||||
text
|
||||
"""
|
||||
|]
|
||||
expected = "\"\"\"\n\
|
||||
\ Short\n\
|
||||
\ text\n\
|
||||
\\"\"\""
|
||||
in actual `shouldBe` expected
|
||||
|
||||
describe "definition" $
|
||||
@ -163,13 +142,113 @@ spec = do
|
||||
fieldSelection = pure $ Full.FieldSelection field
|
||||
operation = Full.DefinitionOperation
|
||||
$ Full.SelectionSet fieldSelection location
|
||||
expected = Text.Lazy.snoc [gql|
|
||||
{
|
||||
field(message: """
|
||||
line1
|
||||
line2
|
||||
""")
|
||||
}
|
||||
|] '\n'
|
||||
expected = "{\n\
|
||||
\ field(message: \"\"\"\n\
|
||||
\ line1\n\
|
||||
\ line2\n\
|
||||
\ \"\"\")\n\
|
||||
\}\n"
|
||||
actual = definition pretty operation
|
||||
in actual `shouldBe` expected
|
||||
|
||||
describe "operationType" $
|
||||
it "produces lowercase mutation operation type" $
|
||||
let actual = operationType pretty Full.Mutation
|
||||
in actual `shouldBe` "mutation"
|
||||
|
||||
describe "typeSystemDefinition" $ do
|
||||
it "produces a schema with an indented operation type definition" $
|
||||
let queryType = Full.OperationTypeDefinition Full.Query "QueryRootType"
|
||||
mutationType = Full.OperationTypeDefinition Full.Mutation "MutationType"
|
||||
operations = queryType :| pure mutationType
|
||||
definition' = Full.SchemaDefinition [] operations
|
||||
expected = "schema {\n\
|
||||
\ query: QueryRootType\n\
|
||||
\ mutation: MutationType\n\
|
||||
\}\n"
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes a scalar type definition" $
|
||||
let uuidType = Full.ScalarTypeDefinition mempty "UUID" mempty
|
||||
definition' = Full.TypeDefinition uuidType
|
||||
expected = "scalar UUID"
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes an interface definition" $
|
||||
let someType = Full.TypeNamed "String"
|
||||
argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty
|
||||
arguments = Full.ArgumentsDefinition [argument]
|
||||
definition' = Full.TypeDefinition
|
||||
$ Full.InterfaceTypeDefinition mempty "UUID" (Full.ImplementsInterfaces []) mempty
|
||||
$ pure
|
||||
$ Full.FieldDefinition mempty "value" arguments someType mempty
|
||||
expected = "interface UUID {\n\
|
||||
\ value(arg: String): String\n\
|
||||
\}"
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes an union definition" $
|
||||
let definition' = Full.TypeDefinition
|
||||
$ Full.UnionTypeDefinition mempty "SearchResult" mempty
|
||||
$ Full.UnionMemberTypes ["Photo", "Person"]
|
||||
expected = "union SearchResult =\n\
|
||||
\ | Photo\n\
|
||||
\ | Person"
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes an enum definition" $
|
||||
let values =
|
||||
[ Full.EnumValueDefinition mempty "NORTH" mempty
|
||||
, Full.EnumValueDefinition mempty "EAST" mempty
|
||||
, Full.EnumValueDefinition mempty "SOUTH" mempty
|
||||
, Full.EnumValueDefinition mempty "WEST" mempty
|
||||
]
|
||||
definition' = Full.TypeDefinition
|
||||
$ Full.EnumTypeDefinition mempty "Direction" mempty values
|
||||
expected = "enum Direction {\n\
|
||||
\ NORTH\n\
|
||||
\ EAST\n\
|
||||
\ SOUTH\n\
|
||||
\ WEST\n\
|
||||
\}"
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes an input type" $
|
||||
let intType = Full.TypeNonNull $ Full.NonNullTypeNamed "Int"
|
||||
stringType = Full.TypeNamed "String"
|
||||
fields =
|
||||
[ Full.InputValueDefinition mempty "a" stringType Nothing mempty
|
||||
, Full.InputValueDefinition mempty "b" intType Nothing mempty
|
||||
]
|
||||
definition' = Full.TypeDefinition
|
||||
$ Full.InputObjectTypeDefinition mempty "ExampleInputObject" mempty fields
|
||||
expected = "input ExampleInputObject {\n\
|
||||
\ a: String\n\
|
||||
\ b: Int!\n\
|
||||
\}"
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
context "directive definition" $ do
|
||||
it "encodes a directive definition" $ do
|
||||
let definition' = Full.DirectiveDefinition mempty "example" mempty False
|
||||
$ pure
|
||||
$ DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field
|
||||
expected = "@example() on\n\
|
||||
\ | FIELD"
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes a repeatable directive definition" $ do
|
||||
let definition' = Full.DirectiveDefinition mempty "example" mempty True
|
||||
$ pure
|
||||
$ DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field
|
||||
expected = "@example() repeatable on\n\
|
||||
\ | FIELD"
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Language.GraphQL.AST.LexerSpec
|
||||
( spec
|
||||
) where
|
||||
@ -7,7 +6,6 @@ module Language.GraphQL.AST.LexerSpec
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import Language.GraphQL.AST.Lexer
|
||||
import Language.GraphQL.TH
|
||||
import Test.Hspec (Spec, context, describe, it)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
|
||||
import Text.Megaparsec (ParseErrorBundle, parse)
|
||||
@ -19,38 +17,39 @@ spec = describe "Lexer" $ do
|
||||
parse unicodeBOM "" `shouldSucceedOn` "\xfeff"
|
||||
|
||||
it "lexes strings" $ do
|
||||
parse string "" [gql|"simple"|] `shouldParse` "simple"
|
||||
parse string "" [gql|" white space "|] `shouldParse` " white space "
|
||||
parse string "" [gql|"quote \""|] `shouldParse` [gql|quote "|]
|
||||
parse string "" [gql|"escaped \n"|] `shouldParse` "escaped \n"
|
||||
parse string "" [gql|"slashes \\ \/"|] `shouldParse` [gql|slashes \ /|]
|
||||
parse string "" [gql|"unicode \u1234\u5678\u90AB\uCDEF"|]
|
||||
parse string "" "\"simple\"" `shouldParse` "simple"
|
||||
parse string "" "\" white space \"" `shouldParse` " white space "
|
||||
parse string "" "\"quote \\\"\"" `shouldParse` "quote \""
|
||||
parse string "" "\"escaped \\n\"" `shouldParse` "escaped \n"
|
||||
parse string "" "\"slashes \\\\ \\/\"" `shouldParse` "slashes \\ /"
|
||||
parse string "" "\"unicode \\u1234\\u5678\\u90AB\\uCDEF\""
|
||||
`shouldParse` "unicode ሴ噸邫췯"
|
||||
|
||||
it "lexes block string" $ do
|
||||
parse blockString "" [gql|"""simple"""|] `shouldParse` "simple"
|
||||
parse blockString "" [gql|""" white space """|]
|
||||
parse blockString "" "\"\"\"simple\"\"\"" `shouldParse` "simple"
|
||||
parse blockString "" "\"\"\" white space \"\"\""
|
||||
`shouldParse` " white space "
|
||||
parse blockString "" [gql|"""contains " quote"""|]
|
||||
`shouldParse` [gql|contains " quote|]
|
||||
parse blockString "" [gql|"""contains \""" triplequote"""|]
|
||||
`shouldParse` [gql|contains """ triplequote|]
|
||||
parse blockString "" "\"\"\"contains \" quote\"\"\""
|
||||
`shouldParse` "contains \" quote"
|
||||
parse blockString "" "\"\"\"contains \\\"\"\" triplequote\"\"\""
|
||||
`shouldParse` "contains \"\"\" triplequote"
|
||||
parse blockString "" "\"\"\"multi\nline\"\"\"" `shouldParse` "multi\nline"
|
||||
parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""
|
||||
`shouldParse` "multi\nline\nnormalized"
|
||||
parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""
|
||||
`shouldParse` "multi\nline\nnormalized"
|
||||
parse blockString "" [gql|"""unescaped \n\r\b\t\f\u1234"""|]
|
||||
`shouldParse` [gql|unescaped \n\r\b\t\f\u1234|]
|
||||
parse blockString "" [gql|"""slashes \\ \/"""|]
|
||||
`shouldParse` [gql|slashes \\ \/|]
|
||||
parse blockString "" [gql|"""
|
||||
|
||||
spans
|
||||
multiple
|
||||
lines
|
||||
|
||||
"""|] `shouldParse` "spans\n multiple\n lines"
|
||||
parse blockString "" "\"\"\"unescaped \\n\\r\\b\\t\\f\\u1234\"\"\""
|
||||
`shouldParse` "unescaped \\n\\r\\b\\t\\f\\u1234"
|
||||
parse blockString "" "\"\"\"slashes \\\\ \\/\"\"\""
|
||||
`shouldParse` "slashes \\\\ \\/"
|
||||
parse blockString "" "\"\"\"\n\
|
||||
\\n\
|
||||
\ spans\n\
|
||||
\ multiple\n\
|
||||
\ lines\n\
|
||||
\\n\
|
||||
\\"\"\""
|
||||
`shouldParse` "spans\n multiple\n lines"
|
||||
|
||||
it "lexes numbers" $ do
|
||||
parse integer "" "4" `shouldParse` (4 :: Int)
|
||||
@ -84,7 +83,7 @@ spec = describe "Lexer" $ do
|
||||
|
||||
context "Implementation tests" $ do
|
||||
it "lexes empty block strings" $
|
||||
parse blockString "" [gql|""""""|] `shouldParse` ""
|
||||
parse blockString "" "\"\"\"\"\"\"" `shouldParse` ""
|
||||
it "lexes ampersand" $
|
||||
parse amp "" "&" `shouldParse` "&"
|
||||
it "lexes schema extensions" $
|
||||
|
@ -1,182 +1,184 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Language.GraphQL.AST.ParserSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.Document
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc
|
||||
import Language.GraphQL.AST.Parser
|
||||
import Language.GraphQL.TH
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
|
||||
import Test.Hspec (Spec, describe, it, context)
|
||||
import Test.Hspec.Megaparsec
|
||||
( shouldParse
|
||||
, shouldFailOn
|
||||
, parseSatisfies
|
||||
, shouldSucceedOn
|
||||
)
|
||||
import Text.Megaparsec (parse)
|
||||
import Test.QuickCheck (property, NonEmptyList (..), mapSize)
|
||||
import Language.GraphQL.AST.Arbitrary
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Parser" $ do
|
||||
it "accepts BOM header" $
|
||||
parse document "" `shouldSucceedOn` "\xfeff{foo}"
|
||||
|
||||
it "accepts block strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: """Argument""")
|
||||
}|]
|
||||
context "Arguments" $ do
|
||||
it "accepts block strings as argument" $
|
||||
parse document "" `shouldSucceedOn`
|
||||
"{ hello(text: \"\"\"Argument\"\"\") }"
|
||||
|
||||
it "accepts strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: "Argument")
|
||||
}|]
|
||||
it "accepts strings as argument" $
|
||||
parse document "" `shouldSucceedOn` "{ hello(text: \"Argument\") }"
|
||||
|
||||
it "accepts two required arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth($username: String!, $password: String!){
|
||||
test
|
||||
}|]
|
||||
it "accepts int as argument" $
|
||||
parse document "" `shouldSucceedOn` "{ user(id: 4) }"
|
||||
|
||||
it "accepts two string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: "username", password: "password")
|
||||
}|]
|
||||
it "accepts boolean as argument" $
|
||||
parse document "" `shouldSucceedOn`
|
||||
"{ hello(flag: true) { field1 } }"
|
||||
|
||||
it "accepts two block string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: """username""", password: """password""")
|
||||
}|]
|
||||
it "accepts float as argument" $
|
||||
parse document "" `shouldSucceedOn`
|
||||
"{ body(height: 172.5) { height } }"
|
||||
|
||||
it "accepts empty list as argument" $
|
||||
parse document "" `shouldSucceedOn` "{ query(list: []) { field1 } }"
|
||||
|
||||
it "accepts two required arguments" $
|
||||
parse document "" `shouldSucceedOn`
|
||||
"mutation auth($username: String!, $password: String!) { test }"
|
||||
|
||||
it "accepts two string arguments" $
|
||||
parse document "" `shouldSucceedOn`
|
||||
"mutation auth { test(username: \"username\", password: \"password\") }"
|
||||
|
||||
it "accepts two block string arguments" $
|
||||
let given = "mutation auth {\n\
|
||||
\ test(username: \"\"\"username\"\"\", password: \"\"\"password\"\"\")\n\
|
||||
\}"
|
||||
in parse document "" `shouldSucceedOn` given
|
||||
|
||||
it "fails to parse an empty argument list in parens" $
|
||||
parse document "" `shouldFailOn` "{ test() }"
|
||||
|
||||
it "accepts any arguments" $ mapSize (const 10) $ property $ \xs ->
|
||||
let arguments' = map printArgument
|
||||
$ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue))
|
||||
query' = "query(" <> Text.intercalate ", " arguments' <> ")"
|
||||
in parse document "" `shouldSucceedOn` ("{ " <> query' <> " }")
|
||||
|
||||
it "parses minimal schema definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|schema { query: Query }|]
|
||||
parse document "" `shouldSucceedOn` "schema { query: Query }"
|
||||
|
||||
it "parses minimal scalar definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|scalar Time|]
|
||||
parse document "" `shouldSucceedOn` "scalar Time"
|
||||
|
||||
it "parses ImplementsInterfaces" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
type Person implements NamedEntity & ValuedEntity {
|
||||
name: String
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"type Person implements NamedEntity & ValuedEntity {\n\
|
||||
\ name: String\n\
|
||||
\}"
|
||||
|
||||
it "parses a type without ImplementsInterfaces" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
type Person {
|
||||
name: String
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"type Person {\n\
|
||||
\ name: String\n\
|
||||
\}"
|
||||
|
||||
it "parses ArgumentsDefinition in an ObjectDefinition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
type Person {
|
||||
name(first: String, last: String): String
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"type Person {\n\
|
||||
\ name(first: String, last: String): String\n\
|
||||
\}"
|
||||
|
||||
it "parses minimal union type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
union SearchResult = Photo | Person
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"union SearchResult = Photo | Person"
|
||||
|
||||
it "parses minimal interface type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
interface NamedEntity {
|
||||
name: String
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"interface NamedEntity {\n\
|
||||
\ name: String\n\
|
||||
\}"
|
||||
|
||||
it "parses ImplementsInterfaces on interfaces" $
|
||||
parse document "" `shouldSucceedOn`
|
||||
"interface Person implements NamedEntity & ValuedEntity {\n\
|
||||
\ name: String\n\
|
||||
\}"
|
||||
|
||||
it "parses minimal enum type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
enum Direction {
|
||||
NORTH
|
||||
EAST
|
||||
SOUTH
|
||||
WEST
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses minimal enum type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
enum Direction {
|
||||
NORTH
|
||||
EAST
|
||||
SOUTH
|
||||
WEST
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"enum Direction {\n\
|
||||
\ NORTH\n\
|
||||
\ EAST\n\
|
||||
\ SOUTH\n\
|
||||
\ WEST\n\
|
||||
\}"
|
||||
|
||||
it "parses minimal input object type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
input Point2D {
|
||||
x: Float
|
||||
y: Float
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"input Point2D {\n\
|
||||
\ x: Float\n\
|
||||
\ y: Float\n\
|
||||
\}"
|
||||
|
||||
it "parses minimal input enum definition with an optional pipe" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
directive @example on
|
||||
| FIELD
|
||||
| FRAGMENT_SPREAD
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"directive @example on\n\
|
||||
\ | FIELD\n\
|
||||
\ | FRAGMENT_SPREAD"
|
||||
|
||||
it "parses two minimal directive definitions" $
|
||||
let directive nm loc =
|
||||
TypeSystemDefinition
|
||||
(DirectiveDefinition
|
||||
(Description Nothing)
|
||||
nm
|
||||
(ArgumentsDefinition [])
|
||||
(loc :| []))
|
||||
example1 =
|
||||
directive "example1"
|
||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
||||
(Location {line = 1, column = 1})
|
||||
example2 =
|
||||
directive "example2"
|
||||
(DirLoc.ExecutableDirectiveLocation DirLoc.Field)
|
||||
(Location {line = 2, column = 1})
|
||||
testSchemaExtension = example1 :| [ example2 ]
|
||||
query = [gql|
|
||||
directive @example1 on FIELD_DEFINITION
|
||||
directive @example2 on FIELD
|
||||
|]
|
||||
let directive name' loc = TypeSystemDefinition
|
||||
$ DirectiveDefinition
|
||||
(Description Nothing)
|
||||
name'
|
||||
(ArgumentsDefinition [])
|
||||
False
|
||||
(loc :| [])
|
||||
example1 = directive "example1"
|
||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
||||
(Location {line = 1, column = 1})
|
||||
example2 = directive "example2"
|
||||
(DirLoc.ExecutableDirectiveLocation DirLoc.Field)
|
||||
(Location {line = 2, column = 1})
|
||||
testSchemaExtension = example1 :| [example2]
|
||||
query = Text.unlines
|
||||
[ "directive @example1 on FIELD_DEFINITION"
|
||||
, "directive @example2 on FIELD"
|
||||
]
|
||||
in parse document "" query `shouldParse` testSchemaExtension
|
||||
|
||||
it "parses a directive definition with a default empty list argument" $
|
||||
let directive nm loc args =
|
||||
TypeSystemDefinition
|
||||
(DirectiveDefinition
|
||||
(Description Nothing)
|
||||
nm
|
||||
(ArgumentsDefinition
|
||||
[ InputValueDefinition
|
||||
(Description Nothing)
|
||||
argName
|
||||
argType
|
||||
argValue
|
||||
[]
|
||||
| (argName, argType, argValue) <- args])
|
||||
(loc :| []))
|
||||
defn =
|
||||
directive "test"
|
||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
||||
[("foo",
|
||||
TypeList (TypeNamed "String"),
|
||||
Just
|
||||
$ Node (ConstList [])
|
||||
$ Location {line = 1, column = 33})]
|
||||
(Location {line = 1, column = 1})
|
||||
query = [gql|directive @test(foo: [String] = []) on FIELD_DEFINITION|]
|
||||
in parse document "" query `shouldParse` (defn :| [ ])
|
||||
let argumentValue = Just
|
||||
$ Node (ConstList [])
|
||||
$ Location{ line = 1, column = 33 }
|
||||
loc = DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition
|
||||
argumentValueDefinition = InputValueDefinition
|
||||
(Description Nothing)
|
||||
"foo"
|
||||
(TypeList (TypeNamed "String"))
|
||||
argumentValue
|
||||
[]
|
||||
definition = DirectiveDefinition
|
||||
(Description Nothing)
|
||||
"test"
|
||||
(ArgumentsDefinition [argumentValueDefinition])
|
||||
False
|
||||
(loc :| [])
|
||||
directive = TypeSystemDefinition definition
|
||||
$ Location{ line = 1, column = 1 }
|
||||
query = "directive @test(foo: [String] = []) on FIELD_DEFINITION"
|
||||
in parse document "" query `shouldParse` (directive :| [])
|
||||
|
||||
it "parses schema extension with a new directive" $
|
||||
parse document "" `shouldSucceedOn`[gql|
|
||||
extend schema @newDirective
|
||||
|]
|
||||
parse document "" `shouldSucceedOn` "extend schema @newDirective"
|
||||
|
||||
it "parses schema extension with an operation type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|extend schema { query: Query }|]
|
||||
parse document "" `shouldSucceedOn` "extend schema { query: Query }"
|
||||
|
||||
it "parses schema extension with an operation type and directive" $
|
||||
let newDirective = Directive "newDirective" [] $ Location 1 15
|
||||
@ -185,38 +187,42 @@ spec = describe "Parser" $ do
|
||||
$ OperationTypeDefinition Query "Query" :| []
|
||||
testSchemaExtension = TypeSystemExtension schemaExtension
|
||||
$ Location 1 1
|
||||
query = [gql|extend schema @newDirective { query: Query }|]
|
||||
query = "extend schema @newDirective { query: Query }"
|
||||
in parse document "" query `shouldParse` (testSchemaExtension :| [])
|
||||
|
||||
it "parses a repeatable directive definition" $
|
||||
let given = "directive @test repeatable on FIELD_DEFINITION"
|
||||
isRepeatable (TypeSystemDefinition definition' _ :| [])
|
||||
| DirectiveDefinition _ _ _ repeatable _ <- definition' = repeatable
|
||||
isRepeatable _ = False
|
||||
in parse document "" given `parseSatisfies` isRepeatable
|
||||
|
||||
it "parses an object extension" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
extend type Story {
|
||||
isHiddenLocally: Boolean
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"extend type Story { isHiddenLocally: Boolean }"
|
||||
|
||||
it "rejects variables in DefaultValue" $
|
||||
parse document "" `shouldFailOn` [gql|
|
||||
query ($book: String = "Zarathustra", $author: String = $book) {
|
||||
title
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldFailOn`
|
||||
"query ($book: String = \"Zarathustra\", $author: String = $book) {\n\
|
||||
\ title\n\
|
||||
\}"
|
||||
|
||||
it "rejects empty selection set" $
|
||||
parse document "" `shouldFailOn` "query { innerField {} }"
|
||||
|
||||
it "parses documents beginning with a comment" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
"""
|
||||
Query
|
||||
"""
|
||||
type Query {
|
||||
queryField: String
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"\"\"\"\n\
|
||||
\Query\n\
|
||||
\\"\"\"\n\
|
||||
\type Query {\n\
|
||||
\ queryField: String\n\
|
||||
\}"
|
||||
|
||||
it "parses subscriptions" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
subscription NewMessages {
|
||||
newMessage(roomId: 123) {
|
||||
sender
|
||||
}
|
||||
}
|
||||
|]
|
||||
parse document "" `shouldSucceedOn`
|
||||
"subscription NewMessages {\n\
|
||||
\ newMessage(roomId: 123) {\n\
|
||||
\ sender\n\
|
||||
\ }\n\
|
||||
\}"
|
||||
|
@ -7,9 +7,9 @@ module Language.GraphQL.ErrorSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Language.GraphQL.Error
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import Test.Hspec
|
||||
( Spec
|
||||
, describe
|
||||
@ -31,6 +31,6 @@ spec = describe "parseError" $
|
||||
, pstateTabWidth = mkPos 1
|
||||
, pstateLinePrefix = ""
|
||||
}
|
||||
Response Aeson.Null actual <-
|
||||
Response Type.Null actual <-
|
||||
parseError (ParseErrorBundle parseErrors posState)
|
||||
length actual `shouldBe` 1
|
||||
|
@ -7,12 +7,8 @@ module Language.GraphQL.Execute.CoerceSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Aeson as Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Scientific (scientific)
|
||||
import qualified Language.GraphQL.Execute.Coerce as Coerce
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
@ -27,81 +23,11 @@ direction = EnumType "Direction" Nothing $ HashMap.fromList
|
||||
, ("WEST", EnumValue Nothing)
|
||||
]
|
||||
|
||||
singletonInputObject :: In.Type
|
||||
singletonInputObject = In.NamedInputObjectType type'
|
||||
where
|
||||
type' = In.InputObjectType "ObjectName" Nothing inputFields
|
||||
inputFields = HashMap.singleton "field" field
|
||||
field = In.InputField Nothing (In.NamedScalarType string) Nothing
|
||||
|
||||
namedIdType :: In.Type
|
||||
namedIdType = In.NamedScalarType id
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "VariableValue Aeson" $ do
|
||||
it "coerces strings" $
|
||||
let expected = Just (String "asdf")
|
||||
actual = Coerce.coerceVariableValue
|
||||
(In.NamedScalarType string) (Aeson.String "asdf")
|
||||
in actual `shouldBe` expected
|
||||
it "coerces non-null strings" $
|
||||
let expected = Just (String "asdf")
|
||||
actual = Coerce.coerceVariableValue
|
||||
(In.NonNullScalarType string) (Aeson.String "asdf")
|
||||
in actual `shouldBe` expected
|
||||
it "coerces booleans" $
|
||||
let expected = Just (Boolean True)
|
||||
actual = Coerce.coerceVariableValue
|
||||
(In.NamedScalarType boolean) (Aeson.Bool True)
|
||||
in actual `shouldBe` expected
|
||||
it "coerces zero to an integer" $
|
||||
let expected = Just (Int 0)
|
||||
actual = Coerce.coerceVariableValue
|
||||
(In.NamedScalarType int) (Aeson.Number 0)
|
||||
in actual `shouldBe` expected
|
||||
it "rejects fractional if an integer is expected" $
|
||||
let actual = Coerce.coerceVariableValue
|
||||
(In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1))
|
||||
in actual `shouldSatisfy` isNothing
|
||||
it "coerces float numbers" $
|
||||
let expected = Just (Float 1.4)
|
||||
actual = Coerce.coerceVariableValue
|
||||
(In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1))
|
||||
in actual `shouldBe` expected
|
||||
it "coerces IDs" $
|
||||
let expected = Just (String "1234")
|
||||
json = Aeson.String "1234"
|
||||
actual = Coerce.coerceVariableValue namedIdType json
|
||||
in actual `shouldBe` expected
|
||||
it "coerces input objects" $
|
||||
let actual = Coerce.coerceVariableValue singletonInputObject
|
||||
$ Aeson.object ["field" .= ("asdf" :: Aeson.Value)]
|
||||
expected = Just $ Object $ HashMap.singleton "field" "asdf"
|
||||
in actual `shouldBe` expected
|
||||
it "skips the field if it is missing in the variables" $
|
||||
let actual = Coerce.coerceVariableValue
|
||||
singletonInputObject Aeson.emptyObject
|
||||
expected = Just $ Object HashMap.empty
|
||||
in actual `shouldBe` expected
|
||||
it "fails if input object value contains extra fields" $
|
||||
let actual = Coerce.coerceVariableValue singletonInputObject
|
||||
$ Aeson.object variableFields
|
||||
variableFields =
|
||||
[ "field" .= ("asdf" :: Aeson.Value)
|
||||
, "extra" .= ("qwer" :: Aeson.Value)
|
||||
]
|
||||
in actual `shouldSatisfy` isNothing
|
||||
it "preserves null" $
|
||||
let actual = Coerce.coerceVariableValue namedIdType Aeson.Null
|
||||
in actual `shouldBe` Just Null
|
||||
it "preserves list order" $
|
||||
let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
|
||||
listType = (In.ListType $ In.NamedScalarType string)
|
||||
actual = Coerce.coerceVariableValue listType list
|
||||
expected = Just $ List [String "asdf", String "qwer"]
|
||||
in actual `shouldBe` expected
|
||||
|
||||
spec =
|
||||
describe "coerceInputLiteral" $ do
|
||||
it "coerces enums" $
|
||||
let expected = Just (Enum "NORTH")
|
||||
|
@ -2,17 +2,17 @@
|
||||
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 DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Language.GraphQL.ExecuteSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Control.Exception (Exception(..), SomeException)
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson.Types (emptyObject)
|
||||
import Data.Conduit
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
@ -21,14 +21,24 @@ import Language.GraphQL.AST (Document, Location(..), Name)
|
||||
import Language.GraphQL.AST.Parser (document)
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute (execute)
|
||||
import Language.GraphQL.TH
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Prelude hiding (id)
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.Megaparsec (parse, errorBundlePretty)
|
||||
import Schemas.HeroSchema (heroSchema)
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Test.Hspec.Expectations
|
||||
( Expectation
|
||||
, expectationFailure
|
||||
)
|
||||
import Data.Either (fromRight)
|
||||
|
||||
data PhilosopherException = PhilosopherException
|
||||
deriving Show
|
||||
@ -39,7 +49,7 @@ instance Exception PhilosopherException where
|
||||
ResolverException resolverException <- fromException e
|
||||
cast resolverException
|
||||
|
||||
philosopherSchema :: Schema (Either SomeException)
|
||||
philosopherSchema :: Schema IO
|
||||
philosopherSchema =
|
||||
schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty
|
||||
where
|
||||
@ -49,12 +59,14 @@ philosopherSchema =
|
||||
, Schema.ObjectType bookCollectionType
|
||||
]
|
||||
|
||||
queryType :: Out.ObjectType (Either SomeException)
|
||||
queryType :: Out.ObjectType IO
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("philosopher", ValueResolver philosopherField philosopherResolver)
|
||||
, ("genres", ValueResolver genresField genresResolver)
|
||||
, ("throwing", ValueResolver throwingField throwingResolver)
|
||||
, ("count", ValueResolver countField countResolver)
|
||||
, ("sequence", ValueResolver sequenceField sequenceResolver)
|
||||
, ("withInputObject", ValueResolver withInputObjectField withInputObjectResolver)
|
||||
]
|
||||
where
|
||||
philosopherField =
|
||||
@ -62,17 +74,35 @@ queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.singleton "id"
|
||||
$ In.Argument Nothing (In.NamedScalarType id) Nothing
|
||||
philosopherResolver = pure $ Object mempty
|
||||
genresField =
|
||||
throwingField =
|
||||
let fieldType = Out.ListType $ Out.NonNullScalarType string
|
||||
in Out.Field Nothing fieldType HashMap.empty
|
||||
genresResolver :: Resolve (Either SomeException)
|
||||
genresResolver = throwM PhilosopherException
|
||||
throwingResolver :: Resolve IO
|
||||
throwingResolver = throwM PhilosopherException
|
||||
countField =
|
||||
let fieldType = Out.NonNullScalarType int
|
||||
in Out.Field Nothing fieldType HashMap.empty
|
||||
countResolver = pure ""
|
||||
sequenceField =
|
||||
let fieldType = Out.ListType $ Out.NonNullScalarType int
|
||||
in Out.Field Nothing fieldType HashMap.empty
|
||||
sequenceResolver = pure intSequence
|
||||
withInputObjectResolver = pure $ Type.Int 0
|
||||
withInputObjectField =
|
||||
Out.Field Nothing (Out.NonNullScalarType int) $ HashMap.fromList
|
||||
[("values", In.Argument Nothing withInputObjectArgumentType Nothing)]
|
||||
withInputObjectArgumentType = In.NonNullListType
|
||||
$ In.NonNullInputObjectType inputObjectType
|
||||
|
||||
musicType :: Out.ObjectType (Either SomeException)
|
||||
inputObjectType :: In.InputObjectType
|
||||
inputObjectType = In.InputObjectType "InputObject" Nothing $
|
||||
HashMap.singleton "name" $
|
||||
In.InputField Nothing (In.NonNullScalarType int) Nothing
|
||||
|
||||
intSequence :: Value
|
||||
intSequence = Type.List [Type.Int 1, Type.Int 2, Type.Int 3]
|
||||
|
||||
musicType :: Out.ObjectType IO
|
||||
musicType = Out.ObjectType "Music" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -82,7 +112,7 @@ musicType = Out.ObjectType "Music" Nothing []
|
||||
instrumentResolver = pure $ String "piano"
|
||||
instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
poetryType :: Out.ObjectType (Either SomeException)
|
||||
poetryType :: Out.ObjectType IO
|
||||
poetryType = Out.ObjectType "Poetry" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -92,10 +122,10 @@ poetryType = Out.ObjectType "Poetry" Nothing []
|
||||
genreResolver = pure $ String "Futurism"
|
||||
genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
interestType :: Out.UnionType (Either SomeException)
|
||||
interestType :: Out.UnionType IO
|
||||
interestType = Out.UnionType "Interest" Nothing [musicType, poetryType]
|
||||
|
||||
philosopherType :: Out.ObjectType (Either SomeException)
|
||||
philosopherType :: Out.ObjectType IO
|
||||
philosopherType = Out.ObjectType "Philosopher" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -136,14 +166,14 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
|
||||
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
firstLanguageResolver = pure Null
|
||||
|
||||
workType :: Out.InterfaceType (Either SomeException)
|
||||
workType :: Out.InterfaceType IO
|
||||
workType = Out.InterfaceType "Work" Nothing []
|
||||
$ HashMap.fromList fields
|
||||
where
|
||||
fields = [("title", titleField)]
|
||||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
bookType :: Out.ObjectType (Either SomeException)
|
||||
bookType :: Out.ObjectType IO
|
||||
bookType = Out.ObjectType "Book" Nothing [workType]
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -153,7 +183,7 @@ bookType = Out.ObjectType "Book" Nothing [workType]
|
||||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
titleResolver = pure "Also sprach Zarathustra: Ein Buch für Alle und Keinen"
|
||||
|
||||
bookCollectionType :: Out.ObjectType (Either SomeException)
|
||||
bookCollectionType :: Out.ObjectType IO
|
||||
bookCollectionType = Out.ObjectType "Book" Nothing [workType]
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -163,7 +193,7 @@ bookCollectionType = Out.ObjectType "Book" Nothing [workType]
|
||||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
titleResolver = pure "The Three Critiques"
|
||||
|
||||
subscriptionType :: Out.ObjectType (Either SomeException)
|
||||
subscriptionType :: Out.ObjectType IO
|
||||
subscriptionType = Out.ObjectType "Subscription" Nothing []
|
||||
$ HashMap.singleton "newQuote"
|
||||
$ EventStreamResolver quoteField (pure $ Object mempty)
|
||||
@ -172,7 +202,7 @@ subscriptionType = Out.ObjectType "Subscription" Nothing []
|
||||
quoteField =
|
||||
Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
|
||||
|
||||
quoteType :: Out.ObjectType (Either SomeException)
|
||||
quoteType :: Out.ObjectType IO
|
||||
quoteType = Out.ObjectType "Quote" Nothing []
|
||||
$ HashMap.singleton "quote"
|
||||
$ ValueResolver quoteField
|
||||
@ -181,7 +211,7 @@ quoteType = Out.ObjectType "Quote" Nothing []
|
||||
quoteField =
|
||||
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
schoolType :: EnumType
|
||||
schoolType :: Type.EnumType
|
||||
schoolType = EnumType "School" Nothing $ HashMap.fromList
|
||||
[ ("NOMINALISM", EnumValue Nothing)
|
||||
, ("REALISM", EnumValue Nothing)
|
||||
@ -189,177 +219,252 @@ schoolType = EnumType "School" Nothing $ HashMap.fromList
|
||||
]
|
||||
|
||||
type EitherStreamOrValue = Either
|
||||
(ResponseEventStream (Either SomeException) Aeson.Value)
|
||||
(Response Aeson.Value)
|
||||
(ResponseEventStream IO Type.Value)
|
||||
(Response Type.Value)
|
||||
|
||||
execute' :: Document -> Either SomeException EitherStreamOrValue
|
||||
execute' =
|
||||
execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
-- Asserts that a query resolves to a value.
|
||||
shouldResolveTo :: Text.Text -> Response Type.Value -> Expectation
|
||||
shouldResolveTo querySource expected =
|
||||
case parse document "" querySource of
|
||||
(Right parsedDocument) ->
|
||||
execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value) parsedDocument >>= go
|
||||
(Left errorBundle) -> expectationFailure $ errorBundlePretty errorBundle
|
||||
where
|
||||
go = \case
|
||||
Right result -> shouldBe result expected
|
||||
Left _ -> expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||
|
||||
-- Asserts that the executor produces an error that starts with a string.
|
||||
shouldContainError :: Either (ResponseEventStream IO Type.Value) (Response Type.Value)
|
||||
-> Text
|
||||
-> Expectation
|
||||
shouldContainError streamOrValue expected =
|
||||
case streamOrValue of
|
||||
Right response -> respond response
|
||||
Left _ -> expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||
where
|
||||
startsWith :: Text.Text -> Text.Text -> Bool
|
||||
startsWith xs ys = Text.take (Text.length ys) xs == ys
|
||||
respond :: Response Type.Value -> Expectation
|
||||
respond Response{ errors }
|
||||
| any ((`startsWith` expected) . message) errors = pure ()
|
||||
| otherwise = expectationFailure
|
||||
"the query is expected to execute with errors, but the response doesn't contain any errors"
|
||||
|
||||
parseAndExecute :: Schema IO
|
||||
-> Maybe Text
|
||||
-> HashMap Name Type.Value
|
||||
-> Text
|
||||
-> IO (Either (ResponseEventStream IO Type.Value) (Response Type.Value))
|
||||
parseAndExecute schema' operation variables
|
||||
= either (pure . parseError) (execute schema' operation variables)
|
||||
. parse document ""
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "execute" $ do
|
||||
it "rejects recursive fragments" $
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
...cyclicFragment
|
||||
}
|
||||
|
||||
fragment cyclicFragment on Query {
|
||||
...cyclicFragment
|
||||
}
|
||||
|]
|
||||
expected = Response emptyObject mempty
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" sourceQuery
|
||||
in actual `shouldBe` expected
|
||||
let sourceQuery = "\
|
||||
\{\n\
|
||||
\ ...cyclicFragment\n\
|
||||
\}\n\
|
||||
\\n\
|
||||
\fragment cyclicFragment on Query {\n\
|
||||
\ ...cyclicFragment\n\
|
||||
\}\
|
||||
\"
|
||||
expected = Response (Object mempty) mempty
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "Query" $ do
|
||||
it "skips unknown fields" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.object
|
||||
[ "firstName" .= ("Friedrich" :: String)
|
||||
]
|
||||
]
|
||||
let data'' = Object
|
||||
$ HashMap.singleton "philosopher"
|
||||
$ Object
|
||||
$ HashMap.singleton "firstName"
|
||||
$ String "Friedrich"
|
||||
expected = Response data'' mempty
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName surname } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { firstName surname } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
it "merges selections" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.object
|
||||
[ "firstName" .= ("Friedrich" :: String)
|
||||
, "lastName" .= ("Nietzsche" :: String)
|
||||
let data'' = Object
|
||||
$ HashMap.singleton "philosopher"
|
||||
$ Object
|
||||
$ HashMap.fromList
|
||||
[ ("firstName", String "Friedrich")
|
||||
, ("lastName", String "Nietzsche")
|
||||
]
|
||||
]
|
||||
expected = Response data'' mempty
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "errors on invalid output enum values" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.Null
|
||||
]
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message =
|
||||
"Value completion error. Expected type !School, found: EXISTENTIALISM."
|
||||
"Value completion error. Expected type School!, found: EXISTENTIALISM."
|
||||
, locations = [Location 1 17]
|
||||
, path = [Segment "philosopher", Segment "school"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { school } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { school } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for non-null unions" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.Null
|
||||
]
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message =
|
||||
"Value completion error. Expected type !Interest, found: { instrument: \"piano\" }."
|
||||
"Value completion error. Expected type Interest!, found: { instrument: \"piano\" }."
|
||||
, locations = [Location 1 17]
|
||||
, path = [Segment "philosopher", Segment "interest"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { interest } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { interest } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for invalid interfaces" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.Null
|
||||
]
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message
|
||||
= "Value completion error. Expected type !Work, found:\
|
||||
= "Value completion error. Expected type Work!, found:\
|
||||
\ { title: \"Also sprach Zarathustra: Ein Buch f\252r Alle und Keinen\" }."
|
||||
, locations = [Location 1 17]
|
||||
, path = [Segment "philosopher", Segment "majorWork"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { majorWork { title } } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "gives location information for invalid scalar arguments" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.Null
|
||||
]
|
||||
executionErrors = pure $ Error
|
||||
{ message =
|
||||
"Argument \"id\" has invalid type. Expected type ID, found: True."
|
||||
, locations = [Location 1 15]
|
||||
, path = [Segment "philosopher"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: true) { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { majorWork { title } } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for failed result coercion" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.Null
|
||||
]
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Unable to coerce result to !Int."
|
||||
{ message = "Unable to coerce result to Int!."
|
||||
, locations = [Location 1 26]
|
||||
, path = [Segment "philosopher", Segment "century"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: \"1\") { century } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher(id: \"1\") { century } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for failed result coercion" $
|
||||
let data'' = Aeson.object
|
||||
[ "genres" .= Aeson.Null
|
||||
]
|
||||
let data'' = Object $ HashMap.singleton "throwing" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "PhilosopherException"
|
||||
, locations = [Location 1 3]
|
||||
, path = [Segment "genres"]
|
||||
, path = [Segment "throwing"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ genres }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ throwing }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "sets data to null if a root field isn't nullable" $
|
||||
let executionErrors = pure $ Error
|
||||
{ message = "Unable to coerce result to !Int."
|
||||
{ message = "Unable to coerce result to Int!."
|
||||
, locations = [Location 1 3]
|
||||
, path = [Segment "count"]
|
||||
}
|
||||
expected = Response Aeson.Null executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ count }"
|
||||
in actual `shouldBe` expected
|
||||
expected = Response Null executionErrors
|
||||
sourceQuery = "{ count }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "detects nullability errors" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.Null
|
||||
]
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Value completion error. Expected type !String, found: null."
|
||||
{ message = "Value completion error. Expected type String!, found: null."
|
||||
, locations = [Location 1 26]
|
||||
, path = [Segment "philosopher", Segment "firstLanguage"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: \"1\") { firstLanguage } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher(id: \"1\") { firstLanguage } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "returns list elements in the original order" $
|
||||
let data'' = Object $ HashMap.singleton "sequence" intSequence
|
||||
expected = Response data'' mempty
|
||||
sourceQuery = "{ sequence }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "Arguments" $ do
|
||||
it "gives location information for invalid scalar arguments" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message =
|
||||
"Argument \"id\" has invalid type. Expected type ID, found: True."
|
||||
, locations = [Location 1 15]
|
||||
, path = [Segment "philosopher"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
sourceQuery = "{ philosopher(id: true) { lastName } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "puts an object in a list if needed" $
|
||||
let data'' = Object $ HashMap.singleton "withInputObject" $ Type.Int 0
|
||||
expected = Response data'' mempty
|
||||
sourceQuery = "{ withInputObject(values: { name: 0 }) }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "queryError" $ do
|
||||
let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
|
||||
twoQueries = namedQuery "A" <> " " <> namedQuery "B"
|
||||
|
||||
it "throws operation name is required error" $ do
|
||||
let expectedErrorMessage = "Operation name is required"
|
||||
actual <- parseAndExecute philosopherSchema Nothing mempty twoQueries
|
||||
actual `shouldContainError` expectedErrorMessage
|
||||
|
||||
it "throws operation not found error" $ do
|
||||
let expectedErrorMessage = "Operation \"C\" is not found"
|
||||
actual <- parseAndExecute philosopherSchema (Just "C") mempty twoQueries
|
||||
actual `shouldContainError` expectedErrorMessage
|
||||
|
||||
it "throws variable coercion error" $ do
|
||||
let data'' = Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Failed to coerce the variable $id: String."
|
||||
, locations =[Location 1 7]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
executeWithVars = execute philosopherSchema Nothing (HashMap.singleton "id" (Type.Int 1))
|
||||
Right actual <- either (pure . parseError) executeWithVars
|
||||
$ parse document "" "query($id: String) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
actual `shouldBe` expected
|
||||
|
||||
it "throws variable unkown input type error" $
|
||||
let data'' = Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Variable $id has unknown type Cat."
|
||||
, locations =[Location 1 7]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
sourceQuery = "query($id: Cat) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "Error path" $ do
|
||||
let executeHero :: Document -> IO EitherStreamOrValue
|
||||
executeHero = execute heroSchema Nothing (HashMap.empty :: HashMap Name Type.Value)
|
||||
|
||||
it "at the beggining of the list" $ do
|
||||
Right actual <- either (pure . parseError) executeHero
|
||||
$ parse document "" "{ hero(id: \"1\") { friends { name } } }"
|
||||
let Response _ errors' = actual
|
||||
Error _ _ path' = fromJust $ Seq.lookup 0 errors'
|
||||
expected = [Segment "hero", Segment "friends", Index 0, Segment "name"]
|
||||
in path' `shouldBe` expected
|
||||
|
||||
context "Subscription" $
|
||||
it "subscribes" $
|
||||
let data'' = Aeson.object
|
||||
[ "newQuote" .= Aeson.object
|
||||
[ "quote" .= ("Naturam expelles furca, tamen usque recurret." :: String)
|
||||
]
|
||||
]
|
||||
it "subscribes" $ do
|
||||
let data'' = Object
|
||||
$ HashMap.singleton "newQuote"
|
||||
$ Object
|
||||
$ HashMap.singleton "quote"
|
||||
$ String "Naturam expelles furca, tamen usque recurret."
|
||||
expected = Response data'' mempty
|
||||
Right (Left stream) = either (pure . parseError) execute'
|
||||
$ parse document "" "subscription { newQuote { quote } }"
|
||||
Right (Just actual) = runConduit $ stream .| await
|
||||
in actual `shouldBe` expected
|
||||
Left stream <- execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value)
|
||||
$ fromRight (error "Parse error")
|
||||
$ parse document "" "subscription { newQuote { quote } }"
|
||||
Just actual <- runConduit $ stream .| await
|
||||
actual `shouldBe` expected
|
||||
|
File diff suppressed because it is too large
Load Diff
70
tests/Schemas/HeroSchema.hs
Normal file
70
tests/Schemas/HeroSchema.hs
Normal file
@ -0,0 +1,70 @@
|
||||
{- 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 #-}
|
||||
|
||||
module Schemas.HeroSchema (heroSchema) where
|
||||
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Language.GraphQL.Error (ResolverException (..))
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import Language.GraphQL.Type.Schema (schemaWithTypes)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Typeable (cast)
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
||||
data HeroException = HeroException
|
||||
deriving Show
|
||||
|
||||
instance Exception HeroException where
|
||||
toException = toException. ResolverException
|
||||
fromException e = do
|
||||
ResolverException resolverException <- fromException e
|
||||
cast resolverException
|
||||
|
||||
heroSchema :: Type.Schema IO
|
||||
heroSchema =
|
||||
schemaWithTypes Nothing queryType Nothing Nothing [] mempty
|
||||
|
||||
type ObjectType = Out.ObjectType IO
|
||||
|
||||
queryType :: ObjectType
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("hero", Out.ValueResolver heroField heroResolver)
|
||||
]
|
||||
where
|
||||
heroField = Out.Field Nothing (Out.NamedObjectType heroType)
|
||||
$ HashMap.singleton "id"
|
||||
$ In.Argument Nothing (In.NamedScalarType Type.id) Nothing
|
||||
heroResolver = pure $ Type.Object mempty
|
||||
|
||||
stringField :: Out.Field IO
|
||||
stringField = Out.Field Nothing (Out.NonNullScalarType Type.string) HashMap.empty
|
||||
|
||||
heroType :: ObjectType
|
||||
heroType = Out.ObjectType "Hero" Nothing [] $ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("id", Out.ValueResolver stringField (pure $ Type.String "4111"))
|
||||
, ("name", Out.ValueResolver stringField (pure $ Type.String "R2D2"))
|
||||
, ("friends", Out.ValueResolver friendsField (pure $ Type.List [luke]))
|
||||
]
|
||||
friendsField = Out.Field Nothing (Out.ListType $ Out.NonNullObjectType lukeType) HashMap.empty
|
||||
-- This list values are ignored because of current realisation (types and resolvers are the same entity)
|
||||
-- The values from lukeType will be used
|
||||
luke = Type.Object $ HashMap.fromList
|
||||
[ ("id", "dfdfdf")
|
||||
, ("name", "dfdfdff")
|
||||
]
|
||||
|
||||
lukeType :: ObjectType
|
||||
lukeType = Out.ObjectType "Luke" Nothing [] $ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("id", Out.ValueResolver stringField (pure $ Type.String "1000"))
|
||||
, ("name", Out.ValueResolver stringField (throwM HeroException))
|
||||
]
|
@ -1,92 +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 Test.DirectiveSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Aeson (object, (.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Language.GraphQL
|
||||
import Language.GraphQL.TH
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.GraphQL
|
||||
|
||||
experimentalResolver :: Schema IO
|
||||
experimentalResolver = schema queryType Nothing Nothing mempty
|
||||
where
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.singleton "experimentalField"
|
||||
$ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||
$ pure $ Int 5
|
||||
|
||||
emptyObject :: Aeson.Object
|
||||
emptyObject = HashMap.singleton "data" $ object []
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "Directive executor" $ do
|
||||
it "should be able to @skip fields" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
experimentalField @skip(if: true)
|
||||
}
|
||||
|]
|
||||
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldResolveTo` emptyObject
|
||||
|
||||
it "should not skip fields if @skip is false" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
experimentalField @skip(if: false)
|
||||
}
|
||||
|]
|
||||
expected = HashMap.singleton "data"
|
||||
$ object
|
||||
[ "experimentalField" .= (5 :: Int)
|
||||
]
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldResolveTo` expected
|
||||
|
||||
it "should skip fields if @include is false" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
experimentalField @include(if: false)
|
||||
}
|
||||
|]
|
||||
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldResolveTo` emptyObject
|
||||
|
||||
it "should be able to @skip a fragment spread" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
...experimentalFragment @skip(if: true)
|
||||
}
|
||||
|
||||
fragment experimentalFragment on Query {
|
||||
experimentalField
|
||||
}
|
||||
|]
|
||||
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldResolveTo` emptyObject
|
||||
|
||||
it "should be able to @skip an inline fragment" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
... on Query @skip(if: true) {
|
||||
experimentalField
|
||||
}
|
||||
}
|
||||
|]
|
||||
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldResolveTo` emptyObject
|
@ -1,204 +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 Test.FragmentSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.TH
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.GraphQL
|
||||
|
||||
size :: (Text, Value)
|
||||
size = ("size", String "L")
|
||||
|
||||
circumference :: (Text, Value)
|
||||
circumference = ("circumference", Int 60)
|
||||
|
||||
garment :: Text -> (Text, Value)
|
||||
garment typeName =
|
||||
("garment", Object $ HashMap.fromList
|
||||
[ if typeName == "Hat" then circumference else size
|
||||
, ("__typename", String typeName)
|
||||
]
|
||||
)
|
||||
|
||||
inlineQuery :: Text
|
||||
inlineQuery = [gql|
|
||||
{
|
||||
garment {
|
||||
... on Hat {
|
||||
circumference
|
||||
}
|
||||
... on Shirt {
|
||||
size
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
|
||||
shirtType :: Out.ObjectType IO
|
||||
shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList
|
||||
[ ("size", sizeFieldType)
|
||||
]
|
||||
|
||||
hatType :: Out.ObjectType IO
|
||||
hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList
|
||||
[ ("size", sizeFieldType)
|
||||
, ("circumference", circumferenceFieldType)
|
||||
]
|
||||
|
||||
circumferenceFieldType :: Out.Resolver IO
|
||||
circumferenceFieldType
|
||||
= Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||
$ pure $ snd circumference
|
||||
|
||||
sizeFieldType :: Out.Resolver IO
|
||||
sizeFieldType
|
||||
= Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ pure $ snd size
|
||||
|
||||
toSchema :: Text -> (Text, Value) -> Schema IO
|
||||
toSchema t (_, resolve) = schema queryType Nothing Nothing mempty
|
||||
where
|
||||
garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
|
||||
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
garmentField = Out.Field Nothing (Out.NamedUnionType garmentType) mempty
|
||||
queryType =
|
||||
case t of
|
||||
"circumference" -> hatType
|
||||
"size" -> shirtType
|
||||
_ -> Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("garment", ValueResolver garmentField (pure resolve))
|
||||
, ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
|
||||
]
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "Inline fragment executor" $ do
|
||||
it "chooses the first selection if the type matches" $ do
|
||||
actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
|
||||
let expected = HashMap.singleton "data"
|
||||
$ Aeson.object
|
||||
[ "garment" .= Aeson.object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
]
|
||||
]
|
||||
in actual `shouldResolveTo` expected
|
||||
|
||||
it "chooses the last selection if the type matches" $ do
|
||||
actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
|
||||
let expected = HashMap.singleton "data"
|
||||
$ Aeson.object
|
||||
[ "garment" .= Aeson.object
|
||||
[ "size" .= ("L" :: Text)
|
||||
]
|
||||
]
|
||||
in actual `shouldResolveTo` expected
|
||||
|
||||
it "embeds inline fragments without type" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
circumference
|
||||
... {
|
||||
size
|
||||
}
|
||||
}
|
||||
|]
|
||||
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
||||
let expected = HashMap.singleton "data"
|
||||
$ Aeson.object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
, "size" .= ("L" :: Text)
|
||||
]
|
||||
in actual `shouldResolveTo` expected
|
||||
|
||||
it "evaluates fragments on Query" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
... {
|
||||
size
|
||||
}
|
||||
}
|
||||
|]
|
||||
in graphql (toSchema "size" size) `shouldResolve` sourceQuery
|
||||
|
||||
describe "Fragment spread executor" $ do
|
||||
it "evaluates fragment spreads" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
...circumferenceFragment
|
||||
}
|
||||
|
||||
fragment circumferenceFragment on Hat {
|
||||
circumference
|
||||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
||||
let expected = HashMap.singleton "data"
|
||||
$ Aeson.object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
]
|
||||
in actual `shouldResolveTo` expected
|
||||
|
||||
it "evaluates nested fragments" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
garment {
|
||||
...circumferenceFragment
|
||||
}
|
||||
}
|
||||
|
||||
fragment circumferenceFragment on Hat {
|
||||
...hatFragment
|
||||
}
|
||||
|
||||
fragment hatFragment on Hat {
|
||||
circumference
|
||||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
|
||||
let expected = HashMap.singleton "data"
|
||||
$ Aeson.object
|
||||
[ "garment" .= Aeson.object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
]
|
||||
]
|
||||
in actual `shouldResolveTo` expected
|
||||
|
||||
it "considers type condition" $ do
|
||||
let sourceQuery = [gql|
|
||||
{
|
||||
garment {
|
||||
...circumferenceFragment
|
||||
...sizeFragment
|
||||
}
|
||||
}
|
||||
fragment circumferenceFragment on Hat {
|
||||
circumference
|
||||
}
|
||||
fragment sizeFragment on Shirt {
|
||||
size
|
||||
}
|
||||
|]
|
||||
expected = HashMap.singleton "data"
|
||||
$ Aeson.object
|
||||
[ "garment" .= Aeson.object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
]
|
||||
]
|
||||
actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
|
||||
actual `shouldResolveTo` expected
|
@ -1,72 +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 Test.RootOperationSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Aeson ((.=), object)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Language.GraphQL
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Language.GraphQL.TH
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Test.Hspec.GraphQL
|
||||
|
||||
hatType :: Out.ObjectType IO
|
||||
hatType = Out.ObjectType "Hat" Nothing []
|
||||
$ HashMap.singleton "circumference"
|
||||
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||
$ pure $ Int 60
|
||||
|
||||
garmentSchema :: Schema IO
|
||||
garmentSchema = schema queryType (Just mutationType) Nothing mempty
|
||||
where
|
||||
queryType = Out.ObjectType "Query" Nothing [] hatFieldResolver
|
||||
mutationType = Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
|
||||
garment = pure $ Object $ HashMap.fromList
|
||||
[ ("circumference", Int 60)
|
||||
]
|
||||
incrementFieldResolver = HashMap.singleton "incrementCircumference"
|
||||
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||
$ pure $ Int 61
|
||||
hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty
|
||||
hatFieldResolver =
|
||||
HashMap.singleton "garment" $ ValueResolver hatField garment
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "Root operation type" $ do
|
||||
it "returns objects from the root resolvers" $ do
|
||||
let querySource = [gql|
|
||||
{
|
||||
garment {
|
||||
circumference
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = HashMap.singleton "data"
|
||||
$ object
|
||||
[ "garment" .= object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
]
|
||||
]
|
||||
actual <- graphql garmentSchema querySource
|
||||
actual `shouldResolveTo` expected
|
||||
|
||||
it "chooses Mutation" $ do
|
||||
let querySource = [gql|
|
||||
mutation {
|
||||
incrementCircumference
|
||||
}
|
||||
|]
|
||||
expected = HashMap.singleton "data"
|
||||
$ object
|
||||
[ "incrementCircumference" .= (61 :: Int)
|
||||
]
|
||||
actual <- graphql garmentSchema querySource
|
||||
actual `shouldResolveTo` expected
|
Reference in New Issue
Block a user