Compare commits
29 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | 445f33dcf3 | |
Eugen Wissner | 4a3b4cb16d | |
Eugen Wissner | 7f0fb18716 | |
Eugen Wissner | afcf9aaa14 | |
Eugen Wissner | 6e8d8a34a1 | |
Eugen Wissner | 7c0b0ace4d | |
Eugen Wissner | a91bc7f2d2 | |
Eugen Wissner | d5f518fe82 | |
Eugen Wissner | 6daae8a521 | |
Eugen Wissner | 56b63f1c3e | |
Eugen Wissner | 466416d4b0 | |
Eugen Wissner | 4602eb1df3 | |
Eugen Wissner | ced9b815db | |
Eugen Wissner | 3373c94895 | |
Eugen Wissner | 9bfa2aa7e8 | |
Eugen Wissner | e9a94147fb | |
Eugen Wissner | 3e393004ae | |
Eugen Wissner | 38c3097bcf | |
Eugen Wissner | 21a7d9cce4 | |
Eugen Wissner | 9a08aa5de7 | |
Eugen Wissner | 497b93c41b | |
Eugen Wissner | 6e644c5b4b | |
Eugen Wissner | 4c10ce9204 | |
Eugen Wissner | 08998dbd93 | |
Eugen Wissner | c2c57b6363 | |
Eugen Wissner | f6ff0ab9c7 | |
Eugen Wissner | d327d9d1ce | |
Eugen Wissner | 14ed209828 | |
Eugen Wissner | 33318a3b01 |
|
@ -1,63 +0,0 @@
|
||||||
name: Haskell CI
|
|
||||||
|
|
||||||
on:
|
|
||||||
push: ~
|
|
||||||
pull_request:
|
|
||||||
branches: [master]
|
|
||||||
|
|
||||||
jobs:
|
|
||||||
test:
|
|
||||||
runs-on: ubuntu-latest
|
|
||||||
|
|
||||||
steps:
|
|
||||||
- uses: actions/checkout@v2
|
|
||||||
- uses: actions/setup-haskell@v1
|
|
||||||
with:
|
|
||||||
enable-stack: true
|
|
||||||
stack-no-global: true
|
|
||||||
stack-version: latest
|
|
||||||
|
|
||||||
- name: Cache
|
|
||||||
uses: actions/cache@v2
|
|
||||||
with:
|
|
||||||
path: |
|
|
||||||
~/.stack
|
|
||||||
stack.yaml.lock
|
|
||||||
key: ${{ runner.os }}-test-${{ hashFiles('**/stack.yaml') }}
|
|
||||||
restore-keys: ${{ runner.os }}-test-
|
|
||||||
|
|
||||||
- name: Install dependencies
|
|
||||||
run: stack --no-terminal test --only-snapshot
|
|
||||||
- name: Run tests
|
|
||||||
run: stack --no-terminal test --pedantic
|
|
||||||
- name: Build the documentation
|
|
||||||
run: |
|
|
||||||
stack --no-terminal ghc -- -Wall -Werror -fno-code docs/tutorial/tutorial.lhs
|
|
||||||
stack --no-terminal haddock --no-haddock-deps
|
|
||||||
|
|
||||||
lint:
|
|
||||||
runs-on: ubuntu-latest
|
|
||||||
|
|
||||||
steps:
|
|
||||||
- uses: actions/checkout@v2
|
|
||||||
- uses: actions/setup-haskell@v1
|
|
||||||
with:
|
|
||||||
enable-stack: true
|
|
||||||
stack-no-global: true
|
|
||||||
stack-version: latest
|
|
||||||
|
|
||||||
- name: Cache
|
|
||||||
uses: actions/cache@v2
|
|
||||||
with:
|
|
||||||
path: |
|
|
||||||
~/.stack
|
|
||||||
stack.yaml.lock
|
|
||||||
key: ${{ runner.os }}-lint-${{ hashFiles('**/stack.yaml') }}
|
|
||||||
restore-keys: ${{ runner.os }}-lint-
|
|
||||||
|
|
||||||
- name: Build HLint
|
|
||||||
run: stack --no-terminal build hlint
|
|
||||||
- name: Install HLint
|
|
||||||
run: stack --no-terminal install hlint
|
|
||||||
- name: Lint
|
|
||||||
run: stack --no-terminal exec hlint -- src tests docs
|
|
105
CHANGELOG.md
105
CHANGELOG.md
|
@ -6,28 +6,94 @@ The format is based on
|
||||||
and this project adheres to
|
and this project adheres to
|
||||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||||
|
|
||||||
|
## [0.11.0.0] - 2020-11-07
|
||||||
|
### Changed
|
||||||
|
- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
|
||||||
|
and `InlineFragment`. Thus validation rules can be defined more concise.
|
||||||
|
- `AST.Document`: `Argument` and `Directive` contain token location.
|
||||||
|
- `AST.Document.Argument` contains the `Value` wrapped in the `Node`.
|
||||||
|
- `AST.Lexer.colon` and `AST.Lexer.at` ignore the result (it is always the
|
||||||
|
- same).
|
||||||
|
- `Validate.Validation`: `Validation.rules` was removed. `Validation.rules`
|
||||||
|
contained the list of rules, but the executed rules shouldn't know about other
|
||||||
|
rules. `rules` was a part of the `Validation` context to pass it easier
|
||||||
|
around, but since the rules are traversed once now and applied to all nodes in
|
||||||
|
the tree at the beginning, it isn't required anymore.
|
||||||
|
- `Validate.Validation.Error`: `path` is removed since it isn't possible to get
|
||||||
|
the path without executing the query.
|
||||||
|
- `Error.Error`: `path` added. It is currently always empty.
|
||||||
|
- `Validate.Validation.Path` was moved to `Error`.
|
||||||
|
- `Type.Schema.Schema`: data constructor is hidden, fields are accessible with
|
||||||
|
freestanding functions: `query`, `mutation`, `subscription`, `directives` and
|
||||||
|
`types`.
|
||||||
|
|
||||||
|
### Added
|
||||||
|
- `Validate.Validation.Rule` constructors:
|
||||||
|
- `SelectionRule`
|
||||||
|
- `FragmentRule`
|
||||||
|
- `FragmentSpreadRule`
|
||||||
|
- `ArgumentsRule`
|
||||||
|
- `DirectivesRule`
|
||||||
|
- `VariablesRule`
|
||||||
|
- `FieldRule`
|
||||||
|
- `Validate.Rules`:
|
||||||
|
- `fragmentsOnCompositeTypesRule`
|
||||||
|
- `fragmentSpreadTargetDefinedRule`
|
||||||
|
- `fragmentSpreadTypeExistenceRule`
|
||||||
|
- `noUnusedFragmentsRule`
|
||||||
|
- `noFragmentCyclesRule`
|
||||||
|
- `uniqueArgumentNamesRule`
|
||||||
|
- `uniqueDirectiveNamesRule`
|
||||||
|
- `uniqueVariableNamesRule`
|
||||||
|
- `variablesAreInputTypesRule`
|
||||||
|
- `noUndefinedVariablesRule`
|
||||||
|
- `noUndefinedVariablesRule`
|
||||||
|
- `noUnusedVariablesRule`
|
||||||
|
- `uniqueInputFieldNamesRule`
|
||||||
|
- `fieldsOnCorrectTypeRule`
|
||||||
|
- `scalarLeafsRule`
|
||||||
|
- `knownArgumentNamesRule`
|
||||||
|
- `knownDirectiveNamesRule`
|
||||||
|
- `directivesInValidLocationsRule`
|
||||||
|
- `providedRequiredArgumentsRule`
|
||||||
|
- `providedRequiredInputFieldsRule`
|
||||||
|
- `AST.Document.Field`.
|
||||||
|
- `AST.Document.FragmentSpread`.
|
||||||
|
- `AST.Document.InlineFragment`.
|
||||||
|
- `AST.Document.Node`.
|
||||||
|
- `Type.In.Arguments`: Type alias for an argument map.
|
||||||
|
- `Type.Schema.Directive` and `Type.Schema.Directives` are directive definition
|
||||||
|
representation.
|
||||||
|
- `Type.Schema.schema`: Schema constructor.
|
||||||
|
|
||||||
|
### Fixed
|
||||||
|
- Collecting existing types from the schema considers subscriptions.
|
||||||
|
|
||||||
|
### Removed
|
||||||
|
- `AST.Document.Alias`. Use `AST.Document.Name` instead.
|
||||||
|
|
||||||
## [0.10.0.0] - 2020-08-29
|
## [0.10.0.0] - 2020-08-29
|
||||||
## Changed
|
### Changed
|
||||||
- `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`.
|
- `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`.
|
||||||
- The `Location` argument of `AST.Document.Definition.ExecutableDefinition` was
|
- The `Location` argument of `AST.Document.Definition.ExecutableDefinition` was
|
||||||
moved to `OperationDefinition` and `FragmentDefinition` since these are the
|
moved to `OperationDefinition` and `FragmentDefinition` since these are the
|
||||||
actual elements that have a location in the document.
|
actual elements that have a location in the document.
|
||||||
- `Validate.Rules` get the whole validation context (AST and schema).
|
- `Validate.Rules` get the whole validation context (AST and schema).
|
||||||
|
|
||||||
## Added
|
### Added
|
||||||
- `Validate.Validation` contains data structures and functions used by the
|
- `Validate.Validation` contains data structures and functions used by the
|
||||||
validator and concretet rules.
|
validator and concretet rules.
|
||||||
- `Validate.Rules`: operation validation rules.
|
- `Validate.Rules`: operation validation rules.
|
||||||
|
|
||||||
## [0.9.0.0] - 2020-07-24
|
## [0.9.0.0] - 2020-07-24
|
||||||
## Fixed
|
### Fixed
|
||||||
- Location of a parse error is returned in a singleton array with key
|
- Location of a parse error is returned in a singleton array with key
|
||||||
`locations`.
|
`locations`.
|
||||||
- Parsing comments in the front of definitions.
|
- Parsing comments in the front of definitions.
|
||||||
- Some missing labels were added to the parsers, some labels were fixed to
|
- Some missing labels were added to the parsers, some labels were fixed to
|
||||||
refer to the AST nodes being parsed.
|
refer to the AST nodes being parsed.
|
||||||
|
|
||||||
## Added
|
### Added
|
||||||
- `AST` reexports `AST.Parser`.
|
- `AST` reexports `AST.Parser`.
|
||||||
- `AST.Document.Location` is a token location as a line and column pair.
|
- `AST.Document.Location` is a token location as a line and column pair.
|
||||||
- `Execute` reexports `Execute.Coerce`.
|
- `Execute` reexports `Execute.Coerce`.
|
||||||
|
@ -43,7 +109,7 @@ and this project adheres to
|
||||||
- `Test.Hspec.GraphQL` contains some test helpers.
|
- `Test.Hspec.GraphQL` contains some test helpers.
|
||||||
- `Validate` contains the validator and standard rules.
|
- `Validate` contains the validator and standard rules.
|
||||||
|
|
||||||
## Changed
|
### Changed
|
||||||
- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
|
- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
|
||||||
have value resolvers, root subscription type resolvers need an additional
|
have value resolvers, root subscription type resolvers need an additional
|
||||||
resolver that creates an event stream. `Resolver` represents these differences
|
resolver that creates an event stream. `Resolver` represents these differences
|
||||||
|
@ -67,7 +133,7 @@ and this project adheres to
|
||||||
- The constraint of the base monad was changed to `MonadCatch` (and it implies
|
- The constraint of the base monad was changed to `MonadCatch` (and it implies
|
||||||
`MonadThrow`).
|
`MonadThrow`).
|
||||||
|
|
||||||
## Removed
|
### Removed
|
||||||
- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
|
- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
|
||||||
represents possible resolver configurations.
|
represents possible resolver configurations.
|
||||||
- `Execute.executeWithName`. `Execute.execute` takes the operation name and
|
- `Execute.executeWithName`. `Execute.execute` takes the operation name and
|
||||||
|
@ -334,16 +400,17 @@ and this project adheres to
|
||||||
### Added
|
### Added
|
||||||
- Data types for the GraphQL language.
|
- Data types for the GraphQL language.
|
||||||
|
|
||||||
[0.10.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.9.0.0...v0.10.0.0
|
[0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0
|
||||||
[0.9.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...v0.9.0.0
|
[0.10.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.10.0.0&rev_to=v0.9.0.0
|
||||||
[0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0
|
[0.9.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.9.0.0&rev_to=v0.8.0.0
|
||||||
[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.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.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.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.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.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.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...v0.5.1.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.0.1]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.0...v0.5.0.1
|
[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.0]: https://github.com/caraus-ecms/graphql/compare/v0.4.0.0...v0.5.0.0
|
[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.4.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.3...v0.4.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.3]: https://github.com/caraus-ecms/graphql/compare/v0.2.1...v0.3
|
[0.4.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.4.0.0&rev_to=v0.3
|
||||||
[0.2.1]: https://github.com/caraus-ecms/graphql/compare/v0.2...v0.2.1
|
[0.3]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.3&rev_to=v0.2.1
|
||||||
[0.2]: https://github.com/caraus-ecms/graphql/compare/v0.1...v0.2
|
[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,31 +0,0 @@
|
||||||
# Contributing guidelines
|
|
||||||
|
|
||||||
## Testing
|
|
||||||
|
|
||||||
To ensure all code changes adhere to existing code quality standards, some
|
|
||||||
automatic checks can be run locally.
|
|
||||||
|
|
||||||
Ensure that the code builds without warnings and passes the tests:
|
|
||||||
|
|
||||||
```sh
|
|
||||||
stack test --pedantic
|
|
||||||
```
|
|
||||||
|
|
||||||
And also run the linter on your code:
|
|
||||||
|
|
||||||
```sh
|
|
||||||
stack build hlint
|
|
||||||
stack exec hlint -- src tests
|
|
||||||
```
|
|
||||||
|
|
||||||
Build the documentation and check if you get any warnings:
|
|
||||||
|
|
||||||
```sh
|
|
||||||
stack haddock
|
|
||||||
```
|
|
||||||
|
|
||||||
Validate that literate Haskell (tutorials) files compile without any warnings:
|
|
||||||
|
|
||||||
```sh
|
|
||||||
stack ghc -- -Wall -fno-code docs/tutorial/*.lhs
|
|
||||||
```
|
|
|
@ -0,0 +1,373 @@
|
||||||
|
Mozilla Public License Version 2.0
|
||||||
|
==================================
|
||||||
|
|
||||||
|
1. Definitions
|
||||||
|
--------------
|
||||||
|
|
||||||
|
1.1. "Contributor"
|
||||||
|
means each individual or legal entity that creates, contributes to
|
||||||
|
the creation of, or owns Covered Software.
|
||||||
|
|
||||||
|
1.2. "Contributor Version"
|
||||||
|
means the combination of the Contributions of others (if any) used
|
||||||
|
by a Contributor and that particular Contributor's Contribution.
|
||||||
|
|
||||||
|
1.3. "Contribution"
|
||||||
|
means Covered Software of a particular Contributor.
|
||||||
|
|
||||||
|
1.4. "Covered Software"
|
||||||
|
means Source Code Form to which the initial Contributor has attached
|
||||||
|
the notice in Exhibit A, the Executable Form of such Source Code
|
||||||
|
Form, and Modifications of such Source Code Form, in each case
|
||||||
|
including portions thereof.
|
||||||
|
|
||||||
|
1.5. "Incompatible With Secondary Licenses"
|
||||||
|
means
|
||||||
|
|
||||||
|
(a) that the initial Contributor has attached the notice described
|
||||||
|
in Exhibit B to the Covered Software; or
|
||||||
|
|
||||||
|
(b) that the Covered Software was made available under the terms of
|
||||||
|
version 1.1 or earlier of the License, but not also under the
|
||||||
|
terms of a Secondary License.
|
||||||
|
|
||||||
|
1.6. "Executable Form"
|
||||||
|
means any form of the work other than Source Code Form.
|
||||||
|
|
||||||
|
1.7. "Larger Work"
|
||||||
|
means a work that combines Covered Software with other material, in
|
||||||
|
a separate file or files, that is not Covered Software.
|
||||||
|
|
||||||
|
1.8. "License"
|
||||||
|
means this document.
|
||||||
|
|
||||||
|
1.9. "Licensable"
|
||||||
|
means having the right to grant, to the maximum extent possible,
|
||||||
|
whether at the time of the initial grant or subsequently, any and
|
||||||
|
all of the rights conveyed by this License.
|
||||||
|
|
||||||
|
1.10. "Modifications"
|
||||||
|
means any of the following:
|
||||||
|
|
||||||
|
(a) any file in Source Code Form that results from an addition to,
|
||||||
|
deletion from, or modification of the contents of Covered
|
||||||
|
Software; or
|
||||||
|
|
||||||
|
(b) any new file in Source Code Form that contains any Covered
|
||||||
|
Software.
|
||||||
|
|
||||||
|
1.11. "Patent Claims" of a Contributor
|
||||||
|
means any patent claim(s), including without limitation, method,
|
||||||
|
process, and apparatus claims, in any patent Licensable by such
|
||||||
|
Contributor that would be infringed, but for the grant of the
|
||||||
|
License, by the making, using, selling, offering for sale, having
|
||||||
|
made, import, or transfer of either its Contributions or its
|
||||||
|
Contributor Version.
|
||||||
|
|
||||||
|
1.12. "Secondary License"
|
||||||
|
means either the GNU General Public License, Version 2.0, the GNU
|
||||||
|
Lesser General Public License, Version 2.1, the GNU Affero General
|
||||||
|
Public License, Version 3.0, or any later versions of those
|
||||||
|
licenses.
|
||||||
|
|
||||||
|
1.13. "Source Code Form"
|
||||||
|
means the form of the work preferred for making modifications.
|
||||||
|
|
||||||
|
1.14. "You" (or "Your")
|
||||||
|
means an individual or a legal entity exercising rights under this
|
||||||
|
License. For legal entities, "You" includes any entity that
|
||||||
|
controls, is controlled by, or is under common control with You. For
|
||||||
|
purposes of this definition, "control" means (a) the power, direct
|
||||||
|
or indirect, to cause the direction or management of such entity,
|
||||||
|
whether by contract or otherwise, or (b) ownership of more than
|
||||||
|
fifty percent (50%) of the outstanding shares or beneficial
|
||||||
|
ownership of such entity.
|
||||||
|
|
||||||
|
2. License Grants and Conditions
|
||||||
|
--------------------------------
|
||||||
|
|
||||||
|
2.1. Grants
|
||||||
|
|
||||||
|
Each Contributor hereby grants You a world-wide, royalty-free,
|
||||||
|
non-exclusive license:
|
||||||
|
|
||||||
|
(a) under intellectual property rights (other than patent or trademark)
|
||||||
|
Licensable by such Contributor to use, reproduce, make available,
|
||||||
|
modify, display, perform, distribute, and otherwise exploit its
|
||||||
|
Contributions, either on an unmodified basis, with Modifications, or
|
||||||
|
as part of a Larger Work; and
|
||||||
|
|
||||||
|
(b) under Patent Claims of such Contributor to make, use, sell, offer
|
||||||
|
for sale, have made, import, and otherwise transfer either its
|
||||||
|
Contributions or its Contributor Version.
|
||||||
|
|
||||||
|
2.2. Effective Date
|
||||||
|
|
||||||
|
The licenses granted in Section 2.1 with respect to any Contribution
|
||||||
|
become effective for each Contribution on the date the Contributor first
|
||||||
|
distributes such Contribution.
|
||||||
|
|
||||||
|
2.3. Limitations on Grant Scope
|
||||||
|
|
||||||
|
The licenses granted in this Section 2 are the only rights granted under
|
||||||
|
this License. No additional rights or licenses will be implied from the
|
||||||
|
distribution or licensing of Covered Software under this License.
|
||||||
|
Notwithstanding Section 2.1(b) above, no patent license is granted by a
|
||||||
|
Contributor:
|
||||||
|
|
||||||
|
(a) for any code that a Contributor has removed from Covered Software;
|
||||||
|
or
|
||||||
|
|
||||||
|
(b) for infringements caused by: (i) Your and any other third party's
|
||||||
|
modifications of Covered Software, or (ii) the combination of its
|
||||||
|
Contributions with other software (except as part of its Contributor
|
||||||
|
Version); or
|
||||||
|
|
||||||
|
(c) under Patent Claims infringed by Covered Software in the absence of
|
||||||
|
its Contributions.
|
||||||
|
|
||||||
|
This License does not grant any rights in the trademarks, service marks,
|
||||||
|
or logos of any Contributor (except as may be necessary to comply with
|
||||||
|
the notice requirements in Section 3.4).
|
||||||
|
|
||||||
|
2.4. Subsequent Licenses
|
||||||
|
|
||||||
|
No Contributor makes additional grants as a result of Your choice to
|
||||||
|
distribute the Covered Software under a subsequent version of this
|
||||||
|
License (see Section 10.2) or under the terms of a Secondary License (if
|
||||||
|
permitted under the terms of Section 3.3).
|
||||||
|
|
||||||
|
2.5. Representation
|
||||||
|
|
||||||
|
Each Contributor represents that the Contributor believes its
|
||||||
|
Contributions are its original creation(s) or it has sufficient rights
|
||||||
|
to grant the rights to its Contributions conveyed by this License.
|
||||||
|
|
||||||
|
2.6. Fair Use
|
||||||
|
|
||||||
|
This License is not intended to limit any rights You have under
|
||||||
|
applicable copyright doctrines of fair use, fair dealing, or other
|
||||||
|
equivalents.
|
||||||
|
|
||||||
|
2.7. Conditions
|
||||||
|
|
||||||
|
Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted
|
||||||
|
in Section 2.1.
|
||||||
|
|
||||||
|
3. Responsibilities
|
||||||
|
-------------------
|
||||||
|
|
||||||
|
3.1. Distribution of Source Form
|
||||||
|
|
||||||
|
All distribution of Covered Software in Source Code Form, including any
|
||||||
|
Modifications that You create or to which You contribute, must be under
|
||||||
|
the terms of this License. You must inform recipients that the Source
|
||||||
|
Code Form of the Covered Software is governed by the terms of this
|
||||||
|
License, and how they can obtain a copy of this License. You may not
|
||||||
|
attempt to alter or restrict the recipients' rights in the Source Code
|
||||||
|
Form.
|
||||||
|
|
||||||
|
3.2. Distribution of Executable Form
|
||||||
|
|
||||||
|
If You distribute Covered Software in Executable Form then:
|
||||||
|
|
||||||
|
(a) such Covered Software must also be made available in Source Code
|
||||||
|
Form, as described in Section 3.1, and You must inform recipients of
|
||||||
|
the Executable Form how they can obtain a copy of such Source Code
|
||||||
|
Form by reasonable means in a timely manner, at a charge no more
|
||||||
|
than the cost of distribution to the recipient; and
|
||||||
|
|
||||||
|
(b) You may distribute such Executable Form under the terms of this
|
||||||
|
License, or sublicense it under different terms, provided that the
|
||||||
|
license for the Executable Form does not attempt to limit or alter
|
||||||
|
the recipients' rights in the Source Code Form under this License.
|
||||||
|
|
||||||
|
3.3. Distribution of a Larger Work
|
||||||
|
|
||||||
|
You may create and distribute a Larger Work under terms of Your choice,
|
||||||
|
provided that You also comply with the requirements of this License for
|
||||||
|
the Covered Software. If the Larger Work is a combination of Covered
|
||||||
|
Software with a work governed by one or more Secondary Licenses, and the
|
||||||
|
Covered Software is not Incompatible With Secondary Licenses, this
|
||||||
|
License permits You to additionally distribute such Covered Software
|
||||||
|
under the terms of such Secondary License(s), so that the recipient of
|
||||||
|
the Larger Work may, at their option, further distribute the Covered
|
||||||
|
Software under the terms of either this License or such Secondary
|
||||||
|
License(s).
|
||||||
|
|
||||||
|
3.4. Notices
|
||||||
|
|
||||||
|
You may not remove or alter the substance of any license notices
|
||||||
|
(including copyright notices, patent notices, disclaimers of warranty,
|
||||||
|
or limitations of liability) contained within the Source Code Form of
|
||||||
|
the Covered Software, except that You may alter any license notices to
|
||||||
|
the extent required to remedy known factual inaccuracies.
|
||||||
|
|
||||||
|
3.5. Application of Additional Terms
|
||||||
|
|
||||||
|
You may choose to offer, and to charge a fee for, warranty, support,
|
||||||
|
indemnity or liability obligations to one or more recipients of Covered
|
||||||
|
Software. However, You may do so only on Your own behalf, and not on
|
||||||
|
behalf of any Contributor. You must make it absolutely clear that any
|
||||||
|
such warranty, support, indemnity, or liability obligation is offered by
|
||||||
|
You alone, and You hereby agree to indemnify every Contributor for any
|
||||||
|
liability incurred by such Contributor as a result of warranty, support,
|
||||||
|
indemnity or liability terms You offer. You may include additional
|
||||||
|
disclaimers of warranty and limitations of liability specific to any
|
||||||
|
jurisdiction.
|
||||||
|
|
||||||
|
4. Inability to Comply Due to Statute or Regulation
|
||||||
|
---------------------------------------------------
|
||||||
|
|
||||||
|
If it is impossible for You to comply with any of the terms of this
|
||||||
|
License with respect to some or all of the Covered Software due to
|
||||||
|
statute, judicial order, or regulation then You must: (a) comply with
|
||||||
|
the terms of this License to the maximum extent possible; and (b)
|
||||||
|
describe the limitations and the code they affect. Such description must
|
||||||
|
be placed in a text file included with all distributions of the Covered
|
||||||
|
Software under this License. Except to the extent prohibited by statute
|
||||||
|
or regulation, such description must be sufficiently detailed for a
|
||||||
|
recipient of ordinary skill to be able to understand it.
|
||||||
|
|
||||||
|
5. Termination
|
||||||
|
--------------
|
||||||
|
|
||||||
|
5.1. The rights granted under this License will terminate automatically
|
||||||
|
if You fail to comply with any of its terms. However, if You become
|
||||||
|
compliant, then the rights granted under this License from a particular
|
||||||
|
Contributor are reinstated (a) provisionally, unless and until such
|
||||||
|
Contributor explicitly and finally terminates Your grants, and (b) on an
|
||||||
|
ongoing basis, if such Contributor fails to notify You of the
|
||||||
|
non-compliance by some reasonable means prior to 60 days after You have
|
||||||
|
come back into compliance. Moreover, Your grants from a particular
|
||||||
|
Contributor are reinstated on an ongoing basis if such Contributor
|
||||||
|
notifies You of the non-compliance by some reasonable means, this is the
|
||||||
|
first time You have received notice of non-compliance with this License
|
||||||
|
from such Contributor, and You become compliant prior to 30 days after
|
||||||
|
Your receipt of the notice.
|
||||||
|
|
||||||
|
5.2. If You initiate litigation against any entity by asserting a patent
|
||||||
|
infringement claim (excluding declaratory judgment actions,
|
||||||
|
counter-claims, and cross-claims) alleging that a Contributor Version
|
||||||
|
directly or indirectly infringes any patent, then the rights granted to
|
||||||
|
You by any and all Contributors for the Covered Software under Section
|
||||||
|
2.1 of this License shall terminate.
|
||||||
|
|
||||||
|
5.3. In the event of termination under Sections 5.1 or 5.2 above, all
|
||||||
|
end user license agreements (excluding distributors and resellers) which
|
||||||
|
have been validly granted by You or Your distributors under this License
|
||||||
|
prior to termination shall survive termination.
|
||||||
|
|
||||||
|
************************************************************************
|
||||||
|
* *
|
||||||
|
* 6. Disclaimer of Warranty *
|
||||||
|
* ------------------------- *
|
||||||
|
* *
|
||||||
|
* Covered Software is provided under this License on an "as is" *
|
||||||
|
* basis, without warranty of any kind, either expressed, implied, or *
|
||||||
|
* statutory, including, without limitation, warranties that the *
|
||||||
|
* Covered Software is free of defects, merchantable, fit for a *
|
||||||
|
* particular purpose or non-infringing. The entire risk as to the *
|
||||||
|
* quality and performance of the Covered Software is with You. *
|
||||||
|
* Should any Covered Software prove defective in any respect, You *
|
||||||
|
* (not any Contributor) assume the cost of any necessary servicing, *
|
||||||
|
* repair, or correction. This disclaimer of warranty constitutes an *
|
||||||
|
* essential part of this License. No use of any Covered Software is *
|
||||||
|
* authorized under this License except under this disclaimer. *
|
||||||
|
* *
|
||||||
|
************************************************************************
|
||||||
|
|
||||||
|
************************************************************************
|
||||||
|
* *
|
||||||
|
* 7. Limitation of Liability *
|
||||||
|
* -------------------------- *
|
||||||
|
* *
|
||||||
|
* Under no circumstances and under no legal theory, whether tort *
|
||||||
|
* (including negligence), contract, or otherwise, shall any *
|
||||||
|
* Contributor, or anyone who distributes Covered Software as *
|
||||||
|
* permitted above, be liable to You for any direct, indirect, *
|
||||||
|
* special, incidental, or consequential damages of any character *
|
||||||
|
* including, without limitation, damages for lost profits, loss of *
|
||||||
|
* goodwill, work stoppage, computer failure or malfunction, or any *
|
||||||
|
* and all other commercial damages or losses, even if such party *
|
||||||
|
* shall have been informed of the possibility of such damages. This *
|
||||||
|
* limitation of liability shall not apply to liability for death or *
|
||||||
|
* personal injury resulting from such party's negligence to the *
|
||||||
|
* extent applicable law prohibits such limitation. Some *
|
||||||
|
* jurisdictions do not allow the exclusion or limitation of *
|
||||||
|
* incidental or consequential damages, so this exclusion and *
|
||||||
|
* limitation may not apply to You. *
|
||||||
|
* *
|
||||||
|
************************************************************************
|
||||||
|
|
||||||
|
8. Litigation
|
||||||
|
-------------
|
||||||
|
|
||||||
|
Any litigation relating to this License may be brought only in the
|
||||||
|
courts of a jurisdiction where the defendant maintains its principal
|
||||||
|
place of business and such litigation shall be governed by laws of that
|
||||||
|
jurisdiction, without reference to its conflict-of-law provisions.
|
||||||
|
Nothing in this Section shall prevent a party's ability to bring
|
||||||
|
cross-claims or counter-claims.
|
||||||
|
|
||||||
|
9. Miscellaneous
|
||||||
|
----------------
|
||||||
|
|
||||||
|
This License represents the complete agreement concerning the subject
|
||||||
|
matter hereof. If any provision of this License is held to be
|
||||||
|
unenforceable, such provision shall be reformed only to the extent
|
||||||
|
necessary to make it enforceable. Any law or regulation which provides
|
||||||
|
that the language of a contract shall be construed against the drafter
|
||||||
|
shall not be used to construe this License against a Contributor.
|
||||||
|
|
||||||
|
10. Versions of the License
|
||||||
|
---------------------------
|
||||||
|
|
||||||
|
10.1. New Versions
|
||||||
|
|
||||||
|
Mozilla Foundation is the license steward. Except as provided in Section
|
||||||
|
10.3, no one other than the license steward has the right to modify or
|
||||||
|
publish new versions of this License. Each version will be given a
|
||||||
|
distinguishing version number.
|
||||||
|
|
||||||
|
10.2. Effect of New Versions
|
||||||
|
|
||||||
|
You may distribute the Covered Software under the terms of the version
|
||||||
|
of the License under which You originally received the Covered Software,
|
||||||
|
or under the terms of any subsequent version published by the license
|
||||||
|
steward.
|
||||||
|
|
||||||
|
10.3. Modified Versions
|
||||||
|
|
||||||
|
If you create software not governed by this License, and you want to
|
||||||
|
create a new license for such software, you may create and use a
|
||||||
|
modified version of this License if you rename the license and remove
|
||||||
|
any references to the name of the license steward (except to note that
|
||||||
|
such modified license differs from this License).
|
||||||
|
|
||||||
|
10.4. Distributing Source Code Form that is Incompatible With Secondary
|
||||||
|
Licenses
|
||||||
|
|
||||||
|
If You choose to distribute Source Code Form that is Incompatible With
|
||||||
|
Secondary Licenses under the terms of this version of the License, the
|
||||||
|
notice described in Exhibit B of this License must be attached.
|
||||||
|
|
||||||
|
Exhibit A - Source Code Form License Notice
|
||||||
|
-------------------------------------------
|
||||||
|
|
||||||
|
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 http://mozilla.org/MPL/2.0/.
|
||||||
|
|
||||||
|
If it is not possible or desirable to put the notice in a particular
|
||||||
|
file, then You may include the notice in a location (such as a LICENSE
|
||||||
|
file in a relevant directory) where a recipient would be likely to look
|
||||||
|
for such a notice.
|
||||||
|
|
||||||
|
You may add additional accurate notices of copyright ownership.
|
||||||
|
|
||||||
|
Exhibit B - "Incompatible With Secondary Licenses" Notice
|
||||||
|
---------------------------------------------------------
|
||||||
|
|
||||||
|
This Source Code Form is "Incompatible With Secondary Licenses", as
|
||||||
|
defined by the Mozilla Public License, v. 2.0.
|
124
README.md
124
README.md
|
@ -1,9 +1,7 @@
|
||||||
# GraphQL implementation in Haskell
|
# GraphQL implementation in Haskell
|
||||||
|
|
||||||
[![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)
|
|
||||||
[![Build Status](https://github.com/caraus-ecms/graphql/workflows/Haskell%20CI/badge.svg)](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22)
|
|
||||||
[![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)
|
|
||||||
[![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org)
|
[![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org)
|
||||||
|
[![CI/CD](https://img.shields.io/badge/CI-CD-brightgreen)](https://build.caraus.tech/go/pipelines)
|
||||||
|
|
||||||
This implementation is relatively low-level by design, it doesn't provide any
|
This implementation is relatively low-level by design, it doesn't provide any
|
||||||
mappings between the GraphQL types and Haskell's type system and avoids
|
mappings between the GraphQL types and Haskell's type system and avoids
|
||||||
|
@ -24,125 +22,13 @@ For now this library provides:
|
||||||
But the idea is to be a Haskell port of
|
But the idea is to be a Haskell port of
|
||||||
[`graphql-js`](https://github.com/graphql/graphql-js).
|
[`graphql-js`](https://github.com/graphql/graphql-js).
|
||||||
|
|
||||||
For a more precise list of currently missing features see issues marked as
|
For a more precise list of currently missing features see
|
||||||
"[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)".
|
[issues](https://www.caraus.tech/projects/pub-graphql/issues).
|
||||||
|
|
||||||
## Documentation
|
## Documentation
|
||||||
|
|
||||||
API documentation is available through
|
API documentation is available through
|
||||||
[Hackage](https://hackage.haskell.org/package/graphql).
|
[Hackage](https://hackage.haskell.org/package/graphql).
|
||||||
|
|
||||||
You'll also find a small tutorial with some examples under
|
Further documentation will be made available in the
|
||||||
[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
|
[Wiki](https://www.caraus.tech/projects/pub-graphql/wiki).
|
||||||
|
|
||||||
### Getting started
|
|
||||||
|
|
||||||
We start with a simple GraphQL API that provides us with some famous and less
|
|
||||||
famous cites.
|
|
||||||
|
|
||||||
```graphql
|
|
||||||
"""
|
|
||||||
Root Query type.
|
|
||||||
"""
|
|
||||||
type Query {
|
|
||||||
"""
|
|
||||||
Provides a cite.
|
|
||||||
"""
|
|
||||||
cite: String!
|
|
||||||
}
|
|
||||||
```
|
|
||||||
|
|
||||||
This is called a GraphQL schema, it defines all queries supported by the API.
|
|
||||||
`Query` is the root query type. Every GraphQL API should define a query type.
|
|
||||||
|
|
||||||
`Query` has a single field `cite` that returns a `String`. The `!` after the
|
|
||||||
type denotes that the returned value cannot be `Null`. GraphQL fields are
|
|
||||||
nullable by default.
|
|
||||||
|
|
||||||
To be able to work with this schema, we are going to implement it in Haskell.
|
|
||||||
|
|
||||||
```haskell
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
import Control.Exception (SomeException)
|
|
||||||
import qualified Data.Aeson as Aeson
|
|
||||||
import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
|
||||||
import Language.GraphQL
|
|
||||||
import Language.GraphQL.Type
|
|
||||||
import qualified Language.GraphQL.Type.Out as Out
|
|
||||||
|
|
||||||
-- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions.
|
|
||||||
-- Our first schema supports only queries.
|
|
||||||
schema :: Schema IO
|
|
||||||
schema = Schema
|
|
||||||
{ query = queryType, mutation = Nothing, subscription = Nothing }
|
|
||||||
|
|
||||||
-- GraphQL distinguishes between input and output types. Input types are field
|
|
||||||
-- argument types and they are defined in Language.GraphQL.Type.In. Output types
|
|
||||||
-- are result types, they are defined in Language.GraphQL.Type.Out. Root types
|
|
||||||
-- are always object types.
|
|
||||||
--
|
|
||||||
-- Here we define a type "Query". The second argument is an optional
|
|
||||||
-- description, the third one is the list of interfaces implemented by the
|
|
||||||
-- object type. The last argument is a field map. Keys are field names, values
|
|
||||||
-- are field definitions and resolvers. Resolvers are the functions, where the
|
|
||||||
-- actual logic lives, they return values for the respective fields.
|
|
||||||
queryType :: Out.ObjectType IO
|
|
||||||
queryType = Out.ObjectType "Query" (Just "Root Query type.") []
|
|
||||||
$ HashMap.singleton "cite" citeResolver
|
|
||||||
where
|
|
||||||
-- 'ValueResolver' is a 'Resolver' data constructor, it combines a field
|
|
||||||
-- definition with its resolver function. This function resolves a value for
|
|
||||||
-- a field (as opposed to the 'EventStreamResolver' used by subscriptions).
|
|
||||||
-- Our resolver just returns a constant value.
|
|
||||||
citeResolver = ValueResolver citeField
|
|
||||||
$ pure "Piscis primum a capite foetat"
|
|
||||||
-- The first argument is an optional field description. The second one is
|
|
||||||
-- the field type and the third one is for arguments (we have none in this
|
|
||||||
-- example).
|
|
||||||
--
|
|
||||||
-- GraphQL has named and wrapping types. String is a scalar, named type.
|
|
||||||
-- Named types are nullable by default. To make our "cite" field
|
|
||||||
-- non-nullable, we wrap it in the wrapping type, Non-Null.
|
|
||||||
citeField = Out.Field
|
|
||||||
(Just "Provides a cite.") (Out.NonNullScalarType string) HashMap.empty
|
|
||||||
|
|
||||||
-- Now we can execute a query. Since our schema defines only one field,
|
|
||||||
-- everything we can do is to ask to resolve it and give back the result.
|
|
||||||
-- Since subscriptions don't return plain values, the 'graphql' function returns
|
|
||||||
-- an 'Either'. 'Left' is for subscriptions, 'Right' is for queries and
|
|
||||||
-- mutations.
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
Right result <- graphql schema "{ cite }"
|
|
||||||
ByteString.Lazy.Char8.putStrLn $ Aeson.encode result
|
|
||||||
```
|
|
||||||
|
|
||||||
Executing this query produces the following JSON:
|
|
||||||
|
|
||||||
```json
|
|
||||||
{
|
|
||||||
"data": {
|
|
||||||
"cite": "Piscis primum a capite foetat"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
```
|
|
||||||
|
|
||||||
## Further information
|
|
||||||
|
|
||||||
- [Contributing guidelines](CONTRIBUTING.md).
|
|
||||||
- [Changelog](CHANGELOG.md) – this one contains the most recent changes;
|
|
||||||
individual changelogs for specific versions can be found on
|
|
||||||
[Hackage](https://hackage.haskell.org/package/graphql).
|
|
||||||
|
|
||||||
## Contact
|
|
||||||
|
|
||||||
Suggestions, contributions and bug reports are welcome.
|
|
||||||
|
|
||||||
Should you have questions on usage, please open an issue and ask – this helps
|
|
||||||
to write useful documentation.
|
|
||||||
|
|
||||||
Feel free to contact on Slack in [#haskell on
|
|
||||||
GraphQL](https://graphql.slack.com/messages/haskell/). You can obtain an
|
|
||||||
invitation [here](https://graphql-slack.herokuapp.com/).
|
|
||||||
|
|
|
@ -1,152 +0,0 @@
|
||||||
---
|
|
||||||
title: GraphQL Haskell Tutorial
|
|
||||||
---
|
|
||||||
|
|
||||||
|
|
||||||
== Getting started ==
|
|
||||||
|
|
||||||
Welcome to GraphQL!
|
|
||||||
|
|
||||||
We have written a small tutorial to help you (and ourselves) understand the
|
|
||||||
graphql package.
|
|
||||||
|
|
||||||
Since this file is a literate haskell file, we start by importing some
|
|
||||||
dependencies.
|
|
||||||
|
|
||||||
> {-# LANGUAGE OverloadedStrings #-}
|
|
||||||
> module Main where
|
|
||||||
>
|
|
||||||
> import Control.Monad.IO.Class (liftIO)
|
|
||||||
> import Data.Aeson (encode)
|
|
||||||
> import Data.ByteString.Lazy.Char8 (putStrLn)
|
|
||||||
> import qualified Data.HashMap.Strict as HashMap
|
|
||||||
> import Data.Text (Text)
|
|
||||||
> import qualified Data.Text as Text
|
|
||||||
> import Data.Time (getCurrentTime)
|
|
||||||
>
|
|
||||||
> import Language.GraphQL
|
|
||||||
> import Language.GraphQL.Type
|
|
||||||
> import qualified Language.GraphQL.Type.Out as Out
|
|
||||||
>
|
|
||||||
> import Prelude hiding (putStrLn)
|
|
||||||
|
|
||||||
|
|
||||||
=== First example ===
|
|
||||||
|
|
||||||
Now, as our first example, we are going to look at the example from
|
|
||||||
[graphql.js](https://github.com/graphql/graphql-js).
|
|
||||||
|
|
||||||
First we build a GraphQL schema.
|
|
||||||
|
|
||||||
> schema1 :: Schema IO
|
|
||||||
> schema1 = Schema
|
|
||||||
> { query = queryType , mutation = Nothing , subscription = Nothing }
|
|
||||||
>
|
|
||||||
> queryType :: ObjectType IO
|
|
||||||
> queryType = ObjectType "Query" Nothing []
|
|
||||||
> $ HashMap.singleton "hello"
|
|
||||||
> $ ValueResolver helloField hello
|
|
||||||
>
|
|
||||||
> helloField :: Field IO
|
|
||||||
> helloField = Field Nothing (Out.NamedScalarType string) mempty
|
|
||||||
>
|
|
||||||
> hello :: Resolve IO
|
|
||||||
> hello = pure $ String "it's me"
|
|
||||||
|
|
||||||
This defines a simple schema with one type and one field, that resolves to a
|
|
||||||
fixed value.
|
|
||||||
|
|
||||||
Next we define our query.
|
|
||||||
|
|
||||||
> query1 :: Text
|
|
||||||
> query1 = "{ hello }"
|
|
||||||
|
|
||||||
To run the query, we call the `graphql` with the schema and the query.
|
|
||||||
|
|
||||||
> main1 :: IO ()
|
|
||||||
> main1 = graphql schema1 query1
|
|
||||||
> >>= either (const $ pure ()) (putStrLn . encode)
|
|
||||||
|
|
||||||
This runs the query by fetching the one field defined, returning
|
|
||||||
|
|
||||||
```{"data" : {"hello":"it's me"}}```
|
|
||||||
|
|
||||||
|
|
||||||
=== Monadic actions ===
|
|
||||||
|
|
||||||
For this example, we're going to be using time.
|
|
||||||
|
|
||||||
> schema2 :: Schema IO
|
|
||||||
> schema2 = Schema
|
|
||||||
> { query = queryType2, mutation = Nothing, subscription = Nothing }
|
|
||||||
>
|
|
||||||
> queryType2 :: ObjectType IO
|
|
||||||
> queryType2 = ObjectType "Query" Nothing []
|
|
||||||
> $ HashMap.singleton "time"
|
|
||||||
> $ ValueResolver timeField time
|
|
||||||
>
|
|
||||||
> timeField :: Field IO
|
|
||||||
> timeField = Field Nothing (Out.NamedScalarType string) mempty
|
|
||||||
>
|
|
||||||
> time :: Resolve IO
|
|
||||||
> time = do
|
|
||||||
> t <- liftIO getCurrentTime
|
|
||||||
> pure $ String $ Text.pack $ show t
|
|
||||||
|
|
||||||
This defines a simple schema with one type and one field, which resolves to the
|
|
||||||
current time.
|
|
||||||
|
|
||||||
Next we define our query.
|
|
||||||
|
|
||||||
> query2 :: Text
|
|
||||||
> query2 = "{ time }"
|
|
||||||
>
|
|
||||||
> main2 :: IO ()
|
|
||||||
> main2 = graphql schema2 query2
|
|
||||||
> >>= either (const $ pure ()) (putStrLn . encode)
|
|
||||||
|
|
||||||
This runs the query, returning the current time
|
|
||||||
|
|
||||||
```{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}```
|
|
||||||
|
|
||||||
|
|
||||||
=== Combining resolvers ===
|
|
||||||
|
|
||||||
Now that we have two resolvers, we can define a schema which uses them both.
|
|
||||||
|
|
||||||
> schema3 :: Schema IO
|
|
||||||
> schema3 = Schema
|
|
||||||
> { query = queryType3, mutation = Nothing, subscription = Nothing }
|
|
||||||
>
|
|
||||||
> queryType3 :: ObjectType IO
|
|
||||||
> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
|
|
||||||
> [ ("hello", ValueResolver helloField hello)
|
|
||||||
> , ("time", ValueResolver timeField time)
|
|
||||||
> ]
|
|
||||||
>
|
|
||||||
> query3 :: Text
|
|
||||||
> query3 = "query timeAndHello { time hello }"
|
|
||||||
>
|
|
||||||
> main3 :: IO ()
|
|
||||||
> main3 = graphql schema3 query3
|
|
||||||
> >>= either (const $ pure ()) (putStrLn . encode)
|
|
||||||
|
|
||||||
This queries for both time and hello, returning
|
|
||||||
|
|
||||||
```{ "data": {"hello":"it's me","time":"2016-03-08 23:29:11.62108 UTC"}}```
|
|
||||||
|
|
||||||
Notice that we can name our queries, as we did with `timeAndHello`. Since we
|
|
||||||
have only been using single queries, we can use the shorthand `{ time hello }`,
|
|
||||||
as we have been doing in the previous examples.
|
|
||||||
|
|
||||||
In GraphQL there can only be one operation per query.
|
|
||||||
|
|
||||||
|
|
||||||
== Further examples ==
|
|
||||||
|
|
||||||
More examples on queries and a more complex schema can be found in the test
|
|
||||||
directory, in the [Test.StarWars](../../tests/Test/StarWars) module. This
|
|
||||||
includes a more complex schema, and more complex queries.
|
|
||||||
|
|
||||||
> main :: IO ()
|
|
||||||
> main = main1 >> main2 >> main3
|
|
|
@ -1,37 +1,35 @@
|
||||||
cabal-version: 1.12
|
cabal-version: 2.2
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.33.0.
|
-- This file has been generated from package.yaml by hpack version 0.33.0.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 3ef060c57424074b84204bae61ee0a63e3470a7a060c45a977ff2bcbe4df8775
|
-- hash: c89b0164372b6e02e4f338d3865dd6bb9dfd1a4475f25d808450480d73f94f91
|
||||||
|
|
||||||
name: graphql
|
name: graphql
|
||||||
version: 0.10.0.0
|
version: 0.11.0.0
|
||||||
synopsis: Haskell GraphQL implementation
|
synopsis: Haskell GraphQL implementation
|
||||||
description: This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
|
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||||
category: Language
|
category: Language
|
||||||
homepage: https://github.com/caraus-ecms/graphql#readme
|
homepage: https://www.caraus.tech/projects/pub-graphql
|
||||||
bug-reports: https://github.com/caraus-ecms/graphql/issues
|
bug-reports: https://www.caraus.tech/projects/pub-graphql/issues
|
||||||
author: Danny Navarro <j@dannynavarro.net>,
|
author: Danny Navarro <j@dannynavarro.net>,
|
||||||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||||
maintainer: belka@caraus.de
|
maintainer: belka@caraus.de
|
||||||
copyright: (c) 2019-2020 Eugen Wissner,
|
copyright: (c) 2019-2020 Eugen Wissner,
|
||||||
(c) 2015-2017 J. Daniel Navarro
|
(c) 2015-2017 J. Daniel Navarro
|
||||||
license: BSD3
|
license: MPL-2.0 AND BSD-3-Clause
|
||||||
license-file: LICENSE
|
license-files: LICENSE,
|
||||||
|
LICENSE.MPL
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
extra-source-files:
|
extra-source-files:
|
||||||
CHANGELOG.md
|
CHANGELOG.md
|
||||||
CONTRIBUTING.md
|
|
||||||
LICENSE
|
|
||||||
README.md
|
README.md
|
||||||
docs/tutorial/tutorial.lhs
|
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
location: https://github.com/caraus-ecms/graphql
|
location: git://caraus.tech/pub/graphql.git
|
||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
|
@ -76,7 +74,7 @@ library
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
test-suite tasty
|
test-suite graphql-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
|
@ -91,9 +89,8 @@ test-suite tasty
|
||||||
Test.DirectiveSpec
|
Test.DirectiveSpec
|
||||||
Test.FragmentSpec
|
Test.FragmentSpec
|
||||||
Test.RootOperationSpec
|
Test.RootOperationSpec
|
||||||
Test.StarWars.Data
|
Paths_graphql
|
||||||
Test.StarWars.QuerySpec
|
autogen-modules:
|
||||||
Test.StarWars.Schema
|
|
||||||
Paths_graphql
|
Paths_graphql
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
tests
|
tests
|
||||||
|
|
29
package.yaml
29
package.yaml
|
@ -1,12 +1,15 @@
|
||||||
name: graphql
|
name: graphql
|
||||||
version: 0.10.0.0
|
version: 0.11.0.0
|
||||||
synopsis: Haskell GraphQL implementation
|
synopsis: Haskell GraphQL implementation
|
||||||
description:
|
description:
|
||||||
This package provides a rudimentary parser for the
|
Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||||
<https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
|
maintainer: belka@caraus.de
|
||||||
maintainer: belka@caraus.de
|
git: git://caraus.tech/pub/graphql.git
|
||||||
github: caraus-ecms/graphql
|
homepage: https://www.caraus.tech/projects/pub-graphql
|
||||||
category: Language
|
bug-reports: https://www.caraus.tech/projects/pub-graphql/issues
|
||||||
|
category: Language
|
||||||
|
license: MPL-2.0 AND BSD-3-Clause
|
||||||
|
|
||||||
copyright:
|
copyright:
|
||||||
- (c) 2019-2020 Eugen Wissner
|
- (c) 2019-2020 Eugen Wissner
|
||||||
- (c) 2015-2017 J. Daniel Navarro
|
- (c) 2015-2017 J. Daniel Navarro
|
||||||
|
@ -15,12 +18,12 @@ author:
|
||||||
- Matthías Páll Gissurarson <mpg@mpg.is>
|
- Matthías Páll Gissurarson <mpg@mpg.is>
|
||||||
- Sólrún Halla Einarsdóttir <she@mpg.is>
|
- Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||||
|
|
||||||
|
license-file:
|
||||||
|
- LICENSE
|
||||||
|
- LICENSE.MPL
|
||||||
extra-source-files:
|
extra-source-files:
|
||||||
- CHANGELOG.md
|
- CHANGELOG.md
|
||||||
- CONTRIBUTING.md
|
|
||||||
- LICENSE
|
|
||||||
- README.md
|
- README.md
|
||||||
- docs/tutorial/tutorial.lhs
|
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
- aeson
|
- aeson
|
||||||
|
@ -47,7 +50,7 @@ library:
|
||||||
- Language.GraphQL.Validate.Rules
|
- Language.GraphQL.Validate.Rules
|
||||||
|
|
||||||
tests:
|
tests:
|
||||||
tasty:
|
graphql-test:
|
||||||
main: Spec.hs
|
main: Spec.hs
|
||||||
source-dirs: tests
|
source-dirs: tests
|
||||||
ghc-options:
|
ghc-options:
|
||||||
|
@ -60,3 +63,5 @@ tests:
|
||||||
- hspec-megaparsec
|
- hspec-megaparsec
|
||||||
- QuickCheck
|
- QuickCheck
|
||||||
- raw-strings-qq
|
- raw-strings-qq
|
||||||
|
generated-other-modules:
|
||||||
|
- Paths_graphql
|
||||||
|
|
|
@ -11,13 +11,14 @@ import Control.Monad.Catch (MonadCatch)
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
import qualified Data.Aeson.Types as Aeson
|
import qualified Data.Aeson.Types as Aeson
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Data.Maybe (catMaybes)
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Language.GraphQL.AST
|
import Language.GraphQL.AST
|
||||||
import Language.GraphQL.Error
|
import Language.GraphQL.Error
|
||||||
import Language.GraphQL.Execute
|
import Language.GraphQL.Execute
|
||||||
import qualified Language.GraphQL.Validate as Validate
|
import qualified Language.GraphQL.Validate as Validate
|
||||||
import Language.GraphQL.Type.Schema
|
import Language.GraphQL.Type.Schema (Schema)
|
||||||
import Text.Megaparsec (parse)
|
import Text.Megaparsec (parse)
|
||||||
|
|
||||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||||
|
@ -55,24 +56,19 @@ graphqlSubs schema operationName variableValues document' =
|
||||||
[ ("data", data'')
|
[ ("data", data'')
|
||||||
, ("errors", Aeson.toJSON $ fromError <$> errors')
|
, ("errors", Aeson.toJSON $ fromError <$> errors')
|
||||||
]
|
]
|
||||||
fromError Error{ locations = [], ..} =
|
fromError Error{..} = Aeson.object $ catMaybes
|
||||||
Aeson.object [("message", Aeson.toJSON message)]
|
[ Just ("message", Aeson.toJSON message)
|
||||||
fromError Error{..} = Aeson.object
|
, toMaybe fromLocation "locations" locations
|
||||||
|
, toMaybe fromPath "path" path
|
||||||
|
]
|
||||||
|
fromValidationError Validate.Error{..} = Aeson.object
|
||||||
[ ("message", Aeson.toJSON message)
|
[ ("message", Aeson.toJSON message)
|
||||||
, ("locations", Aeson.listValue fromLocation locations)
|
, ("locations", Aeson.listValue fromLocation locations)
|
||||||
]
|
]
|
||||||
fromValidationError Validate.Error{..}
|
toMaybe _ _ [] = Nothing
|
||||||
| [] <- path = Aeson.object
|
toMaybe f key xs = Just (key, Aeson.listValue f xs)
|
||||||
[ ("message", Aeson.toJSON message)
|
fromPath (Segment segment) = Aeson.String segment
|
||||||
, ("locations", Aeson.listValue fromLocation locations)
|
fromPath (Index index) = Aeson.toJSON index
|
||||||
]
|
|
||||||
| otherwise = Aeson.object
|
|
||||||
[ ("message", Aeson.toJSON message)
|
|
||||||
, ("locations", Aeson.listValue fromLocation locations)
|
|
||||||
, ("path", Aeson.listValue fromPath path)
|
|
||||||
]
|
|
||||||
fromPath (Validate.Segment segment) = Aeson.String segment
|
|
||||||
fromPath (Validate.Index index) = Aeson.toJSON index
|
|
||||||
fromLocation Location{..} = Aeson.object
|
fromLocation Location{..} = Aeson.object
|
||||||
[ ("line", Aeson.toJSON line)
|
[ ("line", Aeson.toJSON line)
|
||||||
, ("column", Aeson.toJSON column)
|
, ("column", Aeson.toJSON column)
|
||||||
|
|
|
@ -2,6 +2,8 @@
|
||||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
|
{-# LANGUAGE 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.
|
-- This module describes locations in a document where directives can appear.
|
||||||
module Language.GraphQL.AST.DirectiveLocation
|
module Language.GraphQL.AST.DirectiveLocation
|
||||||
|
@ -16,7 +18,13 @@ module Language.GraphQL.AST.DirectiveLocation
|
||||||
data DirectiveLocation
|
data DirectiveLocation
|
||||||
= ExecutableDirectiveLocation ExecutableDirectiveLocation
|
= ExecutableDirectiveLocation ExecutableDirectiveLocation
|
||||||
| TypeSystemDirectiveLocation TypeSystemDirectiveLocation
|
| TypeSystemDirectiveLocation TypeSystemDirectiveLocation
|
||||||
deriving (Eq, Show)
|
deriving Eq
|
||||||
|
|
||||||
|
instance Show DirectiveLocation where
|
||||||
|
show (ExecutableDirectiveLocation directiveLocation) =
|
||||||
|
show directiveLocation
|
||||||
|
show (TypeSystemDirectiveLocation directiveLocation) =
|
||||||
|
show directiveLocation
|
||||||
|
|
||||||
-- | Where directives can appear in an executable definition, like a query.
|
-- | Where directives can appear in an executable definition, like a query.
|
||||||
data ExecutableDirectiveLocation
|
data ExecutableDirectiveLocation
|
||||||
|
@ -27,7 +35,16 @@ data ExecutableDirectiveLocation
|
||||||
| FragmentDefinition
|
| FragmentDefinition
|
||||||
| FragmentSpread
|
| FragmentSpread
|
||||||
| InlineFragment
|
| InlineFragment
|
||||||
deriving (Eq, Show)
|
deriving Eq
|
||||||
|
|
||||||
|
instance Show ExecutableDirectiveLocation where
|
||||||
|
show Query = "QUERY"
|
||||||
|
show Mutation = "MUTATION"
|
||||||
|
show Subscription = "SUBSCRIPTION"
|
||||||
|
show Field = "FIELD"
|
||||||
|
show FragmentDefinition = "FRAGMENT_DEFINITION"
|
||||||
|
show FragmentSpread = "FRAGMENT_SPREAD"
|
||||||
|
show InlineFragment = "INLINE_FRAGMENT"
|
||||||
|
|
||||||
-- | Where directives can appear in a type system definition.
|
-- | Where directives can appear in a type system definition.
|
||||||
data TypeSystemDirectiveLocation
|
data TypeSystemDirectiveLocation
|
||||||
|
@ -42,4 +59,17 @@ data TypeSystemDirectiveLocation
|
||||||
| EnumValue
|
| EnumValue
|
||||||
| InputObject
|
| InputObject
|
||||||
| InputFieldDefinition
|
| InputFieldDefinition
|
||||||
deriving (Eq, Show)
|
deriving Eq
|
||||||
|
|
||||||
|
instance Show TypeSystemDirectiveLocation where
|
||||||
|
show Schema = "SCHEMA"
|
||||||
|
show Scalar = "SCALAR"
|
||||||
|
show Object = "OBJECT"
|
||||||
|
show FieldDefinition = "FIELD_DEFINITION"
|
||||||
|
show ArgumentDefinition = "ARGUMENT_DEFINITION"
|
||||||
|
show Interface = "INTERFACE"
|
||||||
|
show Union = "UNION"
|
||||||
|
show Enum = "ENUM"
|
||||||
|
show EnumValue = "ENUM_VALUE"
|
||||||
|
show InputObject = "INPUT_OBJECT"
|
||||||
|
show InputFieldDefinition = "INPUT_FIELD_DEFINITION"
|
||||||
|
|
|
@ -1,12 +1,15 @@
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE Safe #-}
|
||||||
|
|
||||||
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
|
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
|
||||||
-- follows closely the structure given in the specification. Please refer to
|
-- follows closely the structure given in the specification. Please refer to
|
||||||
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
|
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
|
||||||
-- for more information.
|
-- for more information.
|
||||||
module Language.GraphQL.AST.Document
|
module Language.GraphQL.AST.Document
|
||||||
( Alias
|
( Argument(..)
|
||||||
, Argument(..)
|
|
||||||
, ArgumentsDefinition(..)
|
, ArgumentsDefinition(..)
|
||||||
, ConstValue(..)
|
, ConstValue(..)
|
||||||
, Definition(..)
|
, Definition(..)
|
||||||
|
@ -15,13 +18,17 @@ module Language.GraphQL.AST.Document
|
||||||
, Document
|
, Document
|
||||||
, EnumValueDefinition(..)
|
, EnumValueDefinition(..)
|
||||||
, ExecutableDefinition(..)
|
, ExecutableDefinition(..)
|
||||||
|
, Field(..)
|
||||||
, FieldDefinition(..)
|
, FieldDefinition(..)
|
||||||
, FragmentDefinition(..)
|
, FragmentDefinition(..)
|
||||||
|
, FragmentSpread(..)
|
||||||
, ImplementsInterfaces(..)
|
, ImplementsInterfaces(..)
|
||||||
|
, InlineFragment(..)
|
||||||
, InputValueDefinition(..)
|
, InputValueDefinition(..)
|
||||||
, Location(..)
|
, Location(..)
|
||||||
, Name
|
, Name
|
||||||
, NamedType
|
, NamedType
|
||||||
|
, Node(..)
|
||||||
, NonNullType(..)
|
, NonNullType(..)
|
||||||
, ObjectField(..)
|
, ObjectField(..)
|
||||||
, OperationDefinition(..)
|
, OperationDefinition(..)
|
||||||
|
@ -47,7 +54,7 @@ import Data.Int (Int32)
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import Language.GraphQL.AST.DirectiveLocation
|
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
|
||||||
|
|
||||||
-- * Language
|
-- * Language
|
||||||
|
|
||||||
|
@ -68,6 +75,15 @@ instance Ord Location where
|
||||||
| thisLine > thatLine = GT
|
| thisLine > thatLine = GT
|
||||||
| otherwise = compare thisColumn thatColumn
|
| otherwise = compare thisColumn thatColumn
|
||||||
|
|
||||||
|
-- | Contains some tree node with a location.
|
||||||
|
data Node a = Node
|
||||||
|
{ node :: a
|
||||||
|
, location :: Location
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance Functor Node where
|
||||||
|
fmap f Node{..} = Node (f node) location
|
||||||
|
|
||||||
-- ** Document
|
-- ** Document
|
||||||
|
|
||||||
-- | GraphQL document.
|
-- | GraphQL document.
|
||||||
|
@ -116,10 +132,15 @@ type SelectionSet = NonEmpty Selection
|
||||||
-- | Field selection.
|
-- | Field selection.
|
||||||
type SelectionSetOpt = [Selection]
|
type SelectionSetOpt = [Selection]
|
||||||
|
|
||||||
-- | Selection is a single entry in a selection set. It can be a single field,
|
-- | Selection is a single entry in a selection set. It can be a single 'Field',
|
||||||
-- fragment spread or inline fragment.
|
-- 'FragmentSpread' or an 'InlineFragment'.
|
||||||
--
|
data Selection
|
||||||
-- The only required property of a field is its name. Optionally it can also
|
= FieldSelection Field
|
||||||
|
| FragmentSpreadSelection FragmentSpread
|
||||||
|
| InlineFragmentSelection InlineFragment
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- | The only required property of a field is its name. Optionally it can also
|
||||||
-- have an alias, arguments, directives and a list of subfields.
|
-- have an alias, arguments, directives and a list of subfields.
|
||||||
--
|
--
|
||||||
-- In the following query "user" is a field with two subfields, "id" and "name":
|
-- In the following query "user" is a field with two subfields, "id" and "name":
|
||||||
|
@ -132,8 +153,27 @@ type SelectionSetOpt = [Selection]
|
||||||
-- }
|
-- }
|
||||||
-- }
|
-- }
|
||||||
-- @
|
-- @
|
||||||
|
data Field =
|
||||||
|
Field (Maybe Name) Name [Argument] [Directive] SelectionSetOpt Location
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- | Inline fragments don't have any name and the type condition ("on UserType")
|
||||||
|
-- is optional.
|
||||||
--
|
--
|
||||||
-- A fragment spread refers to a fragment defined outside the operation and is
|
-- @
|
||||||
|
-- {
|
||||||
|
-- user {
|
||||||
|
-- ... on UserType {
|
||||||
|
-- id
|
||||||
|
-- name
|
||||||
|
-- }
|
||||||
|
-- }
|
||||||
|
-- @
|
||||||
|
data InlineFragment = InlineFragment
|
||||||
|
(Maybe TypeCondition) [Directive] SelectionSet Location
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- | A fragment spread refers to a fragment defined outside the operation and is
|
||||||
-- expanded at the execution time.
|
-- expanded at the execution time.
|
||||||
--
|
--
|
||||||
-- @
|
-- @
|
||||||
|
@ -148,23 +188,7 @@ type SelectionSetOpt = [Selection]
|
||||||
-- name
|
-- name
|
||||||
-- }
|
-- }
|
||||||
-- @
|
-- @
|
||||||
--
|
data FragmentSpread = FragmentSpread Name [Directive] Location
|
||||||
-- Inline fragments are similar but they don't have any name and the type
|
|
||||||
-- condition ("on UserType") is optional.
|
|
||||||
--
|
|
||||||
-- @
|
|
||||||
-- {
|
|
||||||
-- user {
|
|
||||||
-- ... on UserType {
|
|
||||||
-- id
|
|
||||||
-- name
|
|
||||||
-- }
|
|
||||||
-- }
|
|
||||||
-- @
|
|
||||||
data Selection
|
|
||||||
= Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
|
|
||||||
| FragmentSpread Name [Directive]
|
|
||||||
| InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
|
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- ** Arguments
|
-- ** Arguments
|
||||||
|
@ -180,23 +204,7 @@ data Selection
|
||||||
-- @
|
-- @
|
||||||
--
|
--
|
||||||
-- Here "id" is an argument for the field "user" and its value is 4.
|
-- Here "id" is an argument for the field "user" and its value is 4.
|
||||||
data Argument = Argument Name Value deriving (Eq,Show)
|
data Argument = Argument Name (Node Value) Location deriving (Eq, Show)
|
||||||
|
|
||||||
-- ** Field Alias
|
|
||||||
|
|
||||||
-- | Alternative field name.
|
|
||||||
--
|
|
||||||
-- @
|
|
||||||
-- {
|
|
||||||
-- smallPic: profilePic(size: 64)
|
|
||||||
-- bigPic: profilePic(size: 1024)
|
|
||||||
-- }
|
|
||||||
-- @
|
|
||||||
--
|
|
||||||
-- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
|
|
||||||
-- used to distinquish between profile pictures with different arguments
|
|
||||||
-- (sizes).
|
|
||||||
type Alias = Name
|
|
||||||
|
|
||||||
-- ** Fragments
|
-- ** Fragments
|
||||||
|
|
||||||
|
@ -238,8 +246,11 @@ data ConstValue
|
||||||
-- | Key-value pair.
|
-- | Key-value pair.
|
||||||
--
|
--
|
||||||
-- A list of 'ObjectField's represents a GraphQL object type.
|
-- A list of 'ObjectField's represents a GraphQL object type.
|
||||||
data ObjectField a = ObjectField Name a
|
data ObjectField a = ObjectField
|
||||||
deriving (Eq, Show)
|
{ name :: Name
|
||||||
|
, value :: Node a
|
||||||
|
, location :: Location
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
-- ** Variables
|
-- ** Variables
|
||||||
|
|
||||||
|
@ -259,7 +270,8 @@ data ObjectField a = ObjectField Name a
|
||||||
--
|
--
|
||||||
-- Variables are usually passed along with the query, but not in the query
|
-- Variables are usually passed along with the query, but not in the query
|
||||||
-- itself. They make queries reusable.
|
-- itself. They make queries reusable.
|
||||||
data VariableDefinition = VariableDefinition Name Type (Maybe ConstValue)
|
data VariableDefinition =
|
||||||
|
VariableDefinition Name Type (Maybe (Node ConstValue)) Location
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- ** Type References
|
-- ** Type References
|
||||||
|
@ -286,7 +298,7 @@ data NonNullType
|
||||||
--
|
--
|
||||||
-- Directives begin with "@", can accept arguments, and can be applied to the
|
-- Directives begin with "@", can accept arguments, and can be applied to the
|
||||||
-- most GraphQL elements, providing additional information.
|
-- most GraphQL elements, providing additional information.
|
||||||
data Directive = Directive Name [Argument] deriving (Eq, Show)
|
data Directive = Directive Name [Argument] Location deriving (Eq, Show)
|
||||||
|
|
||||||
-- * Type System
|
-- * Type System
|
||||||
|
|
||||||
|
@ -485,8 +497,8 @@ instance Monoid ArgumentsDefinition where
|
||||||
-- @
|
-- @
|
||||||
--
|
--
|
||||||
-- The input type "Point2D" contains two value definitions: "x" and "y".
|
-- The input type "Point2D" contains two value definitions: "x" and "y".
|
||||||
data InputValueDefinition
|
data InputValueDefinition = InputValueDefinition
|
||||||
= InputValueDefinition Description Name Type (Maybe ConstValue) [Directive]
|
Description Name Type (Maybe (Node ConstValue)) [Directive]
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- ** Unions
|
-- ** Unions
|
||||||
|
|
|
@ -1,6 +1,8 @@
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE Safe #-}
|
||||||
|
|
||||||
-- | This module defines a minifier and a printer for the @GraphQL@ language.
|
-- | This module defines a minifier and a printer for the @GraphQL@ language.
|
||||||
module Language.GraphQL.AST.Encoder
|
module Language.GraphQL.AST.Encoder
|
||||||
|
@ -25,7 +27,7 @@ import Data.Text.Lazy.Builder (Builder)
|
||||||
import qualified Data.Text.Lazy.Builder as Builder
|
import qualified Data.Text.Lazy.Builder as Builder
|
||||||
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
|
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
|
||||||
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
||||||
import Language.GraphQL.AST.Document
|
import qualified Language.GraphQL.AST.Document as Full
|
||||||
|
|
||||||
-- | Instructs the encoder whether the GraphQL document should be minified or
|
-- | Instructs the encoder whether the GraphQL document should be minified or
|
||||||
-- pretty printed.
|
-- pretty printed.
|
||||||
|
@ -44,77 +46,78 @@ minified :: Formatter
|
||||||
minified = Minified
|
minified = Minified
|
||||||
|
|
||||||
-- | Converts a Document' into a string.
|
-- | Converts a Document' into a string.
|
||||||
document :: Formatter -> Document -> Lazy.Text
|
document :: Formatter -> Full.Document -> Lazy.Text
|
||||||
document formatter defs
|
document formatter defs
|
||||||
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
|
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
|
||||||
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
|
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
|
||||||
where
|
where
|
||||||
encodeDocument = foldr executableDefinition [] defs
|
encodeDocument = foldr executableDefinition [] defs
|
||||||
executableDefinition (ExecutableDefinition executableDefinition') acc =
|
executableDefinition (Full.ExecutableDefinition executableDefinition') acc =
|
||||||
definition formatter executableDefinition' : acc
|
definition formatter executableDefinition' : acc
|
||||||
executableDefinition _ acc = acc
|
executableDefinition _ acc = acc
|
||||||
|
|
||||||
-- | Converts a t'ExecutableDefinition' into a string.
|
-- | Converts a t'Full.ExecutableDefinition' into a string.
|
||||||
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
|
definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
|
||||||
definition formatter x
|
definition formatter x
|
||||||
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
|
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
|
||||||
| Minified <- formatter = encodeDefinition x
|
| Minified <- formatter = encodeDefinition x
|
||||||
where
|
where
|
||||||
encodeDefinition (DefinitionOperation operation)
|
encodeDefinition (Full.DefinitionOperation operation)
|
||||||
= operationDefinition formatter operation
|
= operationDefinition formatter operation
|
||||||
encodeDefinition (DefinitionFragment fragment)
|
encodeDefinition (Full.DefinitionFragment fragment)
|
||||||
= fragmentDefinition formatter fragment
|
= fragmentDefinition formatter fragment
|
||||||
|
|
||||||
-- | Converts a 'OperationDefinition into a string.
|
-- | Converts a 'Full.OperationDefinition into a string.
|
||||||
operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
|
operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
|
||||||
operationDefinition formatter = \case
|
operationDefinition formatter = \case
|
||||||
SelectionSet sels _ -> selectionSet formatter sels
|
Full.SelectionSet sels _ -> selectionSet formatter sels
|
||||||
OperationDefinition Query name vars dirs sels _ ->
|
Full.OperationDefinition Full.Query name vars dirs sels _ ->
|
||||||
"query " <> node formatter name vars dirs sels
|
"query " <> root name vars dirs sels
|
||||||
OperationDefinition Mutation name vars dirs sels _ ->
|
Full.OperationDefinition Full.Mutation name vars dirs sels _ ->
|
||||||
"mutation " <> node formatter name vars dirs sels
|
"mutation " <> root name vars dirs sels
|
||||||
OperationDefinition Subscription name vars dirs sels _ ->
|
Full.OperationDefinition Full.Subscription name vars dirs sels _ ->
|
||||||
"subscription " <> node formatter name vars dirs sels
|
"subscription " <> root name vars dirs sels
|
||||||
|
where
|
||||||
|
-- | Converts a Query or Mutation into a string.
|
||||||
|
root :: Maybe Full.Name ->
|
||||||
|
[Full.VariableDefinition] ->
|
||||||
|
[Full.Directive] ->
|
||||||
|
Full.SelectionSet ->
|
||||||
|
Lazy.Text
|
||||||
|
root name vars dirs sels
|
||||||
|
= Lazy.Text.fromStrict (fold name)
|
||||||
|
<> optempty (variableDefinitions formatter) vars
|
||||||
|
<> optempty (directives formatter) dirs
|
||||||
|
<> eitherFormat formatter " " mempty
|
||||||
|
<> selectionSet formatter sels
|
||||||
|
|
||||||
-- | Converts a Query or Mutation into a string.
|
variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
|
||||||
node :: Formatter ->
|
|
||||||
Maybe Name ->
|
|
||||||
[VariableDefinition] ->
|
|
||||||
[Directive] ->
|
|
||||||
SelectionSet ->
|
|
||||||
Lazy.Text
|
|
||||||
node formatter name vars dirs sels
|
|
||||||
= Lazy.Text.fromStrict (fold name)
|
|
||||||
<> optempty (variableDefinitions formatter) vars
|
|
||||||
<> optempty (directives formatter) dirs
|
|
||||||
<> eitherFormat formatter " " mempty
|
|
||||||
<> selectionSet formatter sels
|
|
||||||
|
|
||||||
variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text
|
|
||||||
variableDefinitions formatter
|
variableDefinitions formatter
|
||||||
= parensCommas formatter $ variableDefinition formatter
|
= parensCommas formatter $ variableDefinition formatter
|
||||||
|
|
||||||
variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text
|
variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
|
||||||
variableDefinition formatter (VariableDefinition var ty defaultValue')
|
variableDefinition formatter variableDefinition' =
|
||||||
= variable var
|
let Full.VariableDefinition variableName variableType defaultValue' _ =
|
||||||
|
variableDefinition'
|
||||||
|
in variable variableName
|
||||||
<> eitherFormat formatter ": " ":"
|
<> eitherFormat formatter ": " ":"
|
||||||
<> type' ty
|
<> type' variableType
|
||||||
<> maybe mempty (defaultValue formatter) defaultValue'
|
<> maybe mempty (defaultValue formatter) (Full.node <$> defaultValue')
|
||||||
|
|
||||||
defaultValue :: Formatter -> ConstValue -> Lazy.Text
|
defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text
|
||||||
defaultValue formatter val
|
defaultValue formatter val
|
||||||
= eitherFormat formatter " = " "="
|
= eitherFormat formatter " = " "="
|
||||||
<> value formatter (fromConstValue val)
|
<> value formatter (fromConstValue val)
|
||||||
|
|
||||||
variable :: Name -> Lazy.Text
|
variable :: Full.Name -> Lazy.Text
|
||||||
variable var = "$" <> Lazy.Text.fromStrict var
|
variable var = "$" <> Lazy.Text.fromStrict var
|
||||||
|
|
||||||
selectionSet :: Formatter -> SelectionSet -> Lazy.Text
|
selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
|
||||||
selectionSet formatter
|
selectionSet formatter
|
||||||
= bracesList formatter (selection formatter)
|
= bracesList formatter (selection formatter)
|
||||||
. NonEmpty.toList
|
. NonEmpty.toList
|
||||||
|
|
||||||
selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text
|
selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
|
||||||
selectionSetOpt formatter = bracesList formatter $ selection formatter
|
selectionSetOpt formatter = bracesList formatter $ selection formatter
|
||||||
|
|
||||||
indentSymbol :: Lazy.Text
|
indentSymbol :: Lazy.Text
|
||||||
|
@ -123,15 +126,15 @@ indentSymbol = " "
|
||||||
indent :: (Integral a) => a -> Lazy.Text
|
indent :: (Integral a) => a -> Lazy.Text
|
||||||
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
|
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
|
||||||
|
|
||||||
selection :: Formatter -> Selection -> Lazy.Text
|
selection :: Formatter -> Full.Selection -> Lazy.Text
|
||||||
selection formatter = Lazy.Text.append indent' . encodeSelection
|
selection formatter = Lazy.Text.append indent' . encodeSelection
|
||||||
where
|
where
|
||||||
encodeSelection (Field alias name args directives' selections) =
|
encodeSelection (Full.FieldSelection fieldSelection) =
|
||||||
field incrementIndent alias name args directives' selections
|
field incrementIndent fieldSelection
|
||||||
encodeSelection (InlineFragment typeCondition directives' selections) =
|
encodeSelection (Full.InlineFragmentSelection fragmentSelection) =
|
||||||
inlineFragment incrementIndent typeCondition directives' selections
|
inlineFragment incrementIndent fragmentSelection
|
||||||
encodeSelection (FragmentSpread name directives') =
|
encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =
|
||||||
fragmentSpread incrementIndent name directives'
|
fragmentSpread incrementIndent fragmentSelection
|
||||||
incrementIndent
|
incrementIndent
|
||||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||||
| otherwise = Minified
|
| otherwise = Minified
|
||||||
|
@ -142,15 +145,9 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
|
||||||
colon :: Formatter -> Lazy.Text
|
colon :: Formatter -> Lazy.Text
|
||||||
colon formatter = eitherFormat formatter ": " ":"
|
colon formatter = eitherFormat formatter ": " ":"
|
||||||
|
|
||||||
-- | Converts Field into a string
|
-- | Converts Field into a string.
|
||||||
field :: Formatter ->
|
field :: Formatter -> Full.Field -> Lazy.Text
|
||||||
Maybe Name ->
|
field formatter (Full.Field alias name args dirs set _)
|
||||||
Name ->
|
|
||||||
[Argument] ->
|
|
||||||
[Directive] ->
|
|
||||||
[Selection] ->
|
|
||||||
Lazy.Text
|
|
||||||
field formatter alias name args dirs set
|
|
||||||
= optempty prependAlias (fold alias)
|
= optempty prependAlias (fold alias)
|
||||||
<> Lazy.Text.fromStrict name
|
<> Lazy.Text.fromStrict name
|
||||||
<> optempty (arguments formatter) args
|
<> optempty (arguments formatter) args
|
||||||
|
@ -161,36 +158,32 @@ field formatter alias name args dirs set
|
||||||
selectionSetOpt' = (eitherFormat formatter " " "" <>)
|
selectionSetOpt' = (eitherFormat formatter " " "" <>)
|
||||||
. selectionSetOpt formatter
|
. selectionSetOpt formatter
|
||||||
|
|
||||||
arguments :: Formatter -> [Argument] -> Lazy.Text
|
arguments :: Formatter -> [Full.Argument] -> Lazy.Text
|
||||||
arguments formatter = parensCommas formatter $ argument formatter
|
arguments formatter = parensCommas formatter $ argument formatter
|
||||||
|
|
||||||
argument :: Formatter -> Argument -> Lazy.Text
|
argument :: Formatter -> Full.Argument -> Lazy.Text
|
||||||
argument formatter (Argument name value')
|
argument formatter (Full.Argument name value' _)
|
||||||
= Lazy.Text.fromStrict name
|
= Lazy.Text.fromStrict name
|
||||||
<> colon formatter
|
<> colon formatter
|
||||||
<> value formatter value'
|
<> value formatter (Full.node value')
|
||||||
|
|
||||||
-- * Fragments
|
-- * Fragments
|
||||||
|
|
||||||
fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
|
fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
|
||||||
fragmentSpread formatter name directives'
|
fragmentSpread formatter (Full.FragmentSpread name directives' _)
|
||||||
= "..." <> Lazy.Text.fromStrict name
|
= "..." <> Lazy.Text.fromStrict name
|
||||||
<> optempty (directives formatter) directives'
|
<> optempty (directives formatter) directives'
|
||||||
|
|
||||||
inlineFragment ::
|
inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
|
||||||
Formatter ->
|
inlineFragment formatter (Full.InlineFragment typeCondition directives' selections _)
|
||||||
Maybe TypeCondition ->
|
= "... on "
|
||||||
[Directive] ->
|
<> Lazy.Text.fromStrict (fold typeCondition)
|
||||||
SelectionSet ->
|
<> directives formatter directives'
|
||||||
Lazy.Text
|
|
||||||
inlineFragment formatter tc dirs sels = "... on "
|
|
||||||
<> Lazy.Text.fromStrict (fold tc)
|
|
||||||
<> directives formatter dirs
|
|
||||||
<> eitherFormat formatter " " mempty
|
<> eitherFormat formatter " " mempty
|
||||||
<> selectionSet formatter sels
|
<> selectionSet formatter selections
|
||||||
|
|
||||||
fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
|
fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
|
||||||
fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
|
fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels _)
|
||||||
= "fragment " <> Lazy.Text.fromStrict name
|
= "fragment " <> Lazy.Text.fromStrict name
|
||||||
<> " on " <> Lazy.Text.fromStrict tc
|
<> " on " <> Lazy.Text.fromStrict tc
|
||||||
<> optempty (directives formatter) dirs
|
<> optempty (directives formatter) dirs
|
||||||
|
@ -199,39 +192,39 @@ fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
|
||||||
|
|
||||||
-- * Miscellaneous
|
-- * Miscellaneous
|
||||||
|
|
||||||
-- | Converts a 'Directive' into a string.
|
-- | Converts a 'Full.Directive' into a string.
|
||||||
directive :: Formatter -> Directive -> Lazy.Text
|
directive :: Formatter -> Full.Directive -> Lazy.Text
|
||||||
directive formatter (Directive name args)
|
directive formatter (Full.Directive name args _)
|
||||||
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
|
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
|
||||||
|
|
||||||
directives :: Formatter -> [Directive] -> Lazy.Text
|
directives :: Formatter -> [Full.Directive] -> Lazy.Text
|
||||||
directives Minified = spaces (directive Minified)
|
directives Minified = spaces (directive Minified)
|
||||||
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
|
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
|
||||||
|
|
||||||
-- | Converts a 'Value' into a string.
|
-- | Converts a 'Full.Value' into a string.
|
||||||
value :: Formatter -> Value -> Lazy.Text
|
value :: Formatter -> Full.Value -> Lazy.Text
|
||||||
value _ (Variable x) = variable x
|
value _ (Full.Variable x) = variable x
|
||||||
value _ (Int x) = Builder.toLazyText $ decimal x
|
value _ (Full.Int x) = Builder.toLazyText $ decimal x
|
||||||
value _ (Float x) = Builder.toLazyText $ realFloat x
|
value _ (Full.Float x) = Builder.toLazyText $ realFloat x
|
||||||
value _ (Boolean x) = booleanValue x
|
value _ (Full.Boolean x) = booleanValue x
|
||||||
value _ Null = "null"
|
value _ Full.Null = "null"
|
||||||
value formatter (String string) = stringValue formatter string
|
value formatter (Full.String string) = stringValue formatter string
|
||||||
value _ (Enum x) = Lazy.Text.fromStrict x
|
value _ (Full.Enum x) = Lazy.Text.fromStrict x
|
||||||
value formatter (List x) = listValue formatter x
|
value formatter (Full.List x) = listValue formatter x
|
||||||
value formatter (Object x) = objectValue formatter x
|
value formatter (Full.Object x) = objectValue formatter x
|
||||||
|
|
||||||
fromConstValue :: ConstValue -> Value
|
fromConstValue :: Full.ConstValue -> Full.Value
|
||||||
fromConstValue (ConstInt x) = Int x
|
fromConstValue (Full.ConstInt x) = Full.Int x
|
||||||
fromConstValue (ConstFloat x) = Float x
|
fromConstValue (Full.ConstFloat x) = Full.Float x
|
||||||
fromConstValue (ConstBoolean x) = Boolean x
|
fromConstValue (Full.ConstBoolean x) = Full.Boolean x
|
||||||
fromConstValue ConstNull = Null
|
fromConstValue Full.ConstNull = Full.Null
|
||||||
fromConstValue (ConstString string) = String string
|
fromConstValue (Full.ConstString string) = Full.String string
|
||||||
fromConstValue (ConstEnum x) = Enum x
|
fromConstValue (Full.ConstEnum x) = Full.Enum x
|
||||||
fromConstValue (ConstList x) = List $ fromConstValue <$> x
|
fromConstValue (Full.ConstList x) = Full.List $ fromConstValue <$> x
|
||||||
fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x
|
fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x
|
||||||
where
|
where
|
||||||
fromConstObjectField (ObjectField key value') =
|
fromConstObjectField Full.ObjectField{value = value', ..} =
|
||||||
ObjectField key $ fromConstValue value'
|
Full.ObjectField name (fromConstValue <$> value') location
|
||||||
|
|
||||||
booleanValue :: Bool -> Lazy.Text
|
booleanValue :: Bool -> Lazy.Text
|
||||||
booleanValue True = "true"
|
booleanValue True = "true"
|
||||||
|
@ -288,10 +281,10 @@ escape char'
|
||||||
where
|
where
|
||||||
unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
|
unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
|
||||||
|
|
||||||
listValue :: Formatter -> [Value] -> Lazy.Text
|
listValue :: Formatter -> [Full.Value] -> Lazy.Text
|
||||||
listValue formatter = bracketsCommas formatter $ value formatter
|
listValue formatter = bracketsCommas formatter $ value formatter
|
||||||
|
|
||||||
objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text
|
objectValue :: Formatter -> [Full.ObjectField Full.Value] -> Lazy.Text
|
||||||
objectValue formatter = intercalate $ objectField formatter
|
objectValue formatter = intercalate $ objectField formatter
|
||||||
where
|
where
|
||||||
intercalate f
|
intercalate f
|
||||||
|
@ -299,22 +292,22 @@ objectValue formatter = intercalate $ objectField formatter
|
||||||
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
|
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
|
||||||
. fmap f
|
. fmap f
|
||||||
|
|
||||||
objectField :: Formatter -> ObjectField Value -> Lazy.Text
|
objectField :: Formatter -> Full.ObjectField Full.Value -> Lazy.Text
|
||||||
objectField formatter (ObjectField name value') =
|
objectField formatter (Full.ObjectField name (Full.Node value' _) _) =
|
||||||
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
|
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
|
||||||
|
|
||||||
-- | Converts a 'Type' a type into a string.
|
-- | Converts a 'Full.Type' a type into a string.
|
||||||
type' :: Type -> Lazy.Text
|
type' :: Full.Type -> Lazy.Text
|
||||||
type' (TypeNamed x) = Lazy.Text.fromStrict x
|
type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
|
||||||
type' (TypeList x) = listType x
|
type' (Full.TypeList x) = listType x
|
||||||
type' (TypeNonNull x) = nonNullType x
|
type' (Full.TypeNonNull x) = nonNullType x
|
||||||
|
|
||||||
listType :: Type -> Lazy.Text
|
listType :: Full.Type -> Lazy.Text
|
||||||
listType x = brackets (type' x)
|
listType x = brackets (type' x)
|
||||||
|
|
||||||
nonNullType :: NonNullType -> Lazy.Text
|
nonNullType :: Full.NonNullType -> Lazy.Text
|
||||||
nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
||||||
nonNullType (NonNullTypeList x) = listType x <> "!"
|
nonNullType (Full.NonNullTypeList x) = listType x <> "!"
|
||||||
|
|
||||||
-- * Internal
|
-- * Internal
|
||||||
|
|
||||||
|
|
|
@ -92,16 +92,16 @@ dollar :: Parser T.Text
|
||||||
dollar = symbol "$"
|
dollar = symbol "$"
|
||||||
|
|
||||||
-- | Parser for "@".
|
-- | Parser for "@".
|
||||||
at :: Parser Text
|
at :: Parser ()
|
||||||
at = symbol "@"
|
at = symbol "@" >> pure ()
|
||||||
|
|
||||||
-- | Parser for "&".
|
-- | Parser for "&".
|
||||||
amp :: Parser T.Text
|
amp :: Parser T.Text
|
||||||
amp = symbol "&"
|
amp = symbol "&"
|
||||||
|
|
||||||
-- | Parser for ":".
|
-- | Parser for ":".
|
||||||
colon :: Parser T.Text
|
colon :: Parser ()
|
||||||
colon = symbol ":"
|
colon = symbol ":" >> pure ()
|
||||||
|
|
||||||
-- | Parser for "=".
|
-- | Parser for "=".
|
||||||
equals :: Parser T.Text
|
equals :: Parser T.Text
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
@ -18,7 +19,7 @@ import Language.GraphQL.AST.DirectiveLocation
|
||||||
, ExecutableDirectiveLocation
|
, ExecutableDirectiveLocation
|
||||||
, TypeSystemDirectiveLocation
|
, TypeSystemDirectiveLocation
|
||||||
)
|
)
|
||||||
import Language.GraphQL.AST.Document
|
import qualified Language.GraphQL.AST.Document as Full
|
||||||
import Language.GraphQL.AST.Lexer
|
import Language.GraphQL.AST.Lexer
|
||||||
import Text.Megaparsec
|
import Text.Megaparsec
|
||||||
( MonadParsec(..)
|
( MonadParsec(..)
|
||||||
|
@ -32,13 +33,13 @@ import Text.Megaparsec
|
||||||
)
|
)
|
||||||
|
|
||||||
-- | Parser for the GraphQL documents.
|
-- | Parser for the GraphQL documents.
|
||||||
document :: Parser Document
|
document :: Parser Full.Document
|
||||||
document = unicodeBOM
|
document = unicodeBOM
|
||||||
*> spaceConsumer
|
*> spaceConsumer
|
||||||
*> lexeme (NonEmpty.some definition)
|
*> lexeme (NonEmpty.some definition)
|
||||||
|
|
||||||
definition :: Parser Definition
|
definition :: Parser Full.Definition
|
||||||
definition = ExecutableDefinition <$> executableDefinition
|
definition = Full.ExecutableDefinition <$> executableDefinition
|
||||||
<|> typeSystemDefinition'
|
<|> typeSystemDefinition'
|
||||||
<|> typeSystemExtension'
|
<|> typeSystemExtension'
|
||||||
<?> "Definition"
|
<?> "Definition"
|
||||||
|
@ -46,41 +47,41 @@ definition = ExecutableDefinition <$> executableDefinition
|
||||||
typeSystemDefinition' = do
|
typeSystemDefinition' = do
|
||||||
location <- getLocation
|
location <- getLocation
|
||||||
definition' <- typeSystemDefinition
|
definition' <- typeSystemDefinition
|
||||||
pure $ TypeSystemDefinition definition' location
|
pure $ Full.TypeSystemDefinition definition' location
|
||||||
typeSystemExtension' = do
|
typeSystemExtension' = do
|
||||||
location <- getLocation
|
location <- getLocation
|
||||||
definition' <- typeSystemExtension
|
definition' <- typeSystemExtension
|
||||||
pure $ TypeSystemExtension definition' location
|
pure $ Full.TypeSystemExtension definition' location
|
||||||
|
|
||||||
getLocation :: Parser Location
|
getLocation :: Parser Full.Location
|
||||||
getLocation = fromSourcePosition <$> getSourcePos
|
getLocation = fromSourcePosition <$> getSourcePos
|
||||||
where
|
where
|
||||||
fromSourcePosition SourcePos{..} =
|
fromSourcePosition SourcePos{..} =
|
||||||
Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
|
Full.Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
|
||||||
wordFromPosition = fromIntegral . unPos
|
wordFromPosition = fromIntegral . unPos
|
||||||
|
|
||||||
executableDefinition :: Parser ExecutableDefinition
|
executableDefinition :: Parser Full.ExecutableDefinition
|
||||||
executableDefinition = DefinitionOperation <$> operationDefinition
|
executableDefinition = Full.DefinitionOperation <$> operationDefinition
|
||||||
<|> DefinitionFragment <$> fragmentDefinition
|
<|> Full.DefinitionFragment <$> fragmentDefinition
|
||||||
<?> "ExecutableDefinition"
|
<?> "ExecutableDefinition"
|
||||||
|
|
||||||
typeSystemDefinition :: Parser TypeSystemDefinition
|
typeSystemDefinition :: Parser Full.TypeSystemDefinition
|
||||||
typeSystemDefinition = schemaDefinition
|
typeSystemDefinition = schemaDefinition
|
||||||
<|> typeSystemDefinitionWithDescription
|
<|> typeSystemDefinitionWithDescription
|
||||||
<?> "TypeSystemDefinition"
|
<?> "TypeSystemDefinition"
|
||||||
where
|
where
|
||||||
typeSystemDefinitionWithDescription = description
|
typeSystemDefinitionWithDescription = description
|
||||||
>>= liftA2 (<|>) typeDefinition' directiveDefinition
|
>>= liftA2 (<|>) typeDefinition' directiveDefinition
|
||||||
typeDefinition' description' = TypeDefinition
|
typeDefinition' description' = Full.TypeDefinition
|
||||||
<$> typeDefinition description'
|
<$> typeDefinition description'
|
||||||
|
|
||||||
typeSystemExtension :: Parser TypeSystemExtension
|
typeSystemExtension :: Parser Full.TypeSystemExtension
|
||||||
typeSystemExtension = SchemaExtension <$> schemaExtension
|
typeSystemExtension = Full.SchemaExtension <$> schemaExtension
|
||||||
<|> TypeExtension <$> typeExtension
|
<|> Full.TypeExtension <$> typeExtension
|
||||||
<?> "TypeSystemExtension"
|
<?> "TypeSystemExtension"
|
||||||
|
|
||||||
directiveDefinition :: Description -> Parser TypeSystemDefinition
|
directiveDefinition :: Full.Description -> Parser Full.TypeSystemDefinition
|
||||||
directiveDefinition description' = DirectiveDefinition description'
|
directiveDefinition description' = Full.DirectiveDefinition description'
|
||||||
<$ symbol "directive"
|
<$ symbol "directive"
|
||||||
<* at
|
<* at
|
||||||
<*> name
|
<*> name
|
||||||
|
@ -124,7 +125,7 @@ typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
|
||||||
<|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
|
<|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
|
||||||
<?> "TypeSystemDirectiveLocation"
|
<?> "TypeSystemDirectiveLocation"
|
||||||
|
|
||||||
typeDefinition :: Description -> Parser TypeDefinition
|
typeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||||
typeDefinition description' = scalarTypeDefinition description'
|
typeDefinition description' = scalarTypeDefinition description'
|
||||||
<|> objectTypeDefinition description'
|
<|> objectTypeDefinition description'
|
||||||
<|> interfaceTypeDefinition description'
|
<|> interfaceTypeDefinition description'
|
||||||
|
@ -133,7 +134,7 @@ typeDefinition description' = scalarTypeDefinition description'
|
||||||
<|> inputObjectTypeDefinition description'
|
<|> inputObjectTypeDefinition description'
|
||||||
<?> "TypeDefinition"
|
<?> "TypeDefinition"
|
||||||
|
|
||||||
typeExtension :: Parser TypeExtension
|
typeExtension :: Parser Full.TypeExtension
|
||||||
typeExtension = scalarTypeExtension
|
typeExtension = scalarTypeExtension
|
||||||
<|> objectTypeExtension
|
<|> objectTypeExtension
|
||||||
<|> interfaceTypeExtension
|
<|> interfaceTypeExtension
|
||||||
|
@ -142,143 +143,143 @@ typeExtension = scalarTypeExtension
|
||||||
<|> inputObjectTypeExtension
|
<|> inputObjectTypeExtension
|
||||||
<?> "TypeExtension"
|
<?> "TypeExtension"
|
||||||
|
|
||||||
scalarTypeDefinition :: Description -> Parser TypeDefinition
|
scalarTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||||
scalarTypeDefinition description' = ScalarTypeDefinition description'
|
scalarTypeDefinition description' = Full.ScalarTypeDefinition description'
|
||||||
<$ symbol "scalar"
|
<$ symbol "scalar"
|
||||||
<*> name
|
<*> name
|
||||||
<*> directives
|
<*> directives
|
||||||
<?> "ScalarTypeDefinition"
|
<?> "ScalarTypeDefinition"
|
||||||
|
|
||||||
scalarTypeExtension :: Parser TypeExtension
|
scalarTypeExtension :: Parser Full.TypeExtension
|
||||||
scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
|
scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
|
||||||
$ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
|
$ (Full.ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
|
||||||
|
|
||||||
objectTypeDefinition :: Description -> Parser TypeDefinition
|
objectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||||
objectTypeDefinition description' = ObjectTypeDefinition description'
|
objectTypeDefinition description' = Full.ObjectTypeDefinition description'
|
||||||
<$ symbol "type"
|
<$ symbol "type"
|
||||||
<*> name
|
<*> name
|
||||||
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> braces (many fieldDefinition)
|
<*> braces (many fieldDefinition)
|
||||||
<?> "ObjectTypeDefinition"
|
<?> "ObjectTypeDefinition"
|
||||||
|
|
||||||
objectTypeExtension :: Parser TypeExtension
|
objectTypeExtension :: Parser Full.TypeExtension
|
||||||
objectTypeExtension = extend "type" "ObjectTypeExtension"
|
objectTypeExtension = extend "type" "ObjectTypeExtension"
|
||||||
$ fieldsDefinitionExtension :|
|
$ fieldsDefinitionExtension :|
|
||||||
[ directivesExtension
|
[ directivesExtension
|
||||||
, implementsInterfacesExtension
|
, implementsInterfacesExtension
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension
|
fieldsDefinitionExtension = Full.ObjectTypeFieldsDefinitionExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> braces (NonEmpty.some fieldDefinition)
|
<*> braces (NonEmpty.some fieldDefinition)
|
||||||
directivesExtension = ObjectTypeDirectivesExtension
|
directivesExtension = Full.ObjectTypeDirectivesExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||||
<*> NonEmpty.some directive
|
<*> NonEmpty.some directive
|
||||||
implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension
|
implementsInterfacesExtension = Full.ObjectTypeImplementsInterfacesExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> implementsInterfaces NonEmpty.sepBy1
|
<*> implementsInterfaces NonEmpty.sepBy1
|
||||||
|
|
||||||
description :: Parser Description
|
description :: Parser Full.Description
|
||||||
description = Description
|
description = Full.Description
|
||||||
<$> optional stringValue
|
<$> optional stringValue
|
||||||
<?> "Description"
|
<?> "Description"
|
||||||
|
|
||||||
unionTypeDefinition :: Description -> Parser TypeDefinition
|
unionTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||||
unionTypeDefinition description' = UnionTypeDefinition description'
|
unionTypeDefinition description' = Full.UnionTypeDefinition description'
|
||||||
<$ symbol "union"
|
<$ symbol "union"
|
||||||
<*> name
|
<*> name
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)
|
<*> option (Full.UnionMemberTypes []) (unionMemberTypes sepBy1)
|
||||||
<?> "UnionTypeDefinition"
|
<?> "UnionTypeDefinition"
|
||||||
|
|
||||||
unionTypeExtension :: Parser TypeExtension
|
unionTypeExtension :: Parser Full.TypeExtension
|
||||||
unionTypeExtension = extend "union" "UnionTypeExtension"
|
unionTypeExtension = extend "union" "UnionTypeExtension"
|
||||||
$ unionMemberTypesExtension :| [directivesExtension]
|
$ unionMemberTypesExtension :| [directivesExtension]
|
||||||
where
|
where
|
||||||
unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension
|
unionMemberTypesExtension = Full.UnionTypeUnionMemberTypesExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> unionMemberTypes NonEmpty.sepBy1
|
<*> unionMemberTypes NonEmpty.sepBy1
|
||||||
directivesExtension = UnionTypeDirectivesExtension
|
directivesExtension = Full.UnionTypeDirectivesExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> NonEmpty.some directive
|
<*> NonEmpty.some directive
|
||||||
|
|
||||||
unionMemberTypes ::
|
unionMemberTypes ::
|
||||||
Foldable t =>
|
Foldable t =>
|
||||||
(Parser Text -> Parser Text -> Parser (t NamedType)) ->
|
(Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
|
||||||
Parser (UnionMemberTypes t)
|
Parser (Full.UnionMemberTypes t)
|
||||||
unionMemberTypes sepBy' = UnionMemberTypes
|
unionMemberTypes sepBy' = Full.UnionMemberTypes
|
||||||
<$ equals
|
<$ equals
|
||||||
<* optional pipe
|
<* optional pipe
|
||||||
<*> name `sepBy'` pipe
|
<*> name `sepBy'` pipe
|
||||||
<?> "UnionMemberTypes"
|
<?> "UnionMemberTypes"
|
||||||
|
|
||||||
interfaceTypeDefinition :: Description -> Parser TypeDefinition
|
interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||||
interfaceTypeDefinition description' = InterfaceTypeDefinition description'
|
interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
|
||||||
<$ symbol "interface"
|
<$ symbol "interface"
|
||||||
<*> name
|
<*> name
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> braces (many fieldDefinition)
|
<*> braces (many fieldDefinition)
|
||||||
<?> "InterfaceTypeDefinition"
|
<?> "InterfaceTypeDefinition"
|
||||||
|
|
||||||
interfaceTypeExtension :: Parser TypeExtension
|
interfaceTypeExtension :: Parser Full.TypeExtension
|
||||||
interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
|
interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
|
||||||
$ fieldsDefinitionExtension :| [directivesExtension]
|
$ fieldsDefinitionExtension :| [directivesExtension]
|
||||||
where
|
where
|
||||||
fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension
|
fieldsDefinitionExtension = Full.InterfaceTypeFieldsDefinitionExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> braces (NonEmpty.some fieldDefinition)
|
<*> braces (NonEmpty.some fieldDefinition)
|
||||||
directivesExtension = InterfaceTypeDirectivesExtension
|
directivesExtension = Full.InterfaceTypeDirectivesExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> NonEmpty.some directive
|
<*> NonEmpty.some directive
|
||||||
|
|
||||||
enumTypeDefinition :: Description -> Parser TypeDefinition
|
enumTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||||
enumTypeDefinition description' = EnumTypeDefinition description'
|
enumTypeDefinition description' = Full.EnumTypeDefinition description'
|
||||||
<$ symbol "enum"
|
<$ symbol "enum"
|
||||||
<*> name
|
<*> name
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> listOptIn braces enumValueDefinition
|
<*> listOptIn braces enumValueDefinition
|
||||||
<?> "EnumTypeDefinition"
|
<?> "EnumTypeDefinition"
|
||||||
|
|
||||||
enumTypeExtension :: Parser TypeExtension
|
enumTypeExtension :: Parser Full.TypeExtension
|
||||||
enumTypeExtension = extend "enum" "EnumTypeExtension"
|
enumTypeExtension = extend "enum" "EnumTypeExtension"
|
||||||
$ enumValuesDefinitionExtension :| [directivesExtension]
|
$ enumValuesDefinitionExtension :| [directivesExtension]
|
||||||
where
|
where
|
||||||
enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension
|
enumValuesDefinitionExtension = Full.EnumTypeEnumValuesDefinitionExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> braces (NonEmpty.some enumValueDefinition)
|
<*> braces (NonEmpty.some enumValueDefinition)
|
||||||
directivesExtension = EnumTypeDirectivesExtension
|
directivesExtension = Full.EnumTypeDirectivesExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> NonEmpty.some directive
|
<*> NonEmpty.some directive
|
||||||
|
|
||||||
inputObjectTypeDefinition :: Description -> Parser TypeDefinition
|
inputObjectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||||
inputObjectTypeDefinition description' = InputObjectTypeDefinition description'
|
inputObjectTypeDefinition description' = Full.InputObjectTypeDefinition description'
|
||||||
<$ symbol "input"
|
<$ symbol "input"
|
||||||
<*> name
|
<*> name
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> listOptIn braces inputValueDefinition
|
<*> listOptIn braces inputValueDefinition
|
||||||
<?> "InputObjectTypeDefinition"
|
<?> "InputObjectTypeDefinition"
|
||||||
|
|
||||||
inputObjectTypeExtension :: Parser TypeExtension
|
inputObjectTypeExtension :: Parser Full.TypeExtension
|
||||||
inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
|
inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
|
||||||
$ inputFieldsDefinitionExtension :| [directivesExtension]
|
$ inputFieldsDefinitionExtension :| [directivesExtension]
|
||||||
where
|
where
|
||||||
inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension
|
inputFieldsDefinitionExtension = Full.InputObjectTypeInputFieldsDefinitionExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> braces (NonEmpty.some inputValueDefinition)
|
<*> braces (NonEmpty.some inputValueDefinition)
|
||||||
directivesExtension = InputObjectTypeDirectivesExtension
|
directivesExtension = Full.InputObjectTypeDirectivesExtension
|
||||||
<$> name
|
<$> name
|
||||||
<*> NonEmpty.some directive
|
<*> NonEmpty.some directive
|
||||||
|
|
||||||
enumValueDefinition :: Parser EnumValueDefinition
|
enumValueDefinition :: Parser Full.EnumValueDefinition
|
||||||
enumValueDefinition = EnumValueDefinition
|
enumValueDefinition = Full.EnumValueDefinition
|
||||||
<$> description
|
<$> description
|
||||||
<*> enumValue
|
<*> enumValue
|
||||||
<*> directives
|
<*> directives
|
||||||
|
@ -286,16 +287,16 @@ enumValueDefinition = EnumValueDefinition
|
||||||
|
|
||||||
implementsInterfaces ::
|
implementsInterfaces ::
|
||||||
Foldable t =>
|
Foldable t =>
|
||||||
(Parser Text -> Parser Text -> Parser (t NamedType)) ->
|
(Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
|
||||||
Parser (ImplementsInterfaces t)
|
Parser (Full.ImplementsInterfaces t)
|
||||||
implementsInterfaces sepBy' = ImplementsInterfaces
|
implementsInterfaces sepBy' = Full.ImplementsInterfaces
|
||||||
<$ symbol "implements"
|
<$ symbol "implements"
|
||||||
<* optional amp
|
<* optional amp
|
||||||
<*> name `sepBy'` amp
|
<*> name `sepBy'` amp
|
||||||
<?> "ImplementsInterfaces"
|
<?> "ImplementsInterfaces"
|
||||||
|
|
||||||
inputValueDefinition :: Parser InputValueDefinition
|
inputValueDefinition :: Parser Full.InputValueDefinition
|
||||||
inputValueDefinition = InputValueDefinition
|
inputValueDefinition = Full.InputValueDefinition
|
||||||
<$> description
|
<$> description
|
||||||
<*> name
|
<*> name
|
||||||
<* colon
|
<* colon
|
||||||
|
@ -304,13 +305,13 @@ inputValueDefinition = InputValueDefinition
|
||||||
<*> directives
|
<*> directives
|
||||||
<?> "InputValueDefinition"
|
<?> "InputValueDefinition"
|
||||||
|
|
||||||
argumentsDefinition :: Parser ArgumentsDefinition
|
argumentsDefinition :: Parser Full.ArgumentsDefinition
|
||||||
argumentsDefinition = ArgumentsDefinition
|
argumentsDefinition = Full.ArgumentsDefinition
|
||||||
<$> listOptIn parens inputValueDefinition
|
<$> listOptIn parens inputValueDefinition
|
||||||
<?> "ArgumentsDefinition"
|
<?> "ArgumentsDefinition"
|
||||||
|
|
||||||
fieldDefinition :: Parser FieldDefinition
|
fieldDefinition :: Parser Full.FieldDefinition
|
||||||
fieldDefinition = FieldDefinition
|
fieldDefinition = Full.FieldDefinition
|
||||||
<$> description
|
<$> description
|
||||||
<*> name
|
<*> name
|
||||||
<*> argumentsDefinition
|
<*> argumentsDefinition
|
||||||
|
@ -319,33 +320,33 @@ fieldDefinition = FieldDefinition
|
||||||
<*> directives
|
<*> directives
|
||||||
<?> "FieldDefinition"
|
<?> "FieldDefinition"
|
||||||
|
|
||||||
schemaDefinition :: Parser TypeSystemDefinition
|
schemaDefinition :: Parser Full.TypeSystemDefinition
|
||||||
schemaDefinition = SchemaDefinition
|
schemaDefinition = Full.SchemaDefinition
|
||||||
<$ symbol "schema"
|
<$ symbol "schema"
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> operationTypeDefinitions
|
<*> operationTypeDefinitions
|
||||||
<?> "SchemaDefinition"
|
<?> "SchemaDefinition"
|
||||||
|
|
||||||
operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition)
|
operationTypeDefinitions :: Parser (NonEmpty Full.OperationTypeDefinition)
|
||||||
operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
|
operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
|
||||||
|
|
||||||
schemaExtension :: Parser SchemaExtension
|
schemaExtension :: Parser Full.SchemaExtension
|
||||||
schemaExtension = extend "schema" "SchemaExtension"
|
schemaExtension = extend "schema" "SchemaExtension"
|
||||||
$ schemaOperationExtension :| [directivesExtension]
|
$ schemaOperationExtension :| [directivesExtension]
|
||||||
where
|
where
|
||||||
directivesExtension = SchemaDirectivesExtension
|
directivesExtension = Full.SchemaDirectivesExtension
|
||||||
<$> NonEmpty.some directive
|
<$> NonEmpty.some directive
|
||||||
schemaOperationExtension = SchemaOperationExtension
|
schemaOperationExtension = Full.SchemaOperationExtension
|
||||||
<$> directives
|
<$> directives
|
||||||
<*> operationTypeDefinitions
|
<*> operationTypeDefinitions
|
||||||
|
|
||||||
operationTypeDefinition :: Parser OperationTypeDefinition
|
operationTypeDefinition :: Parser Full.OperationTypeDefinition
|
||||||
operationTypeDefinition = OperationTypeDefinition
|
operationTypeDefinition = Full.OperationTypeDefinition
|
||||||
<$> operationType <* colon
|
<$> operationType <* colon
|
||||||
<*> name
|
<*> name
|
||||||
<?> "OperationTypeDefinition"
|
<?> "OperationTypeDefinition"
|
||||||
|
|
||||||
operationDefinition :: Parser OperationDefinition
|
operationDefinition :: Parser Full.OperationDefinition
|
||||||
operationDefinition = shorthand
|
operationDefinition = shorthand
|
||||||
<|> operationDefinition'
|
<|> operationDefinition'
|
||||||
<?> "OperationDefinition"
|
<?> "OperationDefinition"
|
||||||
|
@ -353,7 +354,7 @@ operationDefinition = shorthand
|
||||||
shorthand = do
|
shorthand = do
|
||||||
location <- getLocation
|
location <- getLocation
|
||||||
selectionSet' <- selectionSet
|
selectionSet' <- selectionSet
|
||||||
pure $ SelectionSet selectionSet' location
|
pure $ Full.SelectionSet selectionSet' location
|
||||||
operationDefinition' = do
|
operationDefinition' = do
|
||||||
location <- getLocation
|
location <- getLocation
|
||||||
operationType' <- operationType
|
operationType' <- operationType
|
||||||
|
@ -361,60 +362,74 @@ operationDefinition = shorthand
|
||||||
variableDefinitions' <- variableDefinitions
|
variableDefinitions' <- variableDefinitions
|
||||||
directives' <- directives
|
directives' <- directives
|
||||||
selectionSet' <- selectionSet
|
selectionSet' <- selectionSet
|
||||||
pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location
|
pure $ Full.OperationDefinition
|
||||||
|
operationType'
|
||||||
|
operationName
|
||||||
|
variableDefinitions'
|
||||||
|
directives'
|
||||||
|
selectionSet'
|
||||||
|
location
|
||||||
|
|
||||||
operationType :: Parser OperationType
|
operationType :: Parser Full.OperationType
|
||||||
operationType = Query <$ symbol "query"
|
operationType = Full.Query <$ symbol "query"
|
||||||
<|> Mutation <$ symbol "mutation"
|
<|> Full.Mutation <$ symbol "mutation"
|
||||||
<|> Subscription <$ symbol "subscription"
|
<|> Full.Subscription <$ symbol "subscription"
|
||||||
<?> "OperationType"
|
<?> "OperationType"
|
||||||
|
|
||||||
selectionSet :: Parser SelectionSet
|
selectionSet :: Parser Full.SelectionSet
|
||||||
selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"
|
selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"
|
||||||
|
|
||||||
selectionSetOpt :: Parser SelectionSetOpt
|
selectionSetOpt :: Parser Full.SelectionSetOpt
|
||||||
selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
|
selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
|
||||||
|
|
||||||
selection :: Parser Selection
|
selection :: Parser Full.Selection
|
||||||
selection = field
|
selection = Full.FieldSelection <$> field
|
||||||
<|> try fragmentSpread
|
<|> Full.FragmentSpreadSelection <$> try fragmentSpread
|
||||||
<|> inlineFragment
|
<|> Full.InlineFragmentSelection <$> inlineFragment
|
||||||
<?> "Selection"
|
<?> "Selection"
|
||||||
|
|
||||||
field :: Parser Selection
|
field :: Parser Full.Field
|
||||||
field = Field
|
field = label "Field" $ do
|
||||||
<$> optional alias
|
location <- getLocation
|
||||||
<*> name
|
alias' <- optional alias
|
||||||
<*> arguments
|
name' <- name
|
||||||
<*> directives
|
arguments' <- arguments
|
||||||
<*> selectionSetOpt
|
directives' <- directives
|
||||||
<?> "Field"
|
selectionSetOpt' <- selectionSetOpt
|
||||||
|
pure $ Full.Field alias' name' arguments' directives' selectionSetOpt' location
|
||||||
|
|
||||||
alias :: Parser Alias
|
alias :: Parser Full.Name
|
||||||
alias = try (name <* colon) <?> "Alias"
|
alias = try (name <* colon) <?> "Alias"
|
||||||
|
|
||||||
arguments :: Parser [Argument]
|
arguments :: Parser [Full.Argument]
|
||||||
arguments = listOptIn parens argument <?> "Arguments"
|
arguments = listOptIn parens argument <?> "Arguments"
|
||||||
|
|
||||||
argument :: Parser Argument
|
argument :: Parser Full.Argument
|
||||||
argument = Argument <$> name <* colon <*> value <?> "Argument"
|
argument = label "Argument" $ do
|
||||||
|
location <- getLocation
|
||||||
|
name' <- name
|
||||||
|
colon
|
||||||
|
value' <- valueNode value
|
||||||
|
pure $ Full.Argument name' value' location
|
||||||
|
|
||||||
fragmentSpread :: Parser Selection
|
fragmentSpread :: Parser Full.FragmentSpread
|
||||||
fragmentSpread = FragmentSpread
|
fragmentSpread = label "FragmentSpread" $ do
|
||||||
<$ spread
|
location <- getLocation
|
||||||
<*> fragmentName
|
_ <- spread
|
||||||
<*> directives
|
fragmentName' <- fragmentName
|
||||||
<?> "FragmentSpread"
|
directives' <- directives
|
||||||
|
pure $ Full.FragmentSpread fragmentName' directives' location
|
||||||
|
|
||||||
inlineFragment :: Parser Selection
|
inlineFragment :: Parser Full.InlineFragment
|
||||||
inlineFragment = InlineFragment
|
inlineFragment = label "InlineFragment" $ do
|
||||||
<$ spread
|
location <- getLocation
|
||||||
<*> optional typeCondition
|
_ <- spread
|
||||||
<*> directives
|
typeCondition' <- optional typeCondition
|
||||||
<*> selectionSet
|
directives' <- directives
|
||||||
<?> "InlineFragment"
|
selectionSet' <- selectionSet
|
||||||
|
pure $ Full.InlineFragment typeCondition' directives' selectionSet' location
|
||||||
|
|
||||||
fragmentDefinition :: Parser FragmentDefinition
|
fragmentDefinition :: Parser Full.FragmentDefinition
|
||||||
fragmentDefinition = label "FragmentDefinition" $ do
|
fragmentDefinition = label "FragmentDefinition" $ do
|
||||||
location <- getLocation
|
location <- getLocation
|
||||||
_ <- symbol "fragment"
|
_ <- symbol "fragment"
|
||||||
|
@ -422,36 +437,42 @@ fragmentDefinition = label "FragmentDefinition" $ do
|
||||||
typeCondition' <- typeCondition
|
typeCondition' <- typeCondition
|
||||||
directives' <- directives
|
directives' <- directives
|
||||||
selectionSet' <- selectionSet
|
selectionSet' <- selectionSet
|
||||||
pure $ FragmentDefinition
|
pure $ Full.FragmentDefinition
|
||||||
fragmentName' typeCondition' directives' selectionSet' location
|
fragmentName' typeCondition' directives' selectionSet' location
|
||||||
|
|
||||||
fragmentName :: Parser Name
|
fragmentName :: Parser Full.Name
|
||||||
fragmentName = but (symbol "on") *> name <?> "FragmentName"
|
fragmentName = but (symbol "on") *> name <?> "FragmentName"
|
||||||
|
|
||||||
typeCondition :: Parser TypeCondition
|
typeCondition :: Parser Full.TypeCondition
|
||||||
typeCondition = symbol "on" *> name <?> "TypeCondition"
|
typeCondition = symbol "on" *> name <?> "TypeCondition"
|
||||||
|
|
||||||
value :: Parser Value
|
valueNode :: forall a. Parser a -> Parser (Full.Node a)
|
||||||
value = Variable <$> variable
|
valueNode valueParser = do
|
||||||
<|> Float <$> try float
|
location <- getLocation
|
||||||
<|> Int <$> integer
|
value' <- valueParser
|
||||||
<|> Boolean <$> booleanValue
|
pure $ Full.Node value' location
|
||||||
<|> Null <$ nullValue
|
|
||||||
<|> String <$> stringValue
|
value :: Parser Full.Value
|
||||||
<|> Enum <$> try enumValue
|
value = Full.Variable <$> variable
|
||||||
<|> List <$> brackets (some value)
|
<|> Full.Float <$> try float
|
||||||
<|> Object <$> braces (some $ objectField value)
|
<|> Full.Int <$> integer
|
||||||
|
<|> Full.Boolean <$> booleanValue
|
||||||
|
<|> Full.Null <$ nullValue
|
||||||
|
<|> Full.String <$> stringValue
|
||||||
|
<|> Full.Enum <$> try enumValue
|
||||||
|
<|> Full.List <$> brackets (some value)
|
||||||
|
<|> Full.Object <$> braces (some $ objectField $ valueNode value)
|
||||||
<?> "Value"
|
<?> "Value"
|
||||||
|
|
||||||
constValue :: Parser ConstValue
|
constValue :: Parser Full.ConstValue
|
||||||
constValue = ConstFloat <$> try float
|
constValue = Full.ConstFloat <$> try float
|
||||||
<|> ConstInt <$> integer
|
<|> Full.ConstInt <$> integer
|
||||||
<|> ConstBoolean <$> booleanValue
|
<|> Full.ConstBoolean <$> booleanValue
|
||||||
<|> ConstNull <$ nullValue
|
<|> Full.ConstNull <$ nullValue
|
||||||
<|> ConstString <$> stringValue
|
<|> Full.ConstString <$> stringValue
|
||||||
<|> ConstEnum <$> try enumValue
|
<|> Full.ConstEnum <$> try enumValue
|
||||||
<|> ConstList <$> brackets (some constValue)
|
<|> Full.ConstList <$> brackets (some constValue)
|
||||||
<|> ConstObject <$> braces (some $ objectField constValue)
|
<|> Full.ConstObject <$> braces (some $ objectField $ valueNode constValue)
|
||||||
<?> "Value"
|
<?> "Value"
|
||||||
|
|
||||||
booleanValue :: Parser Bool
|
booleanValue :: Parser Bool
|
||||||
|
@ -459,7 +480,7 @@ booleanValue = True <$ symbol "true"
|
||||||
<|> False <$ symbol "false"
|
<|> False <$ symbol "false"
|
||||||
<?> "BooleanValue"
|
<?> "BooleanValue"
|
||||||
|
|
||||||
enumValue :: Parser Name
|
enumValue :: Parser Full.Name
|
||||||
enumValue = but (symbol "true")
|
enumValue = but (symbol "true")
|
||||||
*> but (symbol "false")
|
*> but (symbol "false")
|
||||||
*> but (symbol "null")
|
*> but (symbol "null")
|
||||||
|
@ -472,51 +493,54 @@ stringValue = blockString <|> string <?> "StringValue"
|
||||||
nullValue :: Parser Text
|
nullValue :: Parser Text
|
||||||
nullValue = symbol "null" <?> "NullValue"
|
nullValue = symbol "null" <?> "NullValue"
|
||||||
|
|
||||||
objectField :: Parser a -> Parser (ObjectField a)
|
objectField :: forall a. Parser (Full.Node a) -> Parser (Full.ObjectField a)
|
||||||
objectField valueParser = ObjectField
|
objectField valueParser = label "ObjectField" $ do
|
||||||
<$> name
|
location <- getLocation
|
||||||
<* colon
|
fieldName <- name
|
||||||
<*> valueParser
|
colon
|
||||||
<?> "ObjectField"
|
fieldValue <- valueParser
|
||||||
|
pure $ Full.ObjectField fieldName fieldValue location
|
||||||
|
|
||||||
variableDefinitions :: Parser [VariableDefinition]
|
variableDefinitions :: Parser [Full.VariableDefinition]
|
||||||
variableDefinitions = listOptIn parens variableDefinition
|
variableDefinitions = listOptIn parens variableDefinition
|
||||||
<?> "VariableDefinitions"
|
<?> "VariableDefinitions"
|
||||||
|
|
||||||
variableDefinition :: Parser VariableDefinition
|
variableDefinition :: Parser Full.VariableDefinition
|
||||||
variableDefinition = VariableDefinition
|
variableDefinition = label "VariableDefinition" $ do
|
||||||
<$> variable
|
location <- getLocation
|
||||||
<* colon
|
variableName <- variable
|
||||||
<*> type'
|
colon
|
||||||
<*> defaultValue
|
variableType <- type'
|
||||||
<?> "VariableDefinition"
|
variableValue <- defaultValue
|
||||||
|
pure $ Full.VariableDefinition variableName variableType variableValue location
|
||||||
|
|
||||||
variable :: Parser Name
|
variable :: Parser Full.Name
|
||||||
variable = dollar *> name <?> "Variable"
|
variable = dollar *> name <?> "Variable"
|
||||||
|
|
||||||
defaultValue :: Parser (Maybe ConstValue)
|
defaultValue :: Parser (Maybe (Full.Node Full.ConstValue))
|
||||||
defaultValue = optional (equals *> constValue) <?> "DefaultValue"
|
defaultValue = optional (equals *> valueNode constValue) <?> "DefaultValue"
|
||||||
|
|
||||||
type' :: Parser Type
|
type' :: Parser Full.Type
|
||||||
type' = try (TypeNonNull <$> nonNullType)
|
type' = try (Full.TypeNonNull <$> nonNullType)
|
||||||
<|> TypeList <$> brackets type'
|
<|> Full.TypeList <$> brackets type'
|
||||||
<|> TypeNamed <$> name
|
<|> Full.TypeNamed <$> name
|
||||||
<?> "Type"
|
<?> "Type"
|
||||||
|
|
||||||
nonNullType :: Parser NonNullType
|
nonNullType :: Parser Full.NonNullType
|
||||||
nonNullType = NonNullTypeNamed <$> name <* bang
|
nonNullType = Full.NonNullTypeNamed <$> name <* bang
|
||||||
<|> NonNullTypeList <$> brackets type' <* bang
|
<|> Full.NonNullTypeList <$> brackets type' <* bang
|
||||||
<?> "NonNullType"
|
<?> "NonNullType"
|
||||||
|
|
||||||
directives :: Parser [Directive]
|
directives :: Parser [Full.Directive]
|
||||||
directives = many directive <?> "Directives"
|
directives = many directive <?> "Directives"
|
||||||
|
|
||||||
directive :: Parser Directive
|
directive :: Parser Full.Directive
|
||||||
directive = Directive
|
directive = label "Directive" $ do
|
||||||
<$ at
|
location <- getLocation
|
||||||
<*> name
|
at
|
||||||
<*> arguments
|
directiveName <- name
|
||||||
<?> "Directive"
|
directiveArguments <- arguments
|
||||||
|
pure $ Full.Directive directiveName directiveArguments location
|
||||||
|
|
||||||
listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
|
listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
|
||||||
listOptIn surround = option [] . surround . some
|
listOptIn surround = option [] . surround . some
|
||||||
|
|
|
@ -5,15 +5,16 @@
|
||||||
|
|
||||||
-- | Error handling.
|
-- | Error handling.
|
||||||
module Language.GraphQL.Error
|
module Language.GraphQL.Error
|
||||||
( parseError
|
( CollectErrsT
|
||||||
, CollectErrsT
|
|
||||||
, Error(..)
|
, Error(..)
|
||||||
|
, Path(..)
|
||||||
, Resolution(..)
|
, Resolution(..)
|
||||||
, ResolverException(..)
|
, ResolverException(..)
|
||||||
, Response(..)
|
, Response(..)
|
||||||
, ResponseEventStream
|
, ResponseEventStream
|
||||||
, addErr
|
, addErr
|
||||||
, addErrMsg
|
, addErrMsg
|
||||||
|
, parseError
|
||||||
, runCollectErrs
|
, runCollectErrs
|
||||||
, singleError
|
, singleError
|
||||||
) where
|
) where
|
||||||
|
@ -28,7 +29,7 @@ import Data.Text (Text)
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import Language.GraphQL.AST (Location(..), Name)
|
import Language.GraphQL.AST (Location(..), Name)
|
||||||
import Language.GraphQL.Execute.Coerce
|
import Language.GraphQL.Execute.Coerce
|
||||||
import Language.GraphQL.Type.Schema
|
import qualified Language.GraphQL.Type.Schema as Schema
|
||||||
import Prelude hiding (null)
|
import Prelude hiding (null)
|
||||||
import Text.Megaparsec
|
import Text.Megaparsec
|
||||||
( ParseErrorBundle(..)
|
( ParseErrorBundle(..)
|
||||||
|
@ -43,7 +44,7 @@ import Text.Megaparsec
|
||||||
-- | Executor context.
|
-- | Executor context.
|
||||||
data Resolution m = Resolution
|
data Resolution m = Resolution
|
||||||
{ errors :: Seq Error
|
{ errors :: Seq Error
|
||||||
, types :: HashMap Name (Type m)
|
, types :: HashMap Name (Schema.Type m)
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Wraps a parse error into a list of errors.
|
-- | Wraps a parse error into a list of errors.
|
||||||
|
@ -57,6 +58,7 @@ parseError ParseErrorBundle{..} =
|
||||||
errorObject s SourcePos{..} = Error
|
errorObject s SourcePos{..} = Error
|
||||||
{ message = Text.pack $ init $ parseErrorTextPretty s
|
{ message = Text.pack $ init $ parseErrorTextPretty s
|
||||||
, locations = [Location (unPos' sourceLine) (unPos' sourceColumn)]
|
, locations = [Location (unPos' sourceLine) (unPos' sourceColumn)]
|
||||||
|
, path = []
|
||||||
}
|
}
|
||||||
unPos' = fromIntegral . unPos
|
unPos' = fromIntegral . unPos
|
||||||
go (result, state) x =
|
go (result, state) x =
|
||||||
|
@ -75,7 +77,7 @@ addErr v = modify appender
|
||||||
appender resolution@Resolution{..} = resolution{ errors = errors |> v }
|
appender resolution@Resolution{..} = resolution{ errors = errors |> v }
|
||||||
|
|
||||||
makeErrorMessage :: Text -> Error
|
makeErrorMessage :: Text -> Error
|
||||||
makeErrorMessage s = Error s []
|
makeErrorMessage s = Error s [] []
|
||||||
|
|
||||||
-- | Constructs a response object containing only the error with the given
|
-- | Constructs a response object containing only the error with the given
|
||||||
-- message.
|
-- message.
|
||||||
|
@ -86,10 +88,20 @@ singleError message = Response null $ Seq.singleton $ makeErrorMessage message
|
||||||
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
|
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
|
||||||
addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
|
addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
|
||||||
|
|
||||||
|
-- | If an error can be associated to a particular field in the GraphQL result,
|
||||||
|
-- it must contain an entry with the key path that details the path of the
|
||||||
|
-- response field which experienced the error. This allows clients to identify
|
||||||
|
-- whether a null result is intentional or caused by a runtime error.
|
||||||
|
data Path
|
||||||
|
= Segment Text -- ^ Field name.
|
||||||
|
| Index Int -- ^ List index if a field returned a list.
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | @GraphQL@ error.
|
-- | @GraphQL@ error.
|
||||||
data Error = Error
|
data Error = Error
|
||||||
{ message :: Text
|
{ message :: Text
|
||||||
, locations :: [Location]
|
, locations :: [Location]
|
||||||
|
, path :: [Path]
|
||||||
} deriving (Eq, Show)
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
-- | The server\'s response describes the result of executing the requested
|
-- | The server\'s response describes the result of executing the requested
|
||||||
|
@ -117,7 +129,7 @@ instance Exception ResolverException
|
||||||
-- | Runs the given query computation, but collects the errors into an error
|
-- | Runs the given query computation, but collects the errors into an error
|
||||||
-- list, which is then sent back with the data.
|
-- list, which is then sent back with the data.
|
||||||
runCollectErrs :: (Monad m, Serialize a)
|
runCollectErrs :: (Monad m, Serialize a)
|
||||||
=> HashMap Name (Type m)
|
=> HashMap Name (Schema.Type m)
|
||||||
-> CollectErrsT m a
|
-> CollectErrsT m a
|
||||||
-> m (Response a)
|
-> m (Response a)
|
||||||
runCollectErrs types' res = do
|
runCollectErrs types' res = do
|
||||||
|
|
|
@ -32,8 +32,8 @@ execute :: (MonadCatch m, VariableValue a, Serialize b)
|
||||||
-> HashMap Name a -- ^ Variable substitution function.
|
-> HashMap Name a -- ^ Variable substitution function.
|
||||||
-> Document -- @GraphQL@ document.
|
-> Document -- @GraphQL@ document.
|
||||||
-> m (Either (ResponseEventStream m b) (Response b))
|
-> m (Either (ResponseEventStream m b) (Response b))
|
||||||
execute schema operationName subs document =
|
execute schema' operationName subs document =
|
||||||
case Transform.document schema operationName subs document of
|
case Transform.document schema' operationName subs document of
|
||||||
Left queryError -> pure
|
Left queryError -> pure
|
||||||
$ Right
|
$ Right
|
||||||
$ singleError
|
$ singleError
|
||||||
|
|
|
@ -27,8 +27,7 @@ import qualified Language.GraphQL.Execute.Transform as Transform
|
||||||
import qualified Language.GraphQL.Type as Type
|
import qualified Language.GraphQL.Type as Type
|
||||||
import qualified Language.GraphQL.Type.In as In
|
import qualified Language.GraphQL.Type.In as In
|
||||||
import qualified Language.GraphQL.Type.Out as Out
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
import Language.GraphQL.Type.Internal
|
import qualified Language.GraphQL.Type.Internal as Internal
|
||||||
import Language.GraphQL.Type.Schema
|
|
||||||
import Prelude hiding (null)
|
import Prelude hiding (null)
|
||||||
|
|
||||||
resolveFieldValue :: MonadCatch m
|
resolveFieldValue :: MonadCatch m
|
||||||
|
@ -43,7 +42,7 @@ resolveFieldValue result args resolver =
|
||||||
=> ResolverException
|
=> ResolverException
|
||||||
-> CollectErrsT m Type.Value
|
-> CollectErrsT m Type.Value
|
||||||
handleFieldError e =
|
handleFieldError e =
|
||||||
addErr (Error (Text.pack $ displayException e) []) >> pure Type.Null
|
addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null
|
||||||
context = Type.Context
|
context = Type.Context
|
||||||
{ Type.arguments = Type.Arguments args
|
{ Type.arguments = Type.Arguments args
|
||||||
, Type.values = result
|
, Type.values = result
|
||||||
|
@ -60,7 +59,7 @@ collectFields objectType = foldl forEach Map.empty
|
||||||
in Map.insertWith (<>) responseKey (field :| []) groupedFields
|
in Map.insertWith (<>) responseKey (field :| []) groupedFields
|
||||||
forEach groupedFields (Transform.SelectionFragment selectionFragment)
|
forEach groupedFields (Transform.SelectionFragment selectionFragment)
|
||||||
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
|
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
|
||||||
, doesFragmentTypeApply fragmentType objectType =
|
, Internal.doesFragmentTypeApply fragmentType objectType =
|
||||||
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
|
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
|
||||||
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
|
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
|
||||||
| otherwise = groupedFields
|
| otherwise = groupedFields
|
||||||
|
@ -69,15 +68,15 @@ aliasOrName :: forall m. Transform.Field m -> Name
|
||||||
aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
|
aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
|
||||||
|
|
||||||
resolveAbstractType :: Monad m
|
resolveAbstractType :: Monad m
|
||||||
=> AbstractType m
|
=> Internal.AbstractType m
|
||||||
-> Type.Subs
|
-> Type.Subs
|
||||||
-> CollectErrsT m (Maybe (Out.ObjectType m))
|
-> CollectErrsT m (Maybe (Out.ObjectType m))
|
||||||
resolveAbstractType abstractType values'
|
resolveAbstractType abstractType values'
|
||||||
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
|
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
|
||||||
types' <- gets types
|
types' <- gets types
|
||||||
case HashMap.lookup typeName types' of
|
case HashMap.lookup typeName types' of
|
||||||
Just (ObjectType objectType) ->
|
Just (Internal.ObjectType objectType) ->
|
||||||
if instanceOf objectType abstractType
|
if Internal.instanceOf objectType abstractType
|
||||||
then pure $ Just objectType
|
then pure $ Just objectType
|
||||||
else pure Nothing
|
else pure Nothing
|
||||||
_ -> pure Nothing
|
_ -> pure Nothing
|
||||||
|
@ -124,25 +123,25 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
|
||||||
let Type.EnumType _ _ enumMembers = enumType
|
let Type.EnumType _ _ enumMembers = enumType
|
||||||
in if HashMap.member enum enumMembers
|
in if HashMap.member enum enumMembers
|
||||||
then coerceResult outputType $ Enum enum
|
then coerceResult outputType $ Enum enum
|
||||||
else addErrMsg "Value completion failed."
|
else addErrMsg "Enum value completion failed."
|
||||||
completeValue (Out.ObjectBaseType objectType) fields result =
|
completeValue (Out.ObjectBaseType objectType) fields result =
|
||||||
executeSelectionSet result objectType $ mergeSelectionSets fields
|
executeSelectionSet result objectType $ mergeSelectionSets fields
|
||||||
completeValue (Out.InterfaceBaseType interfaceType) fields result
|
completeValue (Out.InterfaceBaseType interfaceType) fields result
|
||||||
| Type.Object objectMap <- result = do
|
| Type.Object objectMap <- result = do
|
||||||
let abstractType = AbstractInterfaceType interfaceType
|
let abstractType = Internal.AbstractInterfaceType interfaceType
|
||||||
concreteType <- resolveAbstractType abstractType objectMap
|
concreteType <- resolveAbstractType abstractType objectMap
|
||||||
case concreteType of
|
case concreteType of
|
||||||
Just objectType -> executeSelectionSet result objectType
|
Just objectType -> executeSelectionSet result objectType
|
||||||
$ mergeSelectionSets fields
|
$ mergeSelectionSets fields
|
||||||
Nothing -> addErrMsg "Value completion failed."
|
Nothing -> addErrMsg "Interface value completion failed."
|
||||||
completeValue (Out.UnionBaseType unionType) fields result
|
completeValue (Out.UnionBaseType unionType) fields result
|
||||||
| Type.Object objectMap <- result = do
|
| Type.Object objectMap <- result = do
|
||||||
let abstractType = AbstractUnionType unionType
|
let abstractType = Internal.AbstractUnionType unionType
|
||||||
concreteType <- resolveAbstractType abstractType objectMap
|
concreteType <- resolveAbstractType abstractType objectMap
|
||||||
case concreteType of
|
case concreteType of
|
||||||
Just objectType -> executeSelectionSet result objectType
|
Just objectType -> executeSelectionSet result objectType
|
||||||
$ mergeSelectionSets fields
|
$ mergeSelectionSets fields
|
||||||
Nothing -> addErrMsg "Value completion failed."
|
Nothing -> addErrMsg "Union value completion failed."
|
||||||
completeValue _ _ _ = addErrMsg "Value completion failed."
|
completeValue _ _ _ = addErrMsg "Value completion failed."
|
||||||
|
|
||||||
mergeSelectionSets :: MonadCatch m
|
mergeSelectionSets :: MonadCatch m
|
||||||
|
|
|
@ -47,24 +47,23 @@ import Language.GraphQL.AST (Name)
|
||||||
import qualified Language.GraphQL.Execute.Coerce as Coerce
|
import qualified Language.GraphQL.Execute.Coerce as Coerce
|
||||||
import qualified Language.GraphQL.Type.Definition as Definition
|
import qualified Language.GraphQL.Type.Definition as Definition
|
||||||
import qualified Language.GraphQL.Type as Type
|
import qualified Language.GraphQL.Type as Type
|
||||||
import qualified Language.GraphQL.Type.In as In
|
import qualified Language.GraphQL.Type.Internal as Type
|
||||||
import Language.GraphQL.Type.Internal
|
|
||||||
import qualified Language.GraphQL.Type.Out as Out
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
import Language.GraphQL.Type.Schema
|
import qualified Language.GraphQL.Type.Schema as Schema
|
||||||
|
|
||||||
-- | Associates a fragment name with a list of 'Field's.
|
-- | Associates a fragment name with a list of 'Field's.
|
||||||
data Replacement m = Replacement
|
data Replacement m = Replacement
|
||||||
{ fragments :: HashMap Full.Name (Fragment m)
|
{ fragments :: HashMap Full.Name (Fragment m)
|
||||||
, fragmentDefinitions :: FragmentDefinitions
|
, fragmentDefinitions :: FragmentDefinitions
|
||||||
, variableValues :: Type.Subs
|
, variableValues :: Type.Subs
|
||||||
, types :: HashMap Full.Name (Type m)
|
, types :: HashMap Full.Name (Schema.Type m)
|
||||||
}
|
}
|
||||||
|
|
||||||
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
|
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
|
||||||
|
|
||||||
-- | Represents fragments and inline fragments.
|
-- | Represents fragments and inline fragments.
|
||||||
data Fragment m
|
data Fragment m
|
||||||
= Fragment (CompositeType m) (Seq (Selection m))
|
= Fragment (Type.CompositeType m) (Seq (Selection m))
|
||||||
|
|
||||||
-- | Single selection element.
|
-- | Single selection element.
|
||||||
data Selection m
|
data Selection m
|
||||||
|
@ -85,7 +84,7 @@ data Field m = Field
|
||||||
|
|
||||||
-- | Contains the operation to be executed along with its root type.
|
-- | Contains the operation to be executed along with its root type.
|
||||||
data Document m = Document
|
data Document m = Document
|
||||||
(HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)
|
(HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
|
||||||
|
|
||||||
data OperationDefinition = OperationDefinition
|
data OperationDefinition = OperationDefinition
|
||||||
Full.OperationType
|
Full.OperationType
|
||||||
|
@ -139,38 +138,9 @@ getOperation (Just operationName) operations
|
||||||
matchingName (OperationDefinition _ name _ _ _) =
|
matchingName (OperationDefinition _ name _ _ _) =
|
||||||
name == Just operationName
|
name == Just operationName
|
||||||
|
|
||||||
lookupInputType
|
|
||||||
:: Full.Type
|
|
||||||
-> HashMap.HashMap Full.Name (Type m)
|
|
||||||
-> Maybe In.Type
|
|
||||||
lookupInputType (Full.TypeNamed name) types =
|
|
||||||
case HashMap.lookup name types of
|
|
||||||
Just (ScalarType scalarType) ->
|
|
||||||
Just $ In.NamedScalarType scalarType
|
|
||||||
Just (EnumType enumType) ->
|
|
||||||
Just $ In.NamedEnumType enumType
|
|
||||||
Just (InputObjectType objectType) ->
|
|
||||||
Just $ In.NamedInputObjectType objectType
|
|
||||||
_ -> Nothing
|
|
||||||
lookupInputType (Full.TypeList list) types
|
|
||||||
= In.ListType
|
|
||||||
<$> lookupInputType list types
|
|
||||||
lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
|
|
||||||
case HashMap.lookup nonNull types of
|
|
||||||
Just (ScalarType scalarType) ->
|
|
||||||
Just $ In.NonNullScalarType scalarType
|
|
||||||
Just (EnumType enumType) ->
|
|
||||||
Just $ In.NonNullEnumType enumType
|
|
||||||
Just (InputObjectType objectType) ->
|
|
||||||
Just $ In.NonNullInputObjectType objectType
|
|
||||||
_ -> Nothing
|
|
||||||
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
|
|
||||||
= In.NonNullListType
|
|
||||||
<$> lookupInputType nonNull types
|
|
||||||
|
|
||||||
coerceVariableValues :: Coerce.VariableValue a
|
coerceVariableValues :: Coerce.VariableValue a
|
||||||
=> forall m
|
=> forall m
|
||||||
. HashMap Full.Name (Type m)
|
. HashMap Full.Name (Schema.Type m)
|
||||||
-> OperationDefinition
|
-> OperationDefinition
|
||||||
-> HashMap.HashMap Full.Name a
|
-> HashMap.HashMap Full.Name a
|
||||||
-> Either QueryError Type.Subs
|
-> Either QueryError Type.Subs
|
||||||
|
@ -180,10 +150,10 @@ coerceVariableValues types operationDefinition variableValues =
|
||||||
$ foldr forEach (Just HashMap.empty) variableDefinitions
|
$ foldr forEach (Just HashMap.empty) variableDefinitions
|
||||||
where
|
where
|
||||||
forEach variableDefinition coercedValues = do
|
forEach variableDefinition coercedValues = do
|
||||||
let Full.VariableDefinition variableName variableTypeName defaultValue =
|
let Full.VariableDefinition variableName variableTypeName defaultValue _ =
|
||||||
variableDefinition
|
variableDefinition
|
||||||
let defaultValue' = constValue <$> defaultValue
|
let defaultValue' = constValue . Full.node <$> defaultValue
|
||||||
variableType <- lookupInputType variableTypeName types
|
variableType <- Type.lookupInputType variableTypeName types
|
||||||
|
|
||||||
Coerce.matchFieldValues
|
Coerce.matchFieldValues
|
||||||
coerceVariableValue'
|
coerceVariableValue'
|
||||||
|
@ -207,19 +177,20 @@ constValue (Full.ConstList l) = Type.List $ constValue <$> l
|
||||||
constValue (Full.ConstObject o) =
|
constValue (Full.ConstObject o) =
|
||||||
Type.Object $ HashMap.fromList $ constObjectField <$> o
|
Type.Object $ HashMap.fromList $ constObjectField <$> o
|
||||||
where
|
where
|
||||||
constObjectField (Full.ObjectField key value') = (key, constValue value')
|
constObjectField Full.ObjectField{value = value', ..} =
|
||||||
|
(name, constValue $ Full.node value')
|
||||||
|
|
||||||
-- | Rewrites the original syntax tree into an intermediate representation used
|
-- | Rewrites the original syntax tree into an intermediate representation used
|
||||||
-- for query execution.
|
-- for query execution.
|
||||||
document :: Coerce.VariableValue a
|
document :: Coerce.VariableValue a
|
||||||
=> forall m
|
=> forall m
|
||||||
. Schema m
|
. Type.Schema m
|
||||||
-> Maybe Full.Name
|
-> Maybe Full.Name
|
||||||
-> HashMap Full.Name a
|
-> HashMap Full.Name a
|
||||||
-> Full.Document
|
-> Full.Document
|
||||||
-> Either QueryError (Document m)
|
-> Either QueryError (Document m)
|
||||||
document schema operationName subs ast = do
|
document schema operationName subs ast = do
|
||||||
let referencedTypes = collectReferencedTypes schema
|
let referencedTypes = Schema.types schema
|
||||||
|
|
||||||
(operations, fragmentTable) <- defragment ast
|
(operations, fragmentTable) <- defragment ast
|
||||||
chosenOperation <- getOperation operationName operations
|
chosenOperation <- getOperation operationName operations
|
||||||
|
@ -233,14 +204,14 @@ document schema operationName subs ast = do
|
||||||
}
|
}
|
||||||
case chosenOperation of
|
case chosenOperation of
|
||||||
OperationDefinition Full.Query _ _ _ _ ->
|
OperationDefinition Full.Query _ _ _ _ ->
|
||||||
pure $ Document referencedTypes (query schema)
|
pure $ Document referencedTypes (Schema.query schema)
|
||||||
$ operation chosenOperation replacement
|
$ operation chosenOperation replacement
|
||||||
OperationDefinition Full.Mutation _ _ _ _
|
OperationDefinition Full.Mutation _ _ _ _
|
||||||
| Just mutationType <- mutation schema ->
|
| Just mutationType <- Schema.mutation schema ->
|
||||||
pure $ Document referencedTypes mutationType
|
pure $ Document referencedTypes mutationType
|
||||||
$ operation chosenOperation replacement
|
$ operation chosenOperation replacement
|
||||||
OperationDefinition Full.Subscription _ _ _ _
|
OperationDefinition Full.Subscription _ _ _ _
|
||||||
| Just subscriptionType <- subscription schema ->
|
| Just subscriptionType <- Schema.subscription schema ->
|
||||||
pure $ Document referencedTypes subscriptionType
|
pure $ Document referencedTypes subscriptionType
|
||||||
$ operation chosenOperation replacement
|
$ operation chosenOperation replacement
|
||||||
_ -> Left UnsupportedRootOperation
|
_ -> Left UnsupportedRootOperation
|
||||||
|
@ -288,33 +259,47 @@ operation operationDefinition replacement
|
||||||
selection
|
selection
|
||||||
:: Full.Selection
|
:: Full.Selection
|
||||||
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
||||||
selection (Full.Field alias name arguments' directives' selections) =
|
selection (Full.FieldSelection fieldSelection) =
|
||||||
maybe (Left mempty) (Right . SelectionField) <$> do
|
maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection
|
||||||
fieldArguments <- foldM go HashMap.empty arguments'
|
selection (Full.FragmentSpreadSelection fragmentSelection)
|
||||||
fieldSelections <- appendSelection selections
|
= maybe (Left mempty) (Right . SelectionFragment)
|
||||||
fieldDirectives <- Definition.selection <$> directives directives'
|
<$> fragmentSpread fragmentSelection
|
||||||
let field' = Field alias name fieldArguments fieldSelections
|
selection (Full.InlineFragmentSelection fragmentSelection) =
|
||||||
pure $ field' <$ fieldDirectives
|
inlineFragment fragmentSelection
|
||||||
|
|
||||||
|
field :: Full.Field -> State (Replacement m) (Maybe (Field m))
|
||||||
|
field (Full.Field alias name arguments' directives' selections _) = do
|
||||||
|
fieldArguments <- foldM go HashMap.empty arguments'
|
||||||
|
fieldSelections <- appendSelection selections
|
||||||
|
fieldDirectives <- Definition.selection <$> directives directives'
|
||||||
|
let field' = Field alias name fieldArguments fieldSelections
|
||||||
|
pure $ field' <$ fieldDirectives
|
||||||
where
|
where
|
||||||
go arguments (Full.Argument name' value') =
|
go arguments (Full.Argument name' (Full.Node value' _) _) =
|
||||||
inputField arguments name' value'
|
inputField arguments name' value'
|
||||||
|
|
||||||
selection (Full.FragmentSpread name directives') =
|
fragmentSpread
|
||||||
maybe (Left mempty) (Right . SelectionFragment) <$> do
|
:: Full.FragmentSpread
|
||||||
spreadDirectives <- Definition.selection <$> directives directives'
|
-> State (Replacement m) (Maybe (Fragment m))
|
||||||
fragments' <- gets fragments
|
fragmentSpread (Full.FragmentSpread name directives' _) = do
|
||||||
|
spreadDirectives <- Definition.selection <$> directives directives'
|
||||||
|
fragments' <- gets fragments
|
||||||
|
|
||||||
fragmentDefinitions' <- gets fragmentDefinitions
|
fragmentDefinitions' <- gets fragmentDefinitions
|
||||||
case HashMap.lookup name fragments' of
|
case HashMap.lookup name fragments' of
|
||||||
Just definition -> lift $ pure $ definition <$ spreadDirectives
|
Just definition -> lift $ pure $ definition <$ spreadDirectives
|
||||||
Nothing
|
Nothing
|
||||||
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
|
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
|
||||||
fragDef <- fragmentDefinition definition
|
fragDef <- fragmentDefinition definition
|
||||||
case fragDef of
|
case fragDef of
|
||||||
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
|
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
|
||||||
_ -> lift $ pure Nothing
|
_ -> lift $ pure Nothing
|
||||||
| otherwise -> lift $ pure Nothing
|
| otherwise -> lift $ pure Nothing
|
||||||
selection (Full.InlineFragment type' directives' selections) = do
|
|
||||||
|
inlineFragment
|
||||||
|
:: Full.InlineFragment
|
||||||
|
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
||||||
|
inlineFragment (Full.InlineFragment type' directives' selections _) = do
|
||||||
fragmentDirectives <- Definition.selection <$> directives directives'
|
fragmentDirectives <- Definition.selection <$> directives directives'
|
||||||
case fragmentDirectives of
|
case fragmentDirectives of
|
||||||
Nothing -> pure $ Left mempty
|
Nothing -> pure $ Left mempty
|
||||||
|
@ -325,7 +310,7 @@ selection (Full.InlineFragment type' directives' selections) = do
|
||||||
Nothing -> pure $ Left fragmentSelectionSet
|
Nothing -> pure $ Left fragmentSelectionSet
|
||||||
Just typeName -> do
|
Just typeName -> do
|
||||||
types' <- gets types
|
types' <- gets types
|
||||||
case lookupTypeCondition typeName types' of
|
case Type.lookupTypeCondition typeName types' of
|
||||||
Just typeCondition -> pure $
|
Just typeCondition -> pure $
|
||||||
selectionFragment typeCondition fragmentSelectionSet
|
selectionFragment typeCondition fragmentSelectionSet
|
||||||
Nothing -> pure $ Left mempty
|
Nothing -> pure $ Left mempty
|
||||||
|
@ -346,10 +331,10 @@ appendSelection = foldM go mempty
|
||||||
directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
|
directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
|
||||||
directives = traverse directive
|
directives = traverse directive
|
||||||
where
|
where
|
||||||
directive (Full.Directive directiveName directiveArguments)
|
directive (Full.Directive directiveName directiveArguments _)
|
||||||
= Definition.Directive directiveName . Type.Arguments
|
= Definition.Directive directiveName . Type.Arguments
|
||||||
<$> foldM go HashMap.empty directiveArguments
|
<$> foldM go HashMap.empty directiveArguments
|
||||||
go arguments (Full.Argument name value') = do
|
go arguments (Full.Argument name (Full.Node value' _) _) = do
|
||||||
substitutedValue <- value value'
|
substitutedValue <- value value'
|
||||||
return $ HashMap.insert name substitutedValue arguments
|
return $ HashMap.insert name substitutedValue arguments
|
||||||
|
|
||||||
|
@ -372,7 +357,7 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do
|
||||||
fragmentSelection <- appendSelection selections
|
fragmentSelection <- appendSelection selections
|
||||||
types' <- gets types
|
types' <- gets types
|
||||||
|
|
||||||
case lookupTypeCondition type' types' of
|
case Type.lookupTypeCondition type' types' of
|
||||||
Just compositeType -> do
|
Just compositeType -> do
|
||||||
let newValue = Fragment compositeType fragmentSelection
|
let newValue = Fragment compositeType fragmentSelection
|
||||||
modify $ insertFragment newValue
|
modify $ insertFragment newValue
|
||||||
|
@ -399,7 +384,8 @@ value (Full.List list) = Type.List <$> traverse value list
|
||||||
value (Full.Object object) =
|
value (Full.Object object) =
|
||||||
Type.Object . HashMap.fromList <$> traverse objectField object
|
Type.Object . HashMap.fromList <$> traverse objectField object
|
||||||
where
|
where
|
||||||
objectField (Full.ObjectField name value') = (name,) <$> value value'
|
objectField Full.ObjectField{value = value', ..} =
|
||||||
|
(name,) <$> value (Full.node value')
|
||||||
|
|
||||||
input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
|
input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
|
||||||
input (Full.Variable name) =
|
input (Full.Variable name) =
|
||||||
|
@ -415,8 +401,8 @@ input (Full.Object object) = do
|
||||||
objectFields <- foldM objectField HashMap.empty object
|
objectFields <- foldM objectField HashMap.empty object
|
||||||
pure $ pure $ Object objectFields
|
pure $ pure $ Object objectFields
|
||||||
where
|
where
|
||||||
objectField resultMap (Full.ObjectField name value') =
|
objectField resultMap Full.ObjectField{value = value', ..} =
|
||||||
inputField resultMap name value'
|
inputField resultMap name $ Full.node value'
|
||||||
|
|
||||||
inputField :: forall m
|
inputField :: forall m
|
||||||
. HashMap Full.Name Input
|
. HashMap Full.Name Input
|
||||||
|
|
|
@ -21,6 +21,6 @@ module Language.GraphQL.Type
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Language.GraphQL.Type.Definition
|
import Language.GraphQL.Type.Definition
|
||||||
import Language.GraphQL.Type.Schema (Schema(..))
|
import Language.GraphQL.Type.Schema (Schema, schema)
|
||||||
import qualified Language.GraphQL.Type.In as In
|
import qualified Language.GraphQL.Type.In as In
|
||||||
import qualified Language.GraphQL.Type.Out as Out
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
|
|
@ -11,6 +11,7 @@
|
||||||
-- with 'Language.GraphQL.Type.Out'.
|
-- with 'Language.GraphQL.Type.Out'.
|
||||||
module Language.GraphQL.Type.In
|
module Language.GraphQL.Type.In
|
||||||
( Argument(..)
|
( Argument(..)
|
||||||
|
, Arguments
|
||||||
, InputField(..)
|
, InputField(..)
|
||||||
, InputObjectType(..)
|
, InputObjectType(..)
|
||||||
, Type(..)
|
, Type(..)
|
||||||
|
@ -24,10 +25,10 @@ module Language.GraphQL.Type.In
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Language.GraphQL.AST.Document (Name)
|
import Language.GraphQL.AST.Document (Name)
|
||||||
import Language.GraphQL.Type.Definition
|
import qualified Language.GraphQL.Type.Definition as Definition
|
||||||
|
|
||||||
-- | Single field of an 'InputObjectType'.
|
-- | Single field of an 'InputObjectType'.
|
||||||
data InputField = InputField (Maybe Text) Type (Maybe Value)
|
data InputField = InputField (Maybe Text) Type (Maybe Definition.Value)
|
||||||
|
|
||||||
-- | Input object type definition.
|
-- | Input object type definition.
|
||||||
--
|
--
|
||||||
|
@ -45,25 +46,28 @@ instance Eq InputObjectType where
|
||||||
-- type can wrap other wrapping or named types. Wrapping types are lists and
|
-- type can wrap other wrapping or named types. Wrapping types are lists and
|
||||||
-- Non-Null types (named types are nullable by default).
|
-- Non-Null types (named types are nullable by default).
|
||||||
data Type
|
data Type
|
||||||
= NamedScalarType ScalarType
|
= NamedScalarType Definition.ScalarType
|
||||||
| NamedEnumType EnumType
|
| NamedEnumType Definition.EnumType
|
||||||
| NamedInputObjectType InputObjectType
|
| NamedInputObjectType InputObjectType
|
||||||
| ListType Type
|
| ListType Type
|
||||||
| NonNullScalarType ScalarType
|
| NonNullScalarType Definition.ScalarType
|
||||||
| NonNullEnumType EnumType
|
| NonNullEnumType Definition.EnumType
|
||||||
| NonNullInputObjectType InputObjectType
|
| NonNullInputObjectType InputObjectType
|
||||||
| NonNullListType Type
|
| NonNullListType Type
|
||||||
deriving Eq
|
deriving Eq
|
||||||
|
|
||||||
-- | Field argument definition.
|
-- | Field argument definition.
|
||||||
data Argument = Argument (Maybe Text) Type (Maybe Value)
|
data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
|
||||||
|
|
||||||
|
-- | Field argument definitions.
|
||||||
|
type Arguments = HashMap Name Argument
|
||||||
|
|
||||||
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
|
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
|
||||||
pattern ScalarBaseType :: ScalarType -> Type
|
pattern ScalarBaseType :: Definition.ScalarType -> Type
|
||||||
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
|
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
|
||||||
|
|
||||||
-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
|
-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
|
||||||
pattern EnumBaseType :: EnumType -> Type
|
pattern EnumBaseType :: Definition.EnumType -> Type
|
||||||
pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
|
pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
|
||||||
|
|
||||||
-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.
|
-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.
|
||||||
|
@ -76,7 +80,7 @@ pattern ListBaseType listType <- (isListType -> Just listType)
|
||||||
|
|
||||||
{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}
|
{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}
|
||||||
|
|
||||||
isScalarType :: Type -> Maybe ScalarType
|
isScalarType :: Type -> Maybe Definition.ScalarType
|
||||||
isScalarType (NamedScalarType inputType) = Just inputType
|
isScalarType (NamedScalarType inputType) = Just inputType
|
||||||
isScalarType (NonNullScalarType inputType) = Just inputType
|
isScalarType (NonNullScalarType inputType) = Just inputType
|
||||||
isScalarType _ = Nothing
|
isScalarType _ = Nothing
|
||||||
|
@ -86,7 +90,7 @@ isInputObjectType (NamedInputObjectType inputType) = Just inputType
|
||||||
isInputObjectType (NonNullInputObjectType inputType) = Just inputType
|
isInputObjectType (NonNullInputObjectType inputType) = Just inputType
|
||||||
isInputObjectType _ = Nothing
|
isInputObjectType _ = Nothing
|
||||||
|
|
||||||
isEnumType :: Type -> Maybe EnumType
|
isEnumType :: Type -> Maybe Definition.EnumType
|
||||||
isEnumType (NamedEnumType inputType) = Just inputType
|
isEnumType (NamedEnumType inputType) = Just inputType
|
||||||
isEnumType (NonNullEnumType inputType) = Just inputType
|
isEnumType (NonNullEnumType inputType) = Just inputType
|
||||||
isEnumType _ = Nothing
|
isEnumType _ = Nothing
|
||||||
|
|
|
@ -3,23 +3,85 @@
|
||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
|
||||||
module Language.GraphQL.Type.Internal
|
module Language.GraphQL.Type.Internal
|
||||||
( AbstractType(..)
|
( AbstractType(..)
|
||||||
, CompositeType(..)
|
, CompositeType(..)
|
||||||
, collectReferencedTypes
|
, Directive(..)
|
||||||
|
, Directives
|
||||||
|
, Schema(..)
|
||||||
|
, Type(..)
|
||||||
|
, directives
|
||||||
, doesFragmentTypeApply
|
, doesFragmentTypeApply
|
||||||
, instanceOf
|
, instanceOf
|
||||||
|
, lookupInputType
|
||||||
, lookupTypeCondition
|
, lookupTypeCondition
|
||||||
|
, lookupTypeField
|
||||||
|
, mutation
|
||||||
|
, subscription
|
||||||
|
, query
|
||||||
|
, types
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Language.GraphQL.AST (Name)
|
import Data.Text (Text)
|
||||||
|
import qualified Language.GraphQL.AST as Full
|
||||||
|
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
|
||||||
import qualified Language.GraphQL.Type.Definition as Definition
|
import qualified Language.GraphQL.Type.Definition as Definition
|
||||||
import qualified Language.GraphQL.Type.In as In
|
import qualified Language.GraphQL.Type.In as In
|
||||||
import qualified Language.GraphQL.Type.Out as Out
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
import Language.GraphQL.Type.Schema
|
|
||||||
|
-- | These are all of the possible kinds of types.
|
||||||
|
data Type m
|
||||||
|
= ScalarType Definition.ScalarType
|
||||||
|
| EnumType Definition.EnumType
|
||||||
|
| ObjectType (Out.ObjectType m)
|
||||||
|
| InputObjectType In.InputObjectType
|
||||||
|
| InterfaceType (Out.InterfaceType m)
|
||||||
|
| UnionType (Out.UnionType m)
|
||||||
|
deriving Eq
|
||||||
|
|
||||||
|
-- | Directive definition.
|
||||||
|
data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments
|
||||||
|
|
||||||
|
-- | Directive definitions.
|
||||||
|
type Directives = HashMap Full.Name Directive
|
||||||
|
|
||||||
|
-- | A Schema is created by supplying the root types of each type of operation,
|
||||||
|
-- query and mutation (optional). A schema definition is then supplied to the
|
||||||
|
-- validator and executor.
|
||||||
|
--
|
||||||
|
-- __Note:__ When the schema is constructed, by default only the types that
|
||||||
|
-- are reachable by traversing the root types are included, other types must
|
||||||
|
-- be explicitly referenced.
|
||||||
|
data Schema m = Schema
|
||||||
|
(Out.ObjectType m)
|
||||||
|
(Maybe (Out.ObjectType m))
|
||||||
|
(Maybe (Out.ObjectType m))
|
||||||
|
Directives
|
||||||
|
(HashMap Full.Name (Type m))
|
||||||
|
|
||||||
|
-- | Schema query type.
|
||||||
|
query :: forall m. Schema m -> Out.ObjectType m
|
||||||
|
query (Schema query' _ _ _ _) = query'
|
||||||
|
|
||||||
|
-- | Schema mutation type.
|
||||||
|
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||||
|
mutation (Schema _ mutation' _ _ _) = mutation'
|
||||||
|
|
||||||
|
-- | Schema subscription type.
|
||||||
|
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||||
|
subscription (Schema _ _ subscription' _ _) = subscription'
|
||||||
|
|
||||||
|
-- | Schema directive definitions.
|
||||||
|
directives :: forall m. Schema m -> Directives
|
||||||
|
directives (Schema _ _ _ directives' _) = directives'
|
||||||
|
|
||||||
|
-- | Types referenced by the schema.
|
||||||
|
types :: forall m. Schema m -> HashMap Full.Name (Type m)
|
||||||
|
types (Schema _ _ _ _ types') = types'
|
||||||
|
|
||||||
-- | These types may describe the parent context of a selection set.
|
-- | These types may describe the parent context of a selection set.
|
||||||
data CompositeType m
|
data CompositeType m
|
||||||
|
@ -34,65 +96,6 @@ data AbstractType m
|
||||||
| AbstractInterfaceType (Out.InterfaceType m)
|
| AbstractInterfaceType (Out.InterfaceType m)
|
||||||
deriving Eq
|
deriving Eq
|
||||||
|
|
||||||
-- | Traverses the schema and finds all referenced types.
|
|
||||||
collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
|
|
||||||
collectReferencedTypes schema =
|
|
||||||
let queryTypes = traverseObjectType (query schema) HashMap.empty
|
|
||||||
in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
|
|
||||||
where
|
|
||||||
collect traverser typeName element foundTypes
|
|
||||||
| HashMap.member typeName foundTypes = foundTypes
|
|
||||||
| otherwise = traverser $ HashMap.insert typeName element foundTypes
|
|
||||||
visitFields (Out.Field _ outputType arguments) foundTypes
|
|
||||||
= traverseOutputType outputType
|
|
||||||
$ foldr visitArguments foundTypes arguments
|
|
||||||
visitArguments (In.Argument _ inputType _) = traverseInputType inputType
|
|
||||||
visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
|
|
||||||
getField (Out.ValueResolver field _) = field
|
|
||||||
getField (Out.EventStreamResolver field _ _) = field
|
|
||||||
traverseInputType (In.InputObjectBaseType objectType) =
|
|
||||||
let (In.InputObjectType typeName _ inputFields) = objectType
|
|
||||||
element = InputObjectType objectType
|
|
||||||
traverser = flip (foldr visitInputFields) inputFields
|
|
||||||
in collect traverser typeName element
|
|
||||||
traverseInputType (In.ListBaseType listType) =
|
|
||||||
traverseInputType listType
|
|
||||||
traverseInputType (In.ScalarBaseType scalarType) =
|
|
||||||
let (Definition.ScalarType typeName _) = scalarType
|
|
||||||
in collect Prelude.id typeName (ScalarType scalarType)
|
|
||||||
traverseInputType (In.EnumBaseType enumType) =
|
|
||||||
let (Definition.EnumType typeName _ _) = enumType
|
|
||||||
in collect Prelude.id typeName (EnumType enumType)
|
|
||||||
traverseOutputType (Out.ObjectBaseType objectType) =
|
|
||||||
traverseObjectType objectType
|
|
||||||
traverseOutputType (Out.InterfaceBaseType interfaceType) =
|
|
||||||
traverseInterfaceType interfaceType
|
|
||||||
traverseOutputType (Out.UnionBaseType unionType) =
|
|
||||||
let (Out.UnionType typeName _ types) = unionType
|
|
||||||
traverser = flip (foldr traverseObjectType) types
|
|
||||||
in collect traverser typeName (UnionType unionType)
|
|
||||||
traverseOutputType (Out.ListBaseType listType) =
|
|
||||||
traverseOutputType listType
|
|
||||||
traverseOutputType (Out.ScalarBaseType scalarType) =
|
|
||||||
let (Definition.ScalarType typeName _) = scalarType
|
|
||||||
in collect Prelude.id typeName (ScalarType scalarType)
|
|
||||||
traverseOutputType (Out.EnumBaseType enumType) =
|
|
||||||
let (Definition.EnumType typeName _ _) = enumType
|
|
||||||
in collect Prelude.id typeName (EnumType enumType)
|
|
||||||
traverseObjectType objectType foundTypes =
|
|
||||||
let (Out.ObjectType typeName _ interfaces fields) = objectType
|
|
||||||
element = ObjectType objectType
|
|
||||||
traverser = polymorphicTraverser interfaces (getField <$> fields)
|
|
||||||
in collect traverser typeName element foundTypes
|
|
||||||
traverseInterfaceType interfaceType foundTypes =
|
|
||||||
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
|
|
||||||
element = InterfaceType interfaceType
|
|
||||||
traverser = polymorphicTraverser interfaces fields
|
|
||||||
in collect traverser typeName element foundTypes
|
|
||||||
polymorphicTraverser interfaces fields
|
|
||||||
= flip (foldr visitFields) fields
|
|
||||||
. flip (foldr traverseInterfaceType) interfaces
|
|
||||||
|
|
||||||
doesFragmentTypeApply :: forall m
|
doesFragmentTypeApply :: forall m
|
||||||
. CompositeType m
|
. CompositeType m
|
||||||
-> Out.ObjectType m
|
-> Out.ObjectType m
|
||||||
|
@ -118,13 +121,56 @@ instanceOf objectType (AbstractUnionType unionType) =
|
||||||
go unionMemberType acc = acc || objectType == unionMemberType
|
go unionMemberType acc = acc || objectType == unionMemberType
|
||||||
|
|
||||||
lookupTypeCondition :: forall m
|
lookupTypeCondition :: forall m
|
||||||
. Name
|
. Full.Name
|
||||||
-> HashMap Name (Type m)
|
-> HashMap Full.Name (Type m)
|
||||||
-> Maybe (CompositeType m)
|
-> Maybe (CompositeType m)
|
||||||
lookupTypeCondition type' types' =
|
lookupTypeCondition type' types' =
|
||||||
case HashMap.lookup type' types' of
|
case HashMap.lookup type' types' of
|
||||||
Just (ObjectType objectType) -> Just $ CompositeObjectType objectType
|
Just (ObjectType objectType) ->
|
||||||
|
Just $ CompositeObjectType objectType
|
||||||
Just (UnionType unionType) -> Just $ CompositeUnionType unionType
|
Just (UnionType unionType) -> Just $ CompositeUnionType unionType
|
||||||
Just (InterfaceType interfaceType) ->
|
Just (InterfaceType interfaceType) ->
|
||||||
Just $ CompositeInterfaceType interfaceType
|
Just $ CompositeInterfaceType interfaceType
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
lookupInputType :: Full.Type -> HashMap Full.Name (Type m) -> Maybe In.Type
|
||||||
|
lookupInputType (Full.TypeNamed name) types' =
|
||||||
|
case HashMap.lookup name types' of
|
||||||
|
Just (ScalarType scalarType) ->
|
||||||
|
Just $ In.NamedScalarType scalarType
|
||||||
|
Just (EnumType enumType) ->
|
||||||
|
Just $ In.NamedEnumType enumType
|
||||||
|
Just (InputObjectType objectType) ->
|
||||||
|
Just $ In.NamedInputObjectType objectType
|
||||||
|
_ -> Nothing
|
||||||
|
lookupInputType (Full.TypeList list) types'
|
||||||
|
= In.ListType
|
||||||
|
<$> lookupInputType list types'
|
||||||
|
lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types' =
|
||||||
|
case HashMap.lookup nonNull types' of
|
||||||
|
Just (ScalarType scalarType) ->
|
||||||
|
Just $ In.NonNullScalarType scalarType
|
||||||
|
Just (EnumType enumType) ->
|
||||||
|
Just $ In.NonNullEnumType enumType
|
||||||
|
Just (InputObjectType objectType) ->
|
||||||
|
Just $ In.NonNullInputObjectType objectType
|
||||||
|
_ -> Nothing
|
||||||
|
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types'
|
||||||
|
= In.NonNullListType
|
||||||
|
<$> lookupInputType nonNull types'
|
||||||
|
|
||||||
|
lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)
|
||||||
|
lookupTypeField fieldName = \case
|
||||||
|
Out.ObjectBaseType objectType ->
|
||||||
|
objectChild objectType
|
||||||
|
Out.InterfaceBaseType interfaceType ->
|
||||||
|
interfaceChild interfaceType
|
||||||
|
Out.ListBaseType listType -> lookupTypeField fieldName listType
|
||||||
|
_ -> Nothing
|
||||||
|
where
|
||||||
|
objectChild (Out.ObjectType _ _ _ resolvers) =
|
||||||
|
resolverType <$> HashMap.lookup fieldName resolvers
|
||||||
|
interfaceChild (Out.InterfaceType _ _ _ fields) =
|
||||||
|
HashMap.lookup fieldName fields
|
||||||
|
resolverType (Out.ValueResolver objectField _) = objectField
|
||||||
|
resolverType (Out.EventStreamResolver objectField _ _) = objectField
|
||||||
|
|
|
@ -76,7 +76,7 @@ instance forall a. Eq (UnionType a) where
|
||||||
data Field m = Field
|
data Field m = Field
|
||||||
(Maybe Text) -- ^ Description.
|
(Maybe Text) -- ^ Description.
|
||||||
(Type m) -- ^ Field type.
|
(Type m) -- ^ Field type.
|
||||||
(HashMap Name In.Argument) -- ^ Arguments.
|
In.Arguments -- ^ Arguments.
|
||||||
|
|
||||||
-- | These types may be used as output types as the result of fields.
|
-- | These types may be used as output types as the result of fields.
|
||||||
--
|
--
|
||||||
|
|
|
@ -2,36 +2,154 @@
|
||||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
||||||
-- functions for defining and manipulating schemas.
|
-- functions for defining and manipulating schemas.
|
||||||
module Language.GraphQL.Type.Schema
|
module Language.GraphQL.Type.Schema
|
||||||
( Schema(..)
|
( schema
|
||||||
, Type(..)
|
, module Language.GraphQL.Type.Internal
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
|
||||||
|
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||||
|
import qualified Language.GraphQL.AST as Full
|
||||||
|
import Language.GraphQL.Type.Internal
|
||||||
|
( Directive(..)
|
||||||
|
, Directives
|
||||||
|
, Schema
|
||||||
|
, Type(..)
|
||||||
|
, directives
|
||||||
|
, mutation
|
||||||
|
, subscription
|
||||||
|
, query
|
||||||
|
, types
|
||||||
|
)
|
||||||
import qualified Language.GraphQL.Type.Definition as Definition
|
import qualified Language.GraphQL.Type.Definition as Definition
|
||||||
|
import qualified Language.GraphQL.Type.Internal as Internal
|
||||||
import qualified Language.GraphQL.Type.In as In
|
import qualified Language.GraphQL.Type.In as In
|
||||||
import qualified Language.GraphQL.Type.Out as Out
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
|
||||||
-- | These are all of the possible kinds of types.
|
-- | Schema constructor.
|
||||||
data Type m
|
schema :: forall m
|
||||||
= ScalarType Definition.ScalarType
|
. Out.ObjectType m -- ^ Query type.
|
||||||
| EnumType Definition.EnumType
|
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
|
||||||
| ObjectType (Out.ObjectType m)
|
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
|
||||||
| InputObjectType In.InputObjectType
|
-> Directives -- ^ Directive definitions.
|
||||||
| InterfaceType (Out.InterfaceType m)
|
-> Schema m -- ^ Schema.
|
||||||
| UnionType (Out.UnionType m)
|
schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
|
||||||
deriving Eq
|
Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes
|
||||||
|
where
|
||||||
|
collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot
|
||||||
|
allDirectives = HashMap.union directiveDefinitions defaultDirectives
|
||||||
|
defaultDirectives = HashMap.fromList
|
||||||
|
[ ("skip", skipDirective)
|
||||||
|
, ("include", includeDirective)
|
||||||
|
, ("deprecated", deprecatedDirective)
|
||||||
|
]
|
||||||
|
includeDirective =
|
||||||
|
Directive includeDescription skipIncludeLocations includeArguments
|
||||||
|
includeArguments = HashMap.singleton "if"
|
||||||
|
$ In.Argument (Just "Included when true.") ifType Nothing
|
||||||
|
includeDescription = Just
|
||||||
|
"Directs the executor to include this field or fragment only when the \
|
||||||
|
\`if` argument is true."
|
||||||
|
skipDirective = Directive skipDescription skipIncludeLocations skipArguments
|
||||||
|
skipArguments = HashMap.singleton "if"
|
||||||
|
$ In.Argument (Just "skipped when true.") ifType Nothing
|
||||||
|
ifType = In.NonNullScalarType Definition.boolean
|
||||||
|
skipDescription = Just
|
||||||
|
"Directs the executor to skip this field or fragment when the `if` \
|
||||||
|
\argument is true."
|
||||||
|
skipIncludeLocations =
|
||||||
|
[ ExecutableDirectiveLocation DirectiveLocation.Field
|
||||||
|
, ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
|
||||||
|
, ExecutableDirectiveLocation DirectiveLocation.InlineFragment
|
||||||
|
]
|
||||||
|
deprecatedDirective =
|
||||||
|
Directive deprecatedDescription deprecatedLocations deprecatedArguments
|
||||||
|
reasonDescription = Just
|
||||||
|
"Explains why this element was deprecated, usually also including a \
|
||||||
|
\suggestion for how to access supported similar data. Formatted using \
|
||||||
|
\the Markdown syntax, as specified by \
|
||||||
|
\[CommonMark](https://commonmark.org/).'"
|
||||||
|
deprecatedArguments = HashMap.singleton "reason"
|
||||||
|
$ In.Argument reasonDescription reasonType
|
||||||
|
$ Just "No longer supported"
|
||||||
|
reasonType = In.NamedScalarType Definition.string
|
||||||
|
deprecatedDescription = Just
|
||||||
|
"Marks an element of a GraphQL schema as no longer supported."
|
||||||
|
deprecatedLocations =
|
||||||
|
[ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
|
||||||
|
, TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
|
||||||
|
, TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
|
||||||
|
, TypeSystemDirectiveLocation DirectiveLocation.EnumValue
|
||||||
|
]
|
||||||
|
|
||||||
-- | A Schema is created by supplying the root types of each type of operation,
|
-- | Traverses the schema and finds all referenced types.
|
||||||
-- query and mutation (optional). A schema definition is then supplied to the
|
collectReferencedTypes :: forall m
|
||||||
-- validator and executor.
|
. Out.ObjectType m
|
||||||
--
|
-> Maybe (Out.ObjectType m)
|
||||||
-- __Note:__ When the schema is constructed, by default only the types that
|
-> Maybe (Out.ObjectType m)
|
||||||
-- are reachable by traversing the root types are included, other types must
|
-> HashMap Full.Name (Type m)
|
||||||
-- be explicitly referenced.
|
collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
|
||||||
data Schema m = Schema
|
let queryTypes = traverseObjectType queryRoot HashMap.empty
|
||||||
{ query :: Out.ObjectType m
|
mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
|
||||||
, mutation :: Maybe (Out.ObjectType m)
|
mutationRoot
|
||||||
, subscription :: Maybe (Out.ObjectType m)
|
in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot
|
||||||
}
|
where
|
||||||
|
collect traverser typeName element foundTypes
|
||||||
|
| HashMap.member typeName foundTypes = foundTypes
|
||||||
|
| otherwise = traverser $ HashMap.insert typeName element foundTypes
|
||||||
|
visitFields (Out.Field _ outputType arguments) foundTypes
|
||||||
|
= traverseOutputType outputType
|
||||||
|
$ foldr visitArguments foundTypes arguments
|
||||||
|
visitArguments (In.Argument _ inputType _) = traverseInputType inputType
|
||||||
|
visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
|
||||||
|
getField (Out.ValueResolver field _) = field
|
||||||
|
getField (Out.EventStreamResolver field _ _) = field
|
||||||
|
traverseInputType (In.InputObjectBaseType objectType) =
|
||||||
|
let In.InputObjectType typeName _ inputFields = objectType
|
||||||
|
element = InputObjectType objectType
|
||||||
|
traverser = flip (foldr visitInputFields) inputFields
|
||||||
|
in collect traverser typeName element
|
||||||
|
traverseInputType (In.ListBaseType listType) =
|
||||||
|
traverseInputType listType
|
||||||
|
traverseInputType (In.ScalarBaseType scalarType) =
|
||||||
|
let Definition.ScalarType typeName _ = scalarType
|
||||||
|
in collect Prelude.id typeName (ScalarType scalarType)
|
||||||
|
traverseInputType (In.EnumBaseType enumType) =
|
||||||
|
let Definition.EnumType typeName _ _ = enumType
|
||||||
|
in collect Prelude.id typeName (EnumType enumType)
|
||||||
|
traverseOutputType (Out.ObjectBaseType objectType) =
|
||||||
|
traverseObjectType objectType
|
||||||
|
traverseOutputType (Out.InterfaceBaseType interfaceType) =
|
||||||
|
traverseInterfaceType interfaceType
|
||||||
|
traverseOutputType (Out.UnionBaseType unionType) =
|
||||||
|
let Out.UnionType typeName _ types' = unionType
|
||||||
|
traverser = flip (foldr traverseObjectType) types'
|
||||||
|
in collect traverser typeName (UnionType unionType)
|
||||||
|
traverseOutputType (Out.ListBaseType listType) =
|
||||||
|
traverseOutputType listType
|
||||||
|
traverseOutputType (Out.ScalarBaseType scalarType) =
|
||||||
|
let Definition.ScalarType typeName _ = scalarType
|
||||||
|
in collect Prelude.id typeName (ScalarType scalarType)
|
||||||
|
traverseOutputType (Out.EnumBaseType enumType) =
|
||||||
|
let Definition.EnumType typeName _ _ = enumType
|
||||||
|
in collect Prelude.id typeName (EnumType enumType)
|
||||||
|
traverseObjectType objectType foundTypes =
|
||||||
|
let Out.ObjectType typeName _ interfaces fields = objectType
|
||||||
|
element = ObjectType objectType
|
||||||
|
traverser = polymorphicTraverser interfaces (getField <$> fields)
|
||||||
|
in collect traverser typeName element foundTypes
|
||||||
|
traverseInterfaceType interfaceType foundTypes =
|
||||||
|
let Out.InterfaceType typeName _ interfaces fields = interfaceType
|
||||||
|
element = InterfaceType interfaceType
|
||||||
|
traverser = polymorphicTraverser interfaces fields
|
||||||
|
in collect traverser typeName element foundTypes
|
||||||
|
polymorphicTraverser interfaces fields
|
||||||
|
= flip (foldr visitFields) fields
|
||||||
|
. flip (foldr traverseInterfaceType) interfaces
|
||||||
|
|
|
@ -2,80 +2,505 @@
|
||||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
-- | GraphQL validator.
|
-- | GraphQL validator.
|
||||||
module Language.GraphQL.Validate
|
module Language.GraphQL.Validate
|
||||||
( Error(..)
|
( Validation.Error(..)
|
||||||
, Path(..)
|
|
||||||
, document
|
, document
|
||||||
, module Language.GraphQL.Validate.Rules
|
, module Language.GraphQL.Validate.Rules
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad (foldM)
|
import Control.Monad (join)
|
||||||
import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
|
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||||
import Data.Foldable (foldrM)
|
import Control.Monad.Trans.Reader (runReaderT)
|
||||||
|
import Data.Foldable (toList)
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.Sequence (Seq(..), (><), (|>))
|
import Data.Sequence (Seq(..), (><), (|>))
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
import Language.GraphQL.AST.Document
|
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
|
||||||
import Language.GraphQL.Type.Internal
|
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||||
import Language.GraphQL.Type.Schema (Schema(..))
|
import qualified Language.GraphQL.AST.Document as Full
|
||||||
|
import qualified Language.GraphQL.Type.Internal as Type
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
import Language.GraphQL.Type.Schema (Schema)
|
||||||
|
import qualified Language.GraphQL.Type.Schema as Schema
|
||||||
import Language.GraphQL.Validate.Rules
|
import Language.GraphQL.Validate.Rules
|
||||||
import Language.GraphQL.Validate.Validation
|
import Language.GraphQL.Validate.Validation (Validation(Validation))
|
||||||
|
import qualified Language.GraphQL.Validate.Validation as Validation
|
||||||
|
|
||||||
type ValidateT m = Reader (Validation m) (Seq Error)
|
type ApplySelectionRule m a
|
||||||
|
= HashMap Full.Name (Schema.Type m)
|
||||||
|
-> Validation.Rule m
|
||||||
|
-> Maybe (Out.Type m)
|
||||||
|
-> a
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
|
||||||
|
type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.RuleT m)
|
||||||
|
|
||||||
-- | Validates a document and returns a list of found errors. If the returned
|
-- | Validates a document and returns a list of found errors. If the returned
|
||||||
-- list is empty, the document is valid.
|
-- list is empty, the document is valid.
|
||||||
document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
|
document :: forall m
|
||||||
|
. Schema m
|
||||||
|
-> [Validation.Rule m]
|
||||||
|
-> Full.Document
|
||||||
|
-> Seq Validation.Error
|
||||||
document schema' rules' document' =
|
document schema' rules' document' =
|
||||||
runReader (foldrM go Seq.empty document') context
|
runReaderT reader context
|
||||||
where
|
where
|
||||||
context = Validation
|
context = Validation
|
||||||
{ ast = document'
|
{ Validation.ast = document'
|
||||||
, schema = schema'
|
, Validation.schema = schema'
|
||||||
, types = collectReferencedTypes schema'
|
|
||||||
, rules = rules'
|
|
||||||
}
|
}
|
||||||
go definition' accumulator = (accumulator ><) <$> definition definition'
|
reader = do
|
||||||
|
rule' <- lift $ Seq.fromList rules'
|
||||||
|
join $ lift $ foldr (definition rule' context) Seq.empty document'
|
||||||
|
|
||||||
definition :: forall m. Definition -> ValidateT m
|
definition :: Validation.Rule m
|
||||||
definition = \case
|
-> Validation m
|
||||||
definition'@(ExecutableDefinition executableDefinition') -> do
|
-> Full.Definition
|
||||||
applied <- applyRules definition'
|
-> Seq (Validation.RuleT m)
|
||||||
children <- executableDefinition executableDefinition'
|
-> Seq (Validation.RuleT m)
|
||||||
pure $ children >< applied
|
definition (Validation.DefinitionRule rule) _ definition' accumulator =
|
||||||
definition' -> applyRules definition'
|
accumulator |> rule definition'
|
||||||
|
definition rule context (Full.ExecutableDefinition definition') accumulator =
|
||||||
|
accumulator >< executableDefinition rule context definition'
|
||||||
|
definition rule context (Full.TypeSystemDefinition typeSystemDefinition' _) accumulator =
|
||||||
|
accumulator >< typeSystemDefinition context rule typeSystemDefinition'
|
||||||
|
definition rule context (Full.TypeSystemExtension extension _) accumulator =
|
||||||
|
accumulator >< typeSystemExtension context rule extension
|
||||||
|
|
||||||
|
typeSystemExtension :: forall m
|
||||||
|
. Validation m
|
||||||
|
-> ApplyRule m Full.TypeSystemExtension
|
||||||
|
typeSystemExtension context rule = \case
|
||||||
|
Full.SchemaExtension extension -> schemaExtension context rule extension
|
||||||
|
Full.TypeExtension extension -> typeExtension context rule extension
|
||||||
|
|
||||||
|
typeExtension :: forall m. Validation m -> ApplyRule m Full.TypeExtension
|
||||||
|
typeExtension context rule = \case
|
||||||
|
Full.ScalarTypeExtension _ directives' ->
|
||||||
|
directives context rule scalarLocation directives'
|
||||||
|
Full.ObjectTypeFieldsDefinitionExtension _ _ directives' fields
|
||||||
|
-> directives context rule objectLocation directives'
|
||||||
|
>< foldMap (fieldDefinition context rule) fields
|
||||||
|
Full.ObjectTypeDirectivesExtension _ _ directives' ->
|
||||||
|
directives context rule objectLocation directives'
|
||||||
|
Full.ObjectTypeImplementsInterfacesExtension _ _ -> mempty
|
||||||
|
Full.InterfaceTypeFieldsDefinitionExtension _ directives' fields
|
||||||
|
-> directives context rule interfaceLocation directives'
|
||||||
|
>< foldMap (fieldDefinition context rule) fields
|
||||||
|
Full.InterfaceTypeDirectivesExtension _ directives' ->
|
||||||
|
directives context rule interfaceLocation directives'
|
||||||
|
Full.UnionTypeUnionMemberTypesExtension _ directives' _ ->
|
||||||
|
directives context rule unionLocation directives'
|
||||||
|
Full.UnionTypeDirectivesExtension _ directives' ->
|
||||||
|
directives context rule unionLocation directives'
|
||||||
|
Full.EnumTypeEnumValuesDefinitionExtension _ directives' values
|
||||||
|
-> directives context rule enumLocation directives'
|
||||||
|
>< foldMap (enumValueDefinition context rule) values
|
||||||
|
Full.EnumTypeDirectivesExtension _ directives' ->
|
||||||
|
directives context rule enumLocation directives'
|
||||||
|
Full.InputObjectTypeInputFieldsDefinitionExtension _ directives' fields
|
||||||
|
-> directives context rule inputObjectLocation directives'
|
||||||
|
>< foldMap forEachInputFieldDefinition fields
|
||||||
|
Full.InputObjectTypeDirectivesExtension _ directives' ->
|
||||||
|
directives context rule inputObjectLocation directives'
|
||||||
where
|
where
|
||||||
applyRules definition' =
|
forEachInputFieldDefinition =
|
||||||
asks rules >>= foldM (ruleFilter definition') Seq.empty
|
inputValueDefinition context rule inputFieldDefinitionLocation
|
||||||
ruleFilter definition' accumulator (DefinitionRule rule) =
|
|
||||||
mapReaderT (runRule accumulator) $ rule definition'
|
|
||||||
ruleFilter _ accumulator _ = pure accumulator
|
|
||||||
|
|
||||||
runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
|
schemaExtension :: forall m. Validation m -> ApplyRule m Full.SchemaExtension
|
||||||
runRule accumulator (Just error') = pure $ accumulator |> error'
|
schemaExtension context rule = \case
|
||||||
runRule accumulator Nothing = pure accumulator
|
Full.SchemaOperationExtension directives' _ ->
|
||||||
|
directives context rule schemaLocation directives'
|
||||||
|
Full.SchemaDirectivesExtension directives' ->
|
||||||
|
directives context rule schemaLocation directives'
|
||||||
|
|
||||||
executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
|
schemaLocation :: DirectiveLocation
|
||||||
executableDefinition (DefinitionOperation definition') =
|
schemaLocation = TypeSystemDirectiveLocation DirectiveLocation.Schema
|
||||||
operationDefinition definition'
|
|
||||||
executableDefinition (DefinitionFragment definition') =
|
|
||||||
fragmentDefinition definition'
|
|
||||||
|
|
||||||
operationDefinition :: forall m. OperationDefinition -> ValidateT m
|
interfaceLocation :: DirectiveLocation
|
||||||
operationDefinition operation =
|
interfaceLocation = TypeSystemDirectiveLocation DirectiveLocation.Interface
|
||||||
asks rules >>= foldM ruleFilter Seq.empty
|
|
||||||
|
objectLocation :: DirectiveLocation
|
||||||
|
objectLocation = TypeSystemDirectiveLocation DirectiveLocation.Object
|
||||||
|
|
||||||
|
unionLocation :: DirectiveLocation
|
||||||
|
unionLocation = TypeSystemDirectiveLocation DirectiveLocation.Union
|
||||||
|
|
||||||
|
enumLocation :: DirectiveLocation
|
||||||
|
enumLocation = TypeSystemDirectiveLocation DirectiveLocation.Enum
|
||||||
|
|
||||||
|
inputObjectLocation :: DirectiveLocation
|
||||||
|
inputObjectLocation = TypeSystemDirectiveLocation DirectiveLocation.InputObject
|
||||||
|
|
||||||
|
scalarLocation :: DirectiveLocation
|
||||||
|
scalarLocation = TypeSystemDirectiveLocation DirectiveLocation.Scalar
|
||||||
|
|
||||||
|
enumValueLocation :: DirectiveLocation
|
||||||
|
enumValueLocation = TypeSystemDirectiveLocation DirectiveLocation.EnumValue
|
||||||
|
|
||||||
|
fieldDefinitionLocation :: DirectiveLocation
|
||||||
|
fieldDefinitionLocation =
|
||||||
|
TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
|
||||||
|
|
||||||
|
inputFieldDefinitionLocation :: DirectiveLocation
|
||||||
|
inputFieldDefinitionLocation =
|
||||||
|
TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
|
||||||
|
|
||||||
|
argumentDefinitionLocation :: DirectiveLocation
|
||||||
|
argumentDefinitionLocation =
|
||||||
|
TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
|
||||||
|
|
||||||
|
queryLocation :: DirectiveLocation
|
||||||
|
queryLocation = ExecutableDirectiveLocation DirectiveLocation.Query
|
||||||
|
|
||||||
|
mutationLocation :: DirectiveLocation
|
||||||
|
mutationLocation = ExecutableDirectiveLocation DirectiveLocation.Mutation
|
||||||
|
|
||||||
|
subscriptionLocation :: DirectiveLocation
|
||||||
|
subscriptionLocation =
|
||||||
|
ExecutableDirectiveLocation DirectiveLocation.Subscription
|
||||||
|
|
||||||
|
fieldLocation :: DirectiveLocation
|
||||||
|
fieldLocation = ExecutableDirectiveLocation DirectiveLocation.Field
|
||||||
|
|
||||||
|
fragmentDefinitionLocation :: DirectiveLocation
|
||||||
|
fragmentDefinitionLocation =
|
||||||
|
ExecutableDirectiveLocation DirectiveLocation.FragmentDefinition
|
||||||
|
|
||||||
|
fragmentSpreadLocation :: DirectiveLocation
|
||||||
|
fragmentSpreadLocation =
|
||||||
|
ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
|
||||||
|
|
||||||
|
inlineFragmentLocation :: DirectiveLocation
|
||||||
|
inlineFragmentLocation =
|
||||||
|
ExecutableDirectiveLocation DirectiveLocation.InlineFragment
|
||||||
|
|
||||||
|
executableDefinition :: forall m
|
||||||
|
. Validation.Rule m
|
||||||
|
-> Validation m
|
||||||
|
-> Full.ExecutableDefinition
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
executableDefinition rule context (Full.DefinitionOperation operation) =
|
||||||
|
operationDefinition rule context operation
|
||||||
|
executableDefinition rule context (Full.DefinitionFragment fragment) =
|
||||||
|
fragmentDefinition rule context fragment
|
||||||
|
|
||||||
|
typeSystemDefinition :: forall m
|
||||||
|
. Validation m
|
||||||
|
-> ApplyRule m Full.TypeSystemDefinition
|
||||||
|
typeSystemDefinition context rule = \case
|
||||||
|
Full.SchemaDefinition directives' _ ->
|
||||||
|
directives context rule schemaLocation directives'
|
||||||
|
Full.TypeDefinition typeDefinition' ->
|
||||||
|
typeDefinition context rule typeDefinition'
|
||||||
|
Full.DirectiveDefinition _ _ arguments' _ ->
|
||||||
|
argumentsDefinition context rule arguments'
|
||||||
|
|
||||||
|
typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
|
||||||
|
typeDefinition context rule = \case
|
||||||
|
Full.ScalarTypeDefinition _ _ directives' ->
|
||||||
|
directives context rule scalarLocation directives'
|
||||||
|
Full.ObjectTypeDefinition _ _ _ directives' fields
|
||||||
|
-> directives context rule objectLocation directives'
|
||||||
|
>< foldMap (fieldDefinition context rule) fields
|
||||||
|
Full.InterfaceTypeDefinition _ _ directives' fields
|
||||||
|
-> directives context rule interfaceLocation directives'
|
||||||
|
>< foldMap (fieldDefinition context rule) fields
|
||||||
|
Full.UnionTypeDefinition _ _ directives' _ ->
|
||||||
|
directives context rule unionLocation directives'
|
||||||
|
Full.EnumTypeDefinition _ _ directives' values
|
||||||
|
-> directives context rule enumLocation directives'
|
||||||
|
>< foldMap (enumValueDefinition context rule) values
|
||||||
|
Full.InputObjectTypeDefinition _ _ directives' fields
|
||||||
|
-> directives context rule inputObjectLocation directives'
|
||||||
|
<> foldMap forEachInputFieldDefinition fields
|
||||||
where
|
where
|
||||||
ruleFilter accumulator (OperationDefinitionRule rule) =
|
forEachInputFieldDefinition =
|
||||||
mapReaderT (runRule accumulator) $ rule operation
|
inputValueDefinition context rule inputFieldDefinitionLocation
|
||||||
ruleFilter accumulator _ = pure accumulator
|
|
||||||
|
|
||||||
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
|
enumValueDefinition :: forall m
|
||||||
fragmentDefinition fragment =
|
. Validation m
|
||||||
asks rules >>= foldM ruleFilter Seq.empty
|
-> ApplyRule m Full.EnumValueDefinition
|
||||||
|
enumValueDefinition context rule (Full.EnumValueDefinition _ _ directives') =
|
||||||
|
directives context rule enumValueLocation directives'
|
||||||
|
|
||||||
|
fieldDefinition :: forall m. Validation m -> ApplyRule m Full.FieldDefinition
|
||||||
|
fieldDefinition context rule (Full.FieldDefinition _ _ arguments' _ directives')
|
||||||
|
= directives context rule fieldDefinitionLocation directives'
|
||||||
|
>< argumentsDefinition context rule arguments'
|
||||||
|
|
||||||
|
argumentsDefinition :: forall m
|
||||||
|
. Validation m
|
||||||
|
-> ApplyRule m Full.ArgumentsDefinition
|
||||||
|
argumentsDefinition context rule (Full.ArgumentsDefinition definitions) =
|
||||||
|
foldMap forEachArgument definitions
|
||||||
where
|
where
|
||||||
ruleFilter accumulator (FragmentDefinitionRule rule) =
|
forEachArgument =
|
||||||
mapReaderT (runRule accumulator) $ rule fragment
|
inputValueDefinition context rule argumentDefinitionLocation
|
||||||
ruleFilter accumulator _ = pure accumulator
|
|
||||||
|
inputValueDefinition :: forall m
|
||||||
|
. Validation m
|
||||||
|
-> Validation.Rule m
|
||||||
|
-> DirectiveLocation
|
||||||
|
-> Full.InputValueDefinition
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
inputValueDefinition context rule directiveLocation definition' =
|
||||||
|
let Full.InputValueDefinition _ _ _ _ directives' = definition'
|
||||||
|
in directives context rule directiveLocation directives'
|
||||||
|
|
||||||
|
operationDefinition :: forall m
|
||||||
|
. Validation.Rule m
|
||||||
|
-> Validation m
|
||||||
|
-> Full.OperationDefinition
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
operationDefinition rule context operation
|
||||||
|
| Validation.OperationDefinitionRule operationRule <- rule =
|
||||||
|
pure $ operationRule operation
|
||||||
|
| Validation.VariablesRule variablesRule <- rule
|
||||||
|
, Full.OperationDefinition _ _ variables _ _ _ <- operation =
|
||||||
|
foldMap (variableDefinition context rule) variables |> variablesRule variables
|
||||||
|
| Full.SelectionSet selections _ <- operation =
|
||||||
|
selectionSet context types' rule queryRoot selections
|
||||||
|
| Full.OperationDefinition Full.Query _ _ directives' selections _ <- operation
|
||||||
|
= selectionSet context types' rule queryRoot selections
|
||||||
|
>< directives context rule queryLocation directives'
|
||||||
|
| Full.OperationDefinition Full.Mutation _ _ directives' selections _ <- operation =
|
||||||
|
let root = Out.NamedObjectType <$> Schema.mutation schema'
|
||||||
|
in selectionSet context types' rule root selections
|
||||||
|
>< directives context rule mutationLocation directives'
|
||||||
|
| Full.OperationDefinition Full.Subscription _ _ directives' selections _ <- operation =
|
||||||
|
let root = Out.NamedObjectType <$> Schema.subscription schema'
|
||||||
|
in selectionSet context types' rule root selections
|
||||||
|
>< directives context rule subscriptionLocation directives'
|
||||||
|
where
|
||||||
|
schema' = Validation.schema context
|
||||||
|
queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'
|
||||||
|
types' = Schema.types schema'
|
||||||
|
|
||||||
|
typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
|
||||||
|
typeToOut (Schema.ObjectType objectType) =
|
||||||
|
Just $ Out.NamedObjectType objectType
|
||||||
|
typeToOut (Schema.InterfaceType interfaceType) =
|
||||||
|
Just $ Out.NamedInterfaceType interfaceType
|
||||||
|
typeToOut (Schema.UnionType unionType) = Just $ Out.NamedUnionType unionType
|
||||||
|
typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType
|
||||||
|
typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
|
||||||
|
typeToOut _ = Nothing
|
||||||
|
|
||||||
|
variableDefinition :: forall m
|
||||||
|
. Validation m
|
||||||
|
-> ApplyRule m Full.VariableDefinition
|
||||||
|
variableDefinition context rule (Full.VariableDefinition _ typeName value' _)
|
||||||
|
| Just defaultValue' <- value'
|
||||||
|
, types <- Schema.types $ Validation.schema context
|
||||||
|
, variableType <- Type.lookupInputType typeName types =
|
||||||
|
constValue rule variableType defaultValue'
|
||||||
|
variableDefinition _ _ _ = mempty
|
||||||
|
|
||||||
|
constValue :: forall m
|
||||||
|
. Validation.Rule m
|
||||||
|
-> Maybe In.Type
|
||||||
|
-> Full.Node Full.ConstValue
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
constValue (Validation.ValueRule _ rule) valueType = go valueType
|
||||||
|
where
|
||||||
|
go inputObjectType value'@(Full.Node (Full.ConstObject fields) _)
|
||||||
|
= foldMap (forEach inputObjectType) (Seq.fromList fields)
|
||||||
|
|> rule inputObjectType value'
|
||||||
|
go listType value'@(Full.Node (Full.ConstList values) location')
|
||||||
|
= embedListLocation go listType values location'
|
||||||
|
|> rule listType value'
|
||||||
|
go anotherValue value' = pure $ rule anotherValue value'
|
||||||
|
forEach inputObjectType Full.ObjectField{value = value', ..} =
|
||||||
|
go (valueTypeByName name inputObjectType) value'
|
||||||
|
constValue _ _ = const mempty
|
||||||
|
|
||||||
|
inputFieldType :: In.InputField -> In.Type
|
||||||
|
inputFieldType (In.InputField _ inputFieldType' _) = inputFieldType'
|
||||||
|
|
||||||
|
valueTypeByName :: Full.Name -> Maybe In.Type -> Maybe In.Type
|
||||||
|
valueTypeByName fieldName (Just( In.InputObjectBaseType inputObjectType)) =
|
||||||
|
let In.InputObjectType _ _ fieldTypes = inputObjectType
|
||||||
|
in inputFieldType <$> HashMap.lookup fieldName fieldTypes
|
||||||
|
valueTypeByName _ _ = Nothing
|
||||||
|
|
||||||
|
fragmentDefinition :: forall m
|
||||||
|
. Validation.Rule m
|
||||||
|
-> Validation m
|
||||||
|
-> Full.FragmentDefinition
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =
|
||||||
|
pure $ rule definition'
|
||||||
|
fragmentDefinition rule context definition'
|
||||||
|
| Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
|
||||||
|
, Validation.FragmentRule definitionRule _ <- rule
|
||||||
|
= applyToChildren typeCondition directives' selections
|
||||||
|
|> definitionRule definition'
|
||||||
|
| Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
|
||||||
|
= applyToChildren typeCondition directives' selections
|
||||||
|
where
|
||||||
|
types' = Schema.types $ Validation.schema context
|
||||||
|
applyToChildren typeCondition directives' selections
|
||||||
|
= selectionSet context types' rule (lookupType' typeCondition) selections
|
||||||
|
>< directives context rule fragmentDefinitionLocation directives'
|
||||||
|
lookupType' = flip lookupType types'
|
||||||
|
|
||||||
|
lookupType :: forall m
|
||||||
|
. Full.TypeCondition
|
||||||
|
-> HashMap Full.Name (Schema.Type m)
|
||||||
|
-> Maybe (Out.Type m)
|
||||||
|
lookupType typeCondition types' = HashMap.lookup typeCondition types'
|
||||||
|
>>= typeToOut
|
||||||
|
|
||||||
|
selectionSet :: Traversable t
|
||||||
|
=> forall m
|
||||||
|
. Validation m
|
||||||
|
-> ApplySelectionRule m (t Full.Selection)
|
||||||
|
selectionSet context types' rule = foldMap . selection context types' rule
|
||||||
|
|
||||||
|
selection :: forall m. Validation m -> ApplySelectionRule m Full.Selection
|
||||||
|
selection context types' rule objectType selection'
|
||||||
|
| Validation.SelectionRule selectionRule <- rule =
|
||||||
|
applyToChildren |> selectionRule objectType selection'
|
||||||
|
| otherwise = applyToChildren
|
||||||
|
where
|
||||||
|
applyToChildren =
|
||||||
|
case selection' of
|
||||||
|
Full.FieldSelection field' ->
|
||||||
|
field context types' rule objectType field'
|
||||||
|
Full.InlineFragmentSelection inlineFragment' ->
|
||||||
|
inlineFragment context types' rule objectType inlineFragment'
|
||||||
|
Full.FragmentSpreadSelection fragmentSpread' ->
|
||||||
|
fragmentSpread context rule fragmentSpread'
|
||||||
|
|
||||||
|
field :: forall m. Validation m -> ApplySelectionRule m Full.Field
|
||||||
|
field context types' rule objectType field' = go field'
|
||||||
|
where
|
||||||
|
go (Full.Field _ fieldName _ _ _ _)
|
||||||
|
| Validation.FieldRule fieldRule <- rule =
|
||||||
|
applyToChildren fieldName |> fieldRule objectType field'
|
||||||
|
| Validation.ArgumentsRule argumentsRule _ <- rule =
|
||||||
|
applyToChildren fieldName |> argumentsRule objectType field'
|
||||||
|
| otherwise = applyToChildren fieldName
|
||||||
|
typeFieldType (Out.Field _ type' _) = type'
|
||||||
|
typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes
|
||||||
|
applyToChildren fieldName =
|
||||||
|
let Full.Field _ _ arguments' directives' selections _ = field'
|
||||||
|
typeField = objectType >>= Type.lookupTypeField fieldName
|
||||||
|
argumentTypes = maybe mempty typeFieldArguments typeField
|
||||||
|
in selectionSet context types' rule (typeFieldType <$> typeField) selections
|
||||||
|
>< directives context rule fieldLocation directives'
|
||||||
|
>< arguments rule argumentTypes arguments'
|
||||||
|
|
||||||
|
arguments :: forall m
|
||||||
|
. Validation.Rule m
|
||||||
|
-> In.Arguments
|
||||||
|
-> [Full.Argument]
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
arguments rule argumentTypes = foldMap forEach . Seq.fromList
|
||||||
|
where
|
||||||
|
forEach argument'@(Full.Argument argumentName _ _) =
|
||||||
|
let argumentType = HashMap.lookup argumentName argumentTypes
|
||||||
|
in argument rule argumentType argument'
|
||||||
|
|
||||||
|
argument :: forall m
|
||||||
|
. Validation.Rule m
|
||||||
|
-> Maybe In.Argument
|
||||||
|
-> Full.Argument
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
argument rule argumentType (Full.Argument _ value' _) =
|
||||||
|
value rule (valueType <$> argumentType) value'
|
||||||
|
where
|
||||||
|
valueType (In.Argument _ valueType' _) = valueType'
|
||||||
|
|
||||||
|
-- valueTypeFromList :: Maybe In.Type -> Maybe In.Type
|
||||||
|
embedListLocation :: forall a m
|
||||||
|
. (Maybe In.Type -> Full.Node a -> Seq m)
|
||||||
|
-> Maybe In.Type
|
||||||
|
-> [a]
|
||||||
|
-> Full.Location
|
||||||
|
-> Seq m
|
||||||
|
embedListLocation go listType values location'
|
||||||
|
= foldMap (go $ valueTypeFromList listType)
|
||||||
|
$ flip Full.Node location' <$> Seq.fromList values
|
||||||
|
where
|
||||||
|
valueTypeFromList (Just (In.ListBaseType baseType)) = Just baseType
|
||||||
|
valueTypeFromList _ = Nothing
|
||||||
|
|
||||||
|
value :: forall m
|
||||||
|
. Validation.Rule m
|
||||||
|
-> Maybe In.Type
|
||||||
|
-> Full.Node Full.Value
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
value (Validation.ValueRule rule _) valueType = go valueType
|
||||||
|
where
|
||||||
|
go inputObjectType value'@(Full.Node (Full.Object fields) _)
|
||||||
|
= foldMap (forEach inputObjectType) (Seq.fromList fields)
|
||||||
|
|> rule inputObjectType value'
|
||||||
|
go listType value'@(Full.Node (Full.List values) location')
|
||||||
|
= embedListLocation go listType values location'
|
||||||
|
|> rule listType value'
|
||||||
|
go anotherValue value' = pure $ rule anotherValue value'
|
||||||
|
forEach inputObjectType Full.ObjectField{value = value', ..} =
|
||||||
|
go (valueTypeByName name inputObjectType) value'
|
||||||
|
value _ _ = const mempty
|
||||||
|
|
||||||
|
inlineFragment :: forall m
|
||||||
|
. Validation m
|
||||||
|
-> ApplySelectionRule m Full.InlineFragment
|
||||||
|
inlineFragment context types' rule objectType inlineFragment' =
|
||||||
|
go inlineFragment'
|
||||||
|
where
|
||||||
|
go (Full.InlineFragment optionalType directives' selections _)
|
||||||
|
| Validation.FragmentRule _ fragmentRule <- rule
|
||||||
|
= applyToChildren (refineTarget optionalType) directives' selections
|
||||||
|
|> fragmentRule inlineFragment'
|
||||||
|
| otherwise = applyToChildren (refineTarget optionalType) directives' selections
|
||||||
|
refineTarget (Just typeCondition) = lookupType typeCondition types'
|
||||||
|
refineTarget Nothing = objectType
|
||||||
|
applyToChildren objectType' directives' selections
|
||||||
|
= selectionSet context types' rule objectType' selections
|
||||||
|
>< directives context rule inlineFragmentLocation directives'
|
||||||
|
|
||||||
|
fragmentSpread :: forall m. Validation m -> ApplyRule m Full.FragmentSpread
|
||||||
|
fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _)
|
||||||
|
| Validation.FragmentSpreadRule fragmentRule <- rule =
|
||||||
|
applyToChildren |> fragmentRule fragmentSpread'
|
||||||
|
| otherwise = applyToChildren
|
||||||
|
where
|
||||||
|
applyToChildren = directives context rule fragmentSpreadLocation directives'
|
||||||
|
|
||||||
|
directives :: Traversable t
|
||||||
|
=> forall m
|
||||||
|
. Validation m
|
||||||
|
-> Validation.Rule m
|
||||||
|
-> DirectiveLocation
|
||||||
|
-> t Full.Directive
|
||||||
|
-> Seq (Validation.RuleT m)
|
||||||
|
directives context rule directiveLocation directives'
|
||||||
|
| Validation.DirectivesRule directivesRule <- rule =
|
||||||
|
applyToChildren |> directivesRule directiveLocation directiveList
|
||||||
|
| otherwise = applyToChildren
|
||||||
|
where
|
||||||
|
directiveList = toList directives'
|
||||||
|
applyToChildren = foldMap (directive context rule) directiveList
|
||||||
|
|
||||||
|
directive :: forall m. Validation m -> ApplyRule m Full.Directive
|
||||||
|
directive _ (Validation.ArgumentsRule _ argumentsRule) directive' =
|
||||||
|
pure $ argumentsRule directive'
|
||||||
|
directive context rule (Full.Directive directiveName arguments' _) =
|
||||||
|
let argumentTypes = maybe HashMap.empty directiveArguments
|
||||||
|
$ HashMap.lookup directiveName
|
||||||
|
$ Schema.directives
|
||||||
|
$ Validation.schema context
|
||||||
|
in arguments rule argumentTypes arguments'
|
||||||
|
where
|
||||||
|
directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -5,41 +5,29 @@
|
||||||
-- | Definitions used by the validation rules and the validator itself.
|
-- | Definitions used by the validation rules and the validator itself.
|
||||||
module Language.GraphQL.Validate.Validation
|
module Language.GraphQL.Validate.Validation
|
||||||
( Error(..)
|
( Error(..)
|
||||||
, Path(..)
|
|
||||||
, Rule(..)
|
, Rule(..)
|
||||||
, RuleT
|
, RuleT
|
||||||
, Validation(..)
|
, Validation(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.Trans.Reader (ReaderT(..))
|
import Control.Monad.Trans.Reader (ReaderT)
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.Sequence (Seq)
|
||||||
import Data.Text (Text)
|
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
|
||||||
import Language.GraphQL.AST.Document
|
import Language.GraphQL.AST.Document
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
import Language.GraphQL.Type.Schema (Schema)
|
import Language.GraphQL.Type.Schema (Schema)
|
||||||
import qualified Language.GraphQL.Type.Schema as Schema
|
|
||||||
|
|
||||||
-- | If an error can be associated to a particular field in the GraphQL result,
|
|
||||||
-- it must contain an entry with the key path that details the path of the
|
|
||||||
-- response field which experienced the error. This allows clients to identify
|
|
||||||
-- whether a null result is intentional or caused by a runtime error.
|
|
||||||
data Path
|
|
||||||
= Segment Text -- ^ Field name.
|
|
||||||
| Index Int -- ^ List index if a field returned a list.
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | Validation error.
|
-- | Validation error.
|
||||||
data Error = Error
|
data Error = Error
|
||||||
{ message :: String
|
{ message :: String
|
||||||
, locations :: [Location]
|
, locations :: [Location]
|
||||||
, path :: [Path]
|
|
||||||
} deriving (Eq, Show)
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
-- | Validation rule context.
|
-- | Validation rule context.
|
||||||
data Validation m = Validation
|
data Validation m = Validation
|
||||||
{ ast :: Document
|
{ ast :: Document
|
||||||
, schema :: Schema m
|
, schema :: Schema m
|
||||||
, types :: HashMap Name (Schema.Type m)
|
|
||||||
, rules :: [Rule m]
|
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | 'Rule' assigns a function to each AST node that can be validated. If the
|
-- | 'Rule' assigns a function to each AST node that can be validated. If the
|
||||||
|
@ -49,6 +37,14 @@ data Rule m
|
||||||
= DefinitionRule (Definition -> RuleT m)
|
= DefinitionRule (Definition -> RuleT m)
|
||||||
| OperationDefinitionRule (OperationDefinition -> RuleT m)
|
| OperationDefinitionRule (OperationDefinition -> RuleT m)
|
||||||
| FragmentDefinitionRule (FragmentDefinition -> RuleT m)
|
| FragmentDefinitionRule (FragmentDefinition -> RuleT m)
|
||||||
|
| SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)
|
||||||
|
| FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
|
||||||
|
| FragmentSpreadRule (FragmentSpread -> RuleT m)
|
||||||
|
| FieldRule (Maybe (Out.Type m) -> Field -> RuleT m)
|
||||||
|
| ArgumentsRule (Maybe (Out.Type m) -> Field -> RuleT m) (Directive -> RuleT m)
|
||||||
|
| DirectivesRule (DirectiveLocation -> [Directive] -> RuleT m)
|
||||||
|
| VariablesRule ([VariableDefinition] -> RuleT m)
|
||||||
|
| ValueRule (Maybe In.Type -> Node Value -> RuleT m) (Maybe In.Type -> Node ConstValue -> RuleT m)
|
||||||
|
|
||||||
-- | Monad transformer used by the rules.
|
-- | Monad transformer used by the rules.
|
||||||
type RuleT m = ReaderT (Validation m) Maybe Error
|
type RuleT m = ReaderT (Validation m) Seq Error
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
resolver: lts-16.11
|
resolver: lts-16.20
|
||||||
|
|
||||||
packages:
|
packages:
|
||||||
- .
|
- .
|
||||||
|
@ -6,4 +6,4 @@ packages:
|
||||||
extra-deps: []
|
extra-deps: []
|
||||||
flags: {}
|
flags: {}
|
||||||
|
|
||||||
pvp-bounds: both
|
pvp-bounds: lower
|
||||||
|
|
|
@ -4,7 +4,7 @@ module Language.GraphQL.AST.EncoderSpec
|
||||||
( spec
|
( spec
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Language.GraphQL.AST
|
import qualified Language.GraphQL.AST.Document as Full
|
||||||
import Language.GraphQL.AST.Encoder
|
import Language.GraphQL.AST.Encoder
|
||||||
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
|
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
|
||||||
import Test.QuickCheck (choose, oneof, forAll)
|
import Test.QuickCheck (choose, oneof, forAll)
|
||||||
|
@ -15,52 +15,52 @@ spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
describe "value" $ do
|
describe "value" $ do
|
||||||
context "null value" $ do
|
context "null value" $ do
|
||||||
let testNull formatter = value formatter Null `shouldBe` "null"
|
let testNull formatter = value formatter Full.Null `shouldBe` "null"
|
||||||
it "minified" $ testNull minified
|
it "minified" $ testNull minified
|
||||||
it "pretty" $ testNull pretty
|
it "pretty" $ testNull pretty
|
||||||
|
|
||||||
context "minified" $ do
|
context "minified" $ do
|
||||||
it "escapes \\" $
|
it "escapes \\" $
|
||||||
value minified (String "\\") `shouldBe` "\"\\\\\""
|
value minified (Full.String "\\") `shouldBe` "\"\\\\\""
|
||||||
it "escapes double quotes" $
|
it "escapes double quotes" $
|
||||||
value minified (String "\"") `shouldBe` "\"\\\"\""
|
value minified (Full.String "\"") `shouldBe` "\"\\\"\""
|
||||||
it "escapes \\f" $
|
it "escapes \\f" $
|
||||||
value minified (String "\f") `shouldBe` "\"\\f\""
|
value minified (Full.String "\f") `shouldBe` "\"\\f\""
|
||||||
it "escapes \\n" $
|
it "escapes \\n" $
|
||||||
value minified (String "\n") `shouldBe` "\"\\n\""
|
value minified (Full.String "\n") `shouldBe` "\"\\n\""
|
||||||
it "escapes \\r" $
|
it "escapes \\r" $
|
||||||
value minified (String "\r") `shouldBe` "\"\\r\""
|
value minified (Full.String "\r") `shouldBe` "\"\\r\""
|
||||||
it "escapes \\t" $
|
it "escapes \\t" $
|
||||||
value minified (String "\t") `shouldBe` "\"\\t\""
|
value minified (Full.String "\t") `shouldBe` "\"\\t\""
|
||||||
it "escapes backspace" $
|
it "escapes backspace" $
|
||||||
value minified (String "a\bc") `shouldBe` "\"a\\bc\""
|
value minified (Full.String "a\bc") `shouldBe` "\"a\\bc\""
|
||||||
context "escapes Unicode for chars less than 0010" $ do
|
context "escapes Unicode for chars less than 0010" $ do
|
||||||
it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\""
|
it "Null" $ value minified (Full.String "\x0000") `shouldBe` "\"\\u0000\""
|
||||||
it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\""
|
it "bell" $ value minified (Full.String "\x0007") `shouldBe` "\"\\u0007\""
|
||||||
context "escapes Unicode for char less than 0020" $ do
|
context "escapes Unicode for char less than 0020" $ do
|
||||||
it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\""
|
it "DLE" $ value minified (Full.String "\x0010") `shouldBe` "\"\\u0010\""
|
||||||
it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\""
|
it "EM" $ value minified (Full.String "\x0019") `shouldBe` "\"\\u0019\""
|
||||||
context "encodes without escape" $ do
|
context "encodes without escape" $ do
|
||||||
it "space" $ value minified (String "\x0020") `shouldBe` "\" \""
|
it "space" $ value minified (Full.String "\x0020") `shouldBe` "\" \""
|
||||||
it "~" $ value minified (String "\x007E") `shouldBe` "\"~\""
|
it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\""
|
||||||
|
|
||||||
context "pretty" $ do
|
context "pretty" $ do
|
||||||
it "uses strings for short string values" $
|
it "uses strings for short string values" $
|
||||||
value pretty (String "Short text") `shouldBe` "\"Short text\""
|
value pretty (Full.String "Short text") `shouldBe` "\"Short text\""
|
||||||
it "uses block strings for text with new lines, with newline symbol" $
|
it "uses block strings for text with new lines, with newline symbol" $
|
||||||
value pretty (String "Line 1\nLine 2")
|
value pretty (Full.String "Line 1\nLine 2")
|
||||||
`shouldBe` [r|"""
|
`shouldBe` [r|"""
|
||||||
Line 1
|
Line 1
|
||||||
Line 2
|
Line 2
|
||||||
"""|]
|
"""|]
|
||||||
it "uses block strings for text with new lines, with CR symbol" $
|
it "uses block strings for text with new lines, with CR symbol" $
|
||||||
value pretty (String "Line 1\rLine 2")
|
value pretty (Full.String "Line 1\rLine 2")
|
||||||
`shouldBe` [r|"""
|
`shouldBe` [r|"""
|
||||||
Line 1
|
Line 1
|
||||||
Line 2
|
Line 2
|
||||||
"""|]
|
"""|]
|
||||||
it "uses block strings for text with new lines, with CR symbol followed by newline" $
|
it "uses block strings for text with new lines, with CR symbol followed by newline" $
|
||||||
value pretty (String "Line 1\r\nLine 2")
|
value pretty (Full.String "Line 1\r\nLine 2")
|
||||||
`shouldBe` [r|"""
|
`shouldBe` [r|"""
|
||||||
Line 1
|
Line 1
|
||||||
Line 2
|
Line 2
|
||||||
|
@ -77,12 +77,12 @@ spec = do
|
||||||
forAll genNotAllowedSymbol $ \x -> do
|
forAll genNotAllowedSymbol $ \x -> do
|
||||||
let
|
let
|
||||||
rawValue = "Short \n" <> cons x "text"
|
rawValue = "Short \n" <> cons x "text"
|
||||||
encoded = value pretty (String $ toStrict rawValue)
|
encoded = value pretty (Full.String $ toStrict rawValue)
|
||||||
shouldStartWith (unpack encoded) "\""
|
shouldStartWith (unpack encoded) "\""
|
||||||
shouldEndWith (unpack encoded) "\""
|
shouldEndWith (unpack encoded) "\""
|
||||||
shouldNotContain (unpack encoded) "\"\"\""
|
shouldNotContain (unpack encoded) "\"\"\""
|
||||||
|
|
||||||
it "Hello world" $ value pretty (String "Hello,\n World!\n\nYours,\n GraphQL.")
|
it "Hello world" $ value pretty (Full.String "Hello,\n World!\n\nYours,\n GraphQL.")
|
||||||
`shouldBe` [r|"""
|
`shouldBe` [r|"""
|
||||||
Hello,
|
Hello,
|
||||||
World!
|
World!
|
||||||
|
@ -91,29 +91,29 @@ spec = do
|
||||||
GraphQL.
|
GraphQL.
|
||||||
"""|]
|
"""|]
|
||||||
|
|
||||||
it "has only newlines" $ value pretty (String "\n") `shouldBe` [r|"""
|
it "has only newlines" $ value pretty (Full.String "\n") `shouldBe` [r|"""
|
||||||
|
|
||||||
|
|
||||||
"""|]
|
"""|]
|
||||||
it "has newlines and one symbol at the begining" $
|
it "has newlines and one symbol at the begining" $
|
||||||
value pretty (String "a\n\n") `shouldBe` [r|"""
|
value pretty (Full.String "a\n\n") `shouldBe` [r|"""
|
||||||
a
|
a
|
||||||
|
|
||||||
|
|
||||||
"""|]
|
"""|]
|
||||||
it "has newlines and one symbol at the end" $
|
it "has newlines and one symbol at the end" $
|
||||||
value pretty (String "\n\na") `shouldBe` [r|"""
|
value pretty (Full.String "\n\na") `shouldBe` [r|"""
|
||||||
|
|
||||||
|
|
||||||
a
|
a
|
||||||
"""|]
|
"""|]
|
||||||
it "has newlines and one symbol in the middle" $
|
it "has newlines and one symbol in the middle" $
|
||||||
value pretty (String "\na\n") `shouldBe` [r|"""
|
value pretty (Full.String "\na\n") `shouldBe` [r|"""
|
||||||
|
|
||||||
a
|
a
|
||||||
|
|
||||||
"""|]
|
"""|]
|
||||||
it "skip trailing whitespaces" $ value pretty (String " Short\ntext ")
|
it "skip trailing whitespaces" $ value pretty (Full.String " Short\ntext ")
|
||||||
`shouldBe` [r|"""
|
`shouldBe` [r|"""
|
||||||
Short
|
Short
|
||||||
text
|
text
|
||||||
|
@ -121,11 +121,13 @@ spec = do
|
||||||
|
|
||||||
describe "definition" $
|
describe "definition" $
|
||||||
it "indents block strings in arguments" $
|
it "indents block strings in arguments" $
|
||||||
let arguments = [Argument "message" (String "line1\nline2")]
|
let location = Full.Location 0 0
|
||||||
field = Field Nothing "field" arguments [] []
|
argumentValue = Full.Node (Full.String "line1\nline2") location
|
||||||
operation = DefinitionOperation
|
arguments = [Full.Argument "message" argumentValue location]
|
||||||
$ SelectionSet (pure field)
|
field = Full.Field Nothing "field" arguments [] [] location
|
||||||
$ Location 0 0
|
fieldSelection = pure $ Full.FieldSelection field
|
||||||
|
operation = Full.DefinitionOperation
|
||||||
|
$ Full.SelectionSet fieldSelection location
|
||||||
in definition pretty operation `shouldBe` [r|{
|
in definition pretty operation `shouldBe` [r|{
|
||||||
field(message: """
|
field(message: """
|
||||||
line1
|
line1
|
||||||
|
|
|
@ -75,9 +75,9 @@ spec = describe "Lexer" $ do
|
||||||
parse dollar "" "$" `shouldParse` "$"
|
parse dollar "" "$" `shouldParse` "$"
|
||||||
runBetween parens `shouldSucceedOn` "()"
|
runBetween parens `shouldSucceedOn` "()"
|
||||||
parse spread "" "..." `shouldParse` "..."
|
parse spread "" "..." `shouldParse` "..."
|
||||||
parse colon "" ":" `shouldParse` ":"
|
parse colon "" `shouldSucceedOn` ":"
|
||||||
parse equals "" "=" `shouldParse` "="
|
parse equals "" "=" `shouldParse` "="
|
||||||
parse at "" "@" `shouldParse` "@"
|
parse at "" `shouldSucceedOn` "@"
|
||||||
runBetween brackets `shouldSucceedOn` "[]"
|
runBetween brackets `shouldSucceedOn` "[]"
|
||||||
runBetween braces `shouldSucceedOn` "{}"
|
runBetween braces `shouldSucceedOn` "{}"
|
||||||
parse pipe "" "|" `shouldParse` "|"
|
parse pipe "" "|" `shouldParse` "|"
|
||||||
|
|
|
@ -128,7 +128,7 @@ spec = describe "Parser" $ do
|
||||||
parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]
|
parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]
|
||||||
|
|
||||||
it "parses schema extension with an operation type and directive" $
|
it "parses schema extension with an operation type and directive" $
|
||||||
let newDirective = Directive "newDirective" []
|
let newDirective = Directive "newDirective" [] $ Location 1 15
|
||||||
schemaExtension = SchemaExtension
|
schemaExtension = SchemaExtension
|
||||||
$ SchemaOperationExtension [newDirective]
|
$ SchemaOperationExtension [newDirective]
|
||||||
$ OperationTypeDefinition Query "Query" :| []
|
$ OperationTypeDefinition Query "Query" :| []
|
||||||
|
|
|
@ -19,6 +19,6 @@ import Test.Hspec ( Spec
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = describe "singleError" $
|
spec = describe "singleError" $
|
||||||
it "constructs an error with the given message" $
|
it "constructs an error with the given message" $
|
||||||
let errors'' = Seq.singleton $ Error "Message." []
|
let errors'' = Seq.singleton $ Error "Message." [] []
|
||||||
expected = Response Aeson.Null errors''
|
expected = Response Aeson.Null errors''
|
||||||
in singleError "Message." `shouldBe` expected
|
in singleError "Message." `shouldBe` expected
|
||||||
|
|
|
@ -3,6 +3,7 @@
|
||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
module Language.GraphQL.ExecuteSpec
|
module Language.GraphQL.ExecuteSpec
|
||||||
( spec
|
( spec
|
||||||
) where
|
) where
|
||||||
|
@ -10,10 +11,11 @@ module Language.GraphQL.ExecuteSpec
|
||||||
import Control.Exception (SomeException)
|
import Control.Exception (SomeException)
|
||||||
import Data.Aeson ((.=))
|
import Data.Aeson ((.=))
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
|
import Data.Aeson.Types (emptyObject)
|
||||||
import Data.Conduit
|
import Data.Conduit
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Language.GraphQL.AST (Name)
|
import Language.GraphQL.AST (Document, Name)
|
||||||
import Language.GraphQL.AST.Parser (document)
|
import Language.GraphQL.AST.Parser (document)
|
||||||
import Language.GraphQL.Error
|
import Language.GraphQL.Error
|
||||||
import Language.GraphQL.Execute
|
import Language.GraphQL.Execute
|
||||||
|
@ -21,13 +23,10 @@ import Language.GraphQL.Type as Type
|
||||||
import Language.GraphQL.Type.Out as Out
|
import Language.GraphQL.Type.Out as Out
|
||||||
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||||
import Text.Megaparsec (parse)
|
import Text.Megaparsec (parse)
|
||||||
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
schema :: Schema (Either SomeException)
|
philosopherSchema :: Schema (Either SomeException)
|
||||||
schema = Schema
|
philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty
|
||||||
{ query = queryType
|
|
||||||
, mutation = Nothing
|
|
||||||
, subscription = Just subscriptionType
|
|
||||||
}
|
|
||||||
|
|
||||||
queryType :: Out.ObjectType (Either SomeException)
|
queryType :: Out.ObjectType (Either SomeException)
|
||||||
queryType = Out.ObjectType "Query" Nothing []
|
queryType = Out.ObjectType "Query" Nothing []
|
||||||
|
@ -71,9 +70,32 @@ quoteType = Out.ObjectType "Quote" Nothing []
|
||||||
quoteField =
|
quoteField =
|
||||||
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
|
|
||||||
|
type EitherStreamOrValue = Either
|
||||||
|
(ResponseEventStream (Either SomeException) Aeson.Value)
|
||||||
|
(Response Aeson.Value)
|
||||||
|
|
||||||
|
execute' :: Document -> Either SomeException EitherStreamOrValue
|
||||||
|
execute' =
|
||||||
|
execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec =
|
spec =
|
||||||
describe "execute" $ do
|
describe "execute" $ do
|
||||||
|
it "rejects recursive fragments" $
|
||||||
|
let sourceQuery = [r|
|
||||||
|
{
|
||||||
|
...cyclicFragment
|
||||||
|
}
|
||||||
|
|
||||||
|
fragment cyclicFragment on Query {
|
||||||
|
...cyclicFragment
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Response emptyObject mempty
|
||||||
|
Right (Right actual) = either (pure . parseError) execute'
|
||||||
|
$ parse document "" sourceQuery
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
|
||||||
context "Query" $ do
|
context "Query" $ do
|
||||||
it "skips unknown fields" $
|
it "skips unknown fields" $
|
||||||
let data'' = Aeson.object
|
let data'' = Aeson.object
|
||||||
|
@ -82,7 +104,6 @@ spec =
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
expected = Response data'' mempty
|
expected = Response data'' mempty
|
||||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
|
||||||
Right (Right actual) = either (pure . parseError) execute'
|
Right (Right actual) = either (pure . parseError) execute'
|
||||||
$ parse document "" "{ philosopher { firstName surname } }"
|
$ parse document "" "{ philosopher { firstName surname } }"
|
||||||
in actual `shouldBe` expected
|
in actual `shouldBe` expected
|
||||||
|
@ -94,7 +115,6 @@ spec =
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
expected = Response data'' mempty
|
expected = Response data'' mempty
|
||||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
|
||||||
Right (Right actual) = either (pure . parseError) execute'
|
Right (Right actual) = either (pure . parseError) execute'
|
||||||
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
||||||
in actual `shouldBe` expected
|
in actual `shouldBe` expected
|
||||||
|
@ -106,7 +126,6 @@ spec =
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
expected = Response data'' mempty
|
expected = Response data'' mempty
|
||||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
|
||||||
Right (Left stream) = either (pure . parseError) execute'
|
Right (Left stream) = either (pure . parseError) execute'
|
||||||
$ parse document "" "subscription { newQuote { quote } }"
|
$ parse document "" "subscription { newQuote { quote } }"
|
||||||
Right (Just actual) = runConduit $ stream .| await
|
Right (Just actual) = runConduit $ stream .| await
|
||||||
|
|
|
@ -9,8 +9,7 @@ module Language.GraphQL.ValidateSpec
|
||||||
( spec
|
( spec
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Sequence (Seq(..))
|
import Data.Foldable (toList)
|
||||||
import qualified Data.Sequence as Seq
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Language.GraphQL.AST as AST
|
import qualified Language.GraphQL.AST as AST
|
||||||
|
@ -18,23 +17,25 @@ import Language.GraphQL.Type
|
||||||
import qualified Language.GraphQL.Type.In as In
|
import qualified Language.GraphQL.Type.In as In
|
||||||
import qualified Language.GraphQL.Type.Out as Out
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
import Language.GraphQL.Validate
|
import Language.GraphQL.Validate
|
||||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
|
||||||
import Text.Megaparsec (parse)
|
import Text.Megaparsec (parse)
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
schema :: Schema IO
|
petSchema :: Schema IO
|
||||||
schema = Schema
|
petSchema = schema queryType Nothing (Just subscriptionType) mempty
|
||||||
{ query = queryType
|
|
||||||
, mutation = Nothing
|
|
||||||
, subscription = Nothing
|
|
||||||
}
|
|
||||||
|
|
||||||
queryType :: ObjectType IO
|
queryType :: ObjectType IO
|
||||||
queryType = ObjectType "Query" Nothing []
|
queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||||
$ HashMap.singleton "dog" dogResolver
|
[ ("dog", dogResolver)
|
||||||
|
, ("findDog", findDogResolver)
|
||||||
|
]
|
||||||
where
|
where
|
||||||
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
||||||
dogResolver = ValueResolver dogField $ pure Null
|
dogResolver = ValueResolver dogField $ pure Null
|
||||||
|
findDogArguments = HashMap.singleton "complex"
|
||||||
|
$ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing
|
||||||
|
findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments
|
||||||
|
findDogResolver = ValueResolver findDogField $ pure Null
|
||||||
|
|
||||||
dogCommandType :: EnumType
|
dogCommandType :: EnumType
|
||||||
dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
|
dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
|
||||||
|
@ -72,6 +73,12 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
|
||||||
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
|
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
|
||||||
ownerResolver = ValueResolver ownerField $ pure Null
|
ownerResolver = ValueResolver ownerField $ pure Null
|
||||||
|
|
||||||
|
dogDataType :: InputObjectType
|
||||||
|
dogDataType = InputObjectType "DogData" Nothing
|
||||||
|
$ HashMap.singleton "name" nameInputField
|
||||||
|
where
|
||||||
|
nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing
|
||||||
|
|
||||||
sentientType :: InterfaceType IO
|
sentientType :: InterfaceType IO
|
||||||
sentientType = InterfaceType "Sentient" Nothing []
|
sentientType = InterfaceType "Sentient" Nothing []
|
||||||
$ HashMap.singleton "name"
|
$ HashMap.singleton "name"
|
||||||
|
@ -81,19 +88,28 @@ petType :: InterfaceType IO
|
||||||
petType = InterfaceType "Pet" Nothing []
|
petType = InterfaceType "Pet" Nothing []
|
||||||
$ HashMap.singleton "name"
|
$ HashMap.singleton "name"
|
||||||
$ Field Nothing (Out.NonNullScalarType string) mempty
|
$ Field Nothing (Out.NonNullScalarType string) mempty
|
||||||
{-
|
|
||||||
alienType :: ObjectType IO
|
subscriptionType :: ObjectType IO
|
||||||
alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList
|
subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList
|
||||||
[ ("name", nameResolver)
|
[ ("newMessage", newMessageResolver)
|
||||||
, ("homePlanet", homePlanetResolver)
|
, ("disallowedSecondRootField", newMessageResolver)
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
nameField = Field Nothing (Out.NonNullScalarType string) mempty
|
newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty
|
||||||
nameResolver = ValueResolver nameField $ pure "Name"
|
newMessageResolver = ValueResolver newMessageField
|
||||||
homePlanetField =
|
$ pure $ Object HashMap.empty
|
||||||
Field Nothing (Out.NamedScalarType string) mempty
|
|
||||||
homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet"
|
messageType :: ObjectType IO
|
||||||
-}
|
messageType = ObjectType "Message" Nothing [] $ HashMap.fromList
|
||||||
|
[ ("sender", senderResolver)
|
||||||
|
, ("body", bodyResolver)
|
||||||
|
]
|
||||||
|
where
|
||||||
|
senderField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||||
|
senderResolver = ValueResolver senderField $ pure "Sender"
|
||||||
|
bodyField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||||
|
bodyResolver = ValueResolver bodyField $ pure "Message body."
|
||||||
|
|
||||||
humanType :: ObjectType IO
|
humanType :: ObjectType IO
|
||||||
humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
|
humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
|
||||||
[ ("name", nameResolver)
|
[ ("name", nameResolver)
|
||||||
|
@ -106,45 +122,14 @@ humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
|
||||||
Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
|
Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
|
||||||
petsResolver = ValueResolver petsField $ pure $ List []
|
petsResolver = ValueResolver petsField $ pure $ List []
|
||||||
{-
|
{-
|
||||||
catCommandType :: EnumType
|
|
||||||
catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
|
|
||||||
[ ("JUMP", EnumValue Nothing)
|
|
||||||
]
|
|
||||||
|
|
||||||
catType :: ObjectType IO
|
|
||||||
catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
|
|
||||||
[ ("name", nameResolver)
|
|
||||||
, ("nickname", nicknameResolver)
|
|
||||||
, ("doesKnowCommand", doesKnowCommandResolver)
|
|
||||||
, ("meowVolume", meowVolumeResolver)
|
|
||||||
]
|
|
||||||
where
|
|
||||||
nameField = Field Nothing (Out.NonNullScalarType string) mempty
|
|
||||||
nameResolver = ValueResolver nameField $ pure "Name"
|
|
||||||
nicknameField = Field Nothing (Out.NamedScalarType string) mempty
|
|
||||||
nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
|
|
||||||
doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
|
|
||||||
$ HashMap.singleton "catCommand"
|
|
||||||
$ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
|
|
||||||
doesKnowCommandResolver = ValueResolver doesKnowCommandField
|
|
||||||
$ pure $ Boolean True
|
|
||||||
meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
|
|
||||||
meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2
|
|
||||||
|
|
||||||
catOrDogType :: UnionType IO
|
catOrDogType :: UnionType IO
|
||||||
catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
|
catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
|
||||||
|
|
||||||
dogOrHumanType :: UnionType IO
|
|
||||||
dogOrHumanType = UnionType "DogOrHuman" Nothing [dogType, humanType]
|
|
||||||
|
|
||||||
humanOrAlienType :: UnionType IO
|
|
||||||
humanOrAlienType = UnionType "HumanOrAlien" Nothing [humanType, alienType]
|
|
||||||
-}
|
-}
|
||||||
validate :: Text -> Seq Error
|
validate :: Text -> [Error]
|
||||||
validate queryString =
|
validate queryString =
|
||||||
case parse AST.document "" queryString of
|
case parse AST.document "" queryString of
|
||||||
Left _ -> Seq.empty
|
Left _ -> []
|
||||||
Right ast -> document schema specifiedRules ast
|
Right ast -> toList $ document petSchema specifiedRules ast
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec =
|
spec =
|
||||||
|
@ -166,9 +151,8 @@ spec =
|
||||||
{ message =
|
{ message =
|
||||||
"Definition must be OperationDefinition or FragmentDefinition."
|
"Definition must be OperationDefinition or FragmentDefinition."
|
||||||
, locations = [AST.Location 9 15]
|
, locations = [AST.Location 9 15]
|
||||||
, path = []
|
|
||||||
}
|
}
|
||||||
in validate queryString `shouldBe` Seq.singleton expected
|
in validate queryString `shouldContain` [expected]
|
||||||
|
|
||||||
it "rejects multiple subscription root fields" $
|
it "rejects multiple subscription root fields" $
|
||||||
let queryString = [r|
|
let queryString = [r|
|
||||||
|
@ -182,11 +166,11 @@ spec =
|
||||||
|]
|
|]
|
||||||
expected = Error
|
expected = Error
|
||||||
{ message =
|
{ message =
|
||||||
"Subscription sub must select only one top level field."
|
"Subscription \"sub\" must select only one top level \
|
||||||
|
\field."
|
||||||
, locations = [AST.Location 2 15]
|
, locations = [AST.Location 2 15]
|
||||||
, path = []
|
|
||||||
}
|
}
|
||||||
in validate queryString `shouldBe` Seq.singleton expected
|
in validate queryString `shouldContain` [expected]
|
||||||
|
|
||||||
it "rejects multiple subscription root fields coming from a fragment" $
|
it "rejects multiple subscription root fields coming from a fragment" $
|
||||||
let queryString = [r|
|
let queryString = [r|
|
||||||
|
@ -204,11 +188,11 @@ spec =
|
||||||
|]
|
|]
|
||||||
expected = Error
|
expected = Error
|
||||||
{ message =
|
{ message =
|
||||||
"Subscription sub must select only one top level field."
|
"Subscription \"sub\" must select only one top level \
|
||||||
|
\field."
|
||||||
, locations = [AST.Location 2 15]
|
, locations = [AST.Location 2 15]
|
||||||
, path = []
|
|
||||||
}
|
}
|
||||||
in validate queryString `shouldBe` Seq.singleton expected
|
in validate queryString `shouldContain` [expected]
|
||||||
|
|
||||||
it "rejects multiple anonymous operations" $
|
it "rejects multiple anonymous operations" $
|
||||||
let queryString = [r|
|
let queryString = [r|
|
||||||
|
@ -230,9 +214,8 @@ spec =
|
||||||
{ message =
|
{ message =
|
||||||
"This anonymous operation must be the only defined operation."
|
"This anonymous operation must be the only defined operation."
|
||||||
, locations = [AST.Location 2 15]
|
, locations = [AST.Location 2 15]
|
||||||
, path = []
|
|
||||||
}
|
}
|
||||||
in validate queryString `shouldBe` Seq.singleton expected
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
it "rejects operations with the same name" $
|
it "rejects operations with the same name" $
|
||||||
let queryString = [r|
|
let queryString = [r|
|
||||||
|
@ -252,9 +235,8 @@ spec =
|
||||||
{ message =
|
{ message =
|
||||||
"There can be only one operation named \"dogOperation\"."
|
"There can be only one operation named \"dogOperation\"."
|
||||||
, locations = [AST.Location 2 15, AST.Location 8 15]
|
, locations = [AST.Location 2 15, AST.Location 8 15]
|
||||||
, path = []
|
|
||||||
}
|
}
|
||||||
in validate queryString `shouldBe` Seq.singleton expected
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
it "rejects fragments with the same name" $
|
it "rejects fragments with the same name" $
|
||||||
let queryString = [r|
|
let queryString = [r|
|
||||||
|
@ -278,6 +260,406 @@ spec =
|
||||||
{ message =
|
{ message =
|
||||||
"There can be only one fragment named \"fragmentOne\"."
|
"There can be only one fragment named \"fragmentOne\"."
|
||||||
, locations = [AST.Location 8 15, AST.Location 12 15]
|
, locations = [AST.Location 8 15, AST.Location 12 15]
|
||||||
, path = []
|
|
||||||
}
|
}
|
||||||
in validate queryString `shouldBe` Seq.singleton expected
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects the fragment spread without a target" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
...undefinedFragment
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Fragment target \"undefinedFragment\" is undefined."
|
||||||
|
, locations = [AST.Location 4 19]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects fragment spreads without an unknown target type" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
...notOnExistingType
|
||||||
|
}
|
||||||
|
}
|
||||||
|
fragment notOnExistingType on NotInSchema {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Fragment \"notOnExistingType\" is specified on type \
|
||||||
|
\\"NotInSchema\" which doesn't exist in the schema."
|
||||||
|
, locations = [AST.Location 4 19]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects inline fragments without a target" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
... on NotInSchema {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Inline fragment is specified on type \"NotInSchema\" \
|
||||||
|
\which doesn't exist in the schema."
|
||||||
|
, locations = [AST.Location 3 17]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects fragments on scalar types" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
...fragOnScalar
|
||||||
|
}
|
||||||
|
}
|
||||||
|
fragment fragOnScalar on Int {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Fragment cannot condition on non composite type \
|
||||||
|
\\"Int\"."
|
||||||
|
, locations = [AST.Location 7 15]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldContain` [expected]
|
||||||
|
|
||||||
|
it "rejects inline fragments on scalar types" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
... on Boolean {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Fragment cannot condition on non composite type \
|
||||||
|
\\"Boolean\"."
|
||||||
|
, locations = [AST.Location 3 17]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldContain` [expected]
|
||||||
|
|
||||||
|
it "rejects unused fragments" $
|
||||||
|
let queryString = [r|
|
||||||
|
fragment nameFragment on Dog { # unused
|
||||||
|
name
|
||||||
|
}
|
||||||
|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Fragment \"nameFragment\" is never used."
|
||||||
|
, locations = [AST.Location 2 15]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects spreads that form cycles" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
...nameFragment
|
||||||
|
}
|
||||||
|
}
|
||||||
|
fragment nameFragment on Dog {
|
||||||
|
name
|
||||||
|
...barkVolumeFragment
|
||||||
|
}
|
||||||
|
fragment barkVolumeFragment on Dog {
|
||||||
|
barkVolume
|
||||||
|
...nameFragment
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
error1 = Error
|
||||||
|
{ message =
|
||||||
|
"Cannot spread fragment \"barkVolumeFragment\" within \
|
||||||
|
\itself (via barkVolumeFragment -> nameFragment -> \
|
||||||
|
\barkVolumeFragment)."
|
||||||
|
, locations = [AST.Location 11 15]
|
||||||
|
}
|
||||||
|
error2 = Error
|
||||||
|
{ message =
|
||||||
|
"Cannot spread fragment \"nameFragment\" within itself \
|
||||||
|
\(via nameFragment -> barkVolumeFragment -> \
|
||||||
|
\nameFragment)."
|
||||||
|
, locations = [AST.Location 7 15]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [error1, error2]
|
||||||
|
|
||||||
|
it "rejects duplicate field arguments" $ do
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
isHousetrained(atOtherHomes: true, atOtherHomes: true)
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"There can be only one argument named \"atOtherHomes\"."
|
||||||
|
, locations = [AST.Location 4 34, AST.Location 4 54]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects more than one directive per location" $ do
|
||||||
|
let queryString = [r|
|
||||||
|
query ($foo: Boolean = true, $bar: Boolean = false) {
|
||||||
|
dog @skip(if: $foo) @skip(if: $bar) {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"There can be only one directive named \"skip\"."
|
||||||
|
, locations = [AST.Location 3 21, AST.Location 3 37]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects duplicate variables" $
|
||||||
|
let queryString = [r|
|
||||||
|
query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {
|
||||||
|
dog {
|
||||||
|
isHousetrained(atOtherHomes: $atOtherHomes)
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"There can be only one variable named \"atOtherHomes\"."
|
||||||
|
, locations = [AST.Location 2 39, AST.Location 2 63]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects non-input types as variables" $
|
||||||
|
let queryString = [r|
|
||||||
|
query takesDogBang($dog: Dog!) {
|
||||||
|
dog {
|
||||||
|
isHousetrained(atOtherHomes: $dog)
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Variable \"$dog\" cannot be non-input type \"Dog\"."
|
||||||
|
, locations = [AST.Location 2 34]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects undefined variables" $
|
||||||
|
let queryString = [r|
|
||||||
|
query variableIsNotDefinedUsedInSingleFragment {
|
||||||
|
dog {
|
||||||
|
...isHousetrainedFragment
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
fragment isHousetrainedFragment on Dog {
|
||||||
|
isHousetrained(atOtherHomes: $atOtherHomes)
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Variable \"$atOtherHomes\" is not defined by \
|
||||||
|
\operation \
|
||||||
|
\\"variableIsNotDefinedUsedInSingleFragment\"."
|
||||||
|
, locations = [AST.Location 9 46]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects unused variables" $
|
||||||
|
let queryString = [r|
|
||||||
|
query variableUnused($atOtherHomes: Boolean) {
|
||||||
|
dog {
|
||||||
|
isHousetrained
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Variable \"$atOtherHomes\" is never used in operation \
|
||||||
|
\\"variableUnused\"."
|
||||||
|
, locations = [AST.Location 2 36]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects duplicate fields in input objects" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
findDog(complex: { name: "Fido", name: "Jack" }) {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"There can be only one input field named \"name\"."
|
||||||
|
, locations = [AST.Location 3 36, AST.Location 3 50]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects undefined fields" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
meowVolume
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Cannot query field \"meowVolume\" on type \"Dog\"."
|
||||||
|
, locations = [AST.Location 4 19]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects scalar fields with not empty selection set" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
barkVolume {
|
||||||
|
sinceWhen
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Field \"barkVolume\" must not have a selection since \
|
||||||
|
\type \"Int\" has no subfields."
|
||||||
|
, locations = [AST.Location 4 19]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects field arguments missing in the type" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Unknown argument \"command\" on field \
|
||||||
|
\\"Dog.doesKnowCommand\"."
|
||||||
|
, locations = [AST.Location 4 35]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects directive arguments missing in the definition" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
isHousetrained(atOtherHomes: true) @include(unless: false, if: true)
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Unknown argument \"unless\" on directive \"@include\"."
|
||||||
|
, locations = [AST.Location 4 63]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects undefined directives" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
dog {
|
||||||
|
isHousetrained(atOtherHomes: true) @ignore(if: true)
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message = "Unknown directive \"@ignore\"."
|
||||||
|
, locations = [AST.Location 4 54]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects undefined input object fields" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Field \"favoriteCookieFlavor\" is not defined \
|
||||||
|
\by type \"DogData\"."
|
||||||
|
, locations = [AST.Location 3 36]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects directives in invalid locations" $
|
||||||
|
let queryString = [r|
|
||||||
|
query @skip(if: $foo) {
|
||||||
|
dog {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message = "Directive \"@skip\" may not be used on QUERY."
|
||||||
|
, locations = [AST.Location 2 21]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "rejects missing required input fields" $
|
||||||
|
let queryString = [r|
|
||||||
|
{
|
||||||
|
findDog(complex: { name: null }) {
|
||||||
|
name
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Input field \"name\" of type \"DogData\" is required, \
|
||||||
|
\but it was not provided."
|
||||||
|
, locations = [AST.Location 3 34]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
||||||
|
it "finds corresponding subscription fragment" $
|
||||||
|
let queryString = [r|
|
||||||
|
subscription sub {
|
||||||
|
...anotherSubscription
|
||||||
|
...multipleSubscriptions
|
||||||
|
}
|
||||||
|
fragment multipleSubscriptions on Subscription {
|
||||||
|
newMessage {
|
||||||
|
body
|
||||||
|
}
|
||||||
|
disallowedSecondRootField {
|
||||||
|
sender
|
||||||
|
}
|
||||||
|
}
|
||||||
|
fragment anotherSubscription on Subscription {
|
||||||
|
newMessage {
|
||||||
|
body
|
||||||
|
sender
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Subscription \"sub\" must select only one top level \
|
||||||
|
\field."
|
||||||
|
, locations = [AST.Location 2 15]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldBe` [expected]
|
||||||
|
|
|
@ -19,8 +19,7 @@ import Test.Hspec.GraphQL
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
experimentalResolver :: Schema IO
|
experimentalResolver :: Schema IO
|
||||||
experimentalResolver = Schema
|
experimentalResolver = schema queryType Nothing Nothing mempty
|
||||||
{ query = queryType, mutation = Nothing, subscription = Nothing }
|
|
||||||
where
|
where
|
||||||
queryType = Out.ObjectType "Query" Nothing []
|
queryType = Out.ObjectType "Query" Nothing []
|
||||||
$ HashMap.singleton "experimentalField"
|
$ HashMap.singleton "experimentalField"
|
||||||
|
@ -72,7 +71,7 @@ spec =
|
||||||
...experimentalFragment @skip(if: true)
|
...experimentalFragment @skip(if: true)
|
||||||
}
|
}
|
||||||
|
|
||||||
fragment experimentalFragment on ExperimentalType {
|
fragment experimentalFragment on Query {
|
||||||
experimentalField
|
experimentalField
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
@ -83,7 +82,7 @@ spec =
|
||||||
it "should be able to @skip an inline fragment" $ do
|
it "should be able to @skip an inline fragment" $ do
|
||||||
let sourceQuery = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
... on ExperimentalType @skip(if: true) {
|
... on Query @skip(if: true) {
|
||||||
experimentalField
|
experimentalField
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -46,18 +46,15 @@ inlineQuery = [r|{
|
||||||
}|]
|
}|]
|
||||||
|
|
||||||
shirtType :: Out.ObjectType IO
|
shirtType :: Out.ObjectType IO
|
||||||
shirtType = Out.ObjectType "Shirt" Nothing []
|
shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList
|
||||||
$ HashMap.fromList
|
[ ("size", sizeFieldType)
|
||||||
[ ("size", sizeFieldType)
|
]
|
||||||
, ("circumference", circumferenceFieldType)
|
|
||||||
]
|
|
||||||
|
|
||||||
hatType :: Out.ObjectType IO
|
hatType :: Out.ObjectType IO
|
||||||
hatType = Out.ObjectType "Hat" Nothing []
|
hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList
|
||||||
$ HashMap.fromList
|
[ ("size", sizeFieldType)
|
||||||
[ ("size", sizeFieldType)
|
, ("circumference", circumferenceFieldType)
|
||||||
, ("circumference", circumferenceFieldType)
|
]
|
||||||
]
|
|
||||||
|
|
||||||
circumferenceFieldType :: Out.Resolver IO
|
circumferenceFieldType :: Out.Resolver IO
|
||||||
circumferenceFieldType
|
circumferenceFieldType
|
||||||
|
@ -70,12 +67,11 @@ sizeFieldType
|
||||||
$ pure $ snd size
|
$ pure $ snd size
|
||||||
|
|
||||||
toSchema :: Text -> (Text, Value) -> Schema IO
|
toSchema :: Text -> (Text, Value) -> Schema IO
|
||||||
toSchema t (_, resolve) = Schema
|
toSchema t (_, resolve) = schema queryType Nothing Nothing mempty
|
||||||
{ query = queryType, mutation = Nothing, subscription = Nothing }
|
|
||||||
where
|
where
|
||||||
unionMember = if t == "Hat" then hatType else shirtType
|
garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
|
||||||
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
|
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||||
garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
|
garmentField = Out.Field Nothing (Out.NamedUnionType garmentType) mempty
|
||||||
queryType =
|
queryType =
|
||||||
case t of
|
case t of
|
||||||
"circumference" -> hatType
|
"circumference" -> hatType
|
||||||
|
@ -111,22 +107,16 @@ spec = do
|
||||||
|
|
||||||
it "embeds inline fragments without type" $ do
|
it "embeds inline fragments without type" $ do
|
||||||
let sourceQuery = [r|{
|
let sourceQuery = [r|{
|
||||||
garment {
|
circumference
|
||||||
circumference
|
... {
|
||||||
... {
|
size
|
||||||
size
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
}|]
|
}|]
|
||||||
resolvers = ("garment", Object $ HashMap.fromList [circumference, size])
|
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
||||||
|
|
||||||
actual <- graphql (toSchema "garment" resolvers) sourceQuery
|
|
||||||
let expected = HashMap.singleton "data"
|
let expected = HashMap.singleton "data"
|
||||||
$ Aeson.object
|
$ Aeson.object
|
||||||
[ "garment" .= Aeson.object
|
[ "circumference" .= (60 :: Int)
|
||||||
[ "circumference" .= (60 :: Int)
|
, "size" .= ("L" :: Text)
|
||||||
, "size" .= ("L" :: Text)
|
|
||||||
]
|
|
||||||
]
|
]
|
||||||
in actual `shouldResolveTo` expected
|
in actual `shouldResolveTo` expected
|
||||||
|
|
||||||
|
@ -183,21 +173,6 @@ spec = do
|
||||||
]
|
]
|
||||||
in actual `shouldResolveTo` expected
|
in actual `shouldResolveTo` expected
|
||||||
|
|
||||||
it "rejects recursive fragments" $ do
|
|
||||||
let expected = HashMap.singleton "data" $ Aeson.object []
|
|
||||||
sourceQuery = [r|
|
|
||||||
{
|
|
||||||
...circumferenceFragment
|
|
||||||
}
|
|
||||||
|
|
||||||
fragment circumferenceFragment on Hat {
|
|
||||||
...circumferenceFragment
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
|
|
||||||
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
|
||||||
actual `shouldResolveTo` expected
|
|
||||||
|
|
||||||
it "considers type condition" $ do
|
it "considers type condition" $ do
|
||||||
let sourceQuery = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
|
|
|
@ -23,13 +23,11 @@ hatType = Out.ObjectType "Hat" Nothing []
|
||||||
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||||
$ pure $ Int 60
|
$ pure $ Int 60
|
||||||
|
|
||||||
schema :: Schema IO
|
garmentSchema :: Schema IO
|
||||||
schema = Schema
|
garmentSchema = schema queryType (Just mutationType) Nothing mempty
|
||||||
{ query = Out.ObjectType "Query" Nothing [] hatFieldResolver
|
|
||||||
, mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
|
|
||||||
, subscription = Nothing
|
|
||||||
}
|
|
||||||
where
|
where
|
||||||
|
queryType = Out.ObjectType "Query" Nothing [] hatFieldResolver
|
||||||
|
mutationType = Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
|
||||||
garment = pure $ Object $ HashMap.fromList
|
garment = pure $ Object $ HashMap.fromList
|
||||||
[ ("circumference", Int 60)
|
[ ("circumference", Int 60)
|
||||||
]
|
]
|
||||||
|
@ -57,7 +55,7 @@ spec =
|
||||||
[ "circumference" .= (60 :: Int)
|
[ "circumference" .= (60 :: Int)
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
actual <- graphql schema querySource
|
actual <- graphql garmentSchema querySource
|
||||||
actual `shouldResolveTo` expected
|
actual `shouldResolveTo` expected
|
||||||
|
|
||||||
it "chooses Mutation" $ do
|
it "chooses Mutation" $ do
|
||||||
|
@ -70,5 +68,5 @@ spec =
|
||||||
$ object
|
$ object
|
||||||
[ "incrementCircumference" .= (61 :: Int)
|
[ "incrementCircumference" .= (61 :: Int)
|
||||||
]
|
]
|
||||||
actual <- graphql schema querySource
|
actual <- graphql garmentSchema querySource
|
||||||
actual `shouldResolveTo` expected
|
actual `shouldResolveTo` expected
|
||||||
|
|
|
@ -1,204 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
module Test.StarWars.Data
|
|
||||||
( Character
|
|
||||||
, StarWarsException(..)
|
|
||||||
, appearsIn
|
|
||||||
, artoo
|
|
||||||
, getDroid
|
|
||||||
, getDroid'
|
|
||||||
, getEpisode
|
|
||||||
, getFriends
|
|
||||||
, getHero
|
|
||||||
, getHuman
|
|
||||||
, id_
|
|
||||||
, homePlanet
|
|
||||||
, name_
|
|
||||||
, secretBackstory
|
|
||||||
, typeName
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad.Catch (Exception(..), MonadThrow(..), SomeException)
|
|
||||||
import Control.Applicative (Alternative(..), liftA2)
|
|
||||||
import Data.Maybe (catMaybes)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Typeable (cast)
|
|
||||||
import Language.GraphQL.Error
|
|
||||||
import Language.GraphQL.Type
|
|
||||||
|
|
||||||
-- * Data
|
|
||||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
|
|
||||||
|
|
||||||
-- ** Characters
|
|
||||||
|
|
||||||
type ID = Text
|
|
||||||
|
|
||||||
data CharCommon = CharCommon
|
|
||||||
{ _id_ :: ID
|
|
||||||
, _name :: Text
|
|
||||||
, _friends :: [ID]
|
|
||||||
, _appearsIn :: [Int]
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
|
|
||||||
data Human = Human
|
|
||||||
{ _humanChar :: CharCommon
|
|
||||||
, homePlanet :: Text
|
|
||||||
}
|
|
||||||
|
|
||||||
data Droid = Droid
|
|
||||||
{ _droidChar :: CharCommon
|
|
||||||
, primaryFunction :: Text
|
|
||||||
}
|
|
||||||
|
|
||||||
type Character = Either Droid Human
|
|
||||||
|
|
||||||
id_ :: Character -> ID
|
|
||||||
id_ (Left x) = _id_ . _droidChar $ x
|
|
||||||
id_ (Right x) = _id_ . _humanChar $ x
|
|
||||||
|
|
||||||
name_ :: Character -> Text
|
|
||||||
name_ (Left x) = _name . _droidChar $ x
|
|
||||||
name_ (Right x) = _name . _humanChar $ x
|
|
||||||
|
|
||||||
friends :: Character -> [ID]
|
|
||||||
friends (Left x) = _friends . _droidChar $ x
|
|
||||||
friends (Right x) = _friends . _humanChar $ x
|
|
||||||
|
|
||||||
appearsIn :: Character -> [Int]
|
|
||||||
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
|
||||||
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
|
||||||
|
|
||||||
data StarWarsException = SecretBackstory | InvalidArguments
|
|
||||||
|
|
||||||
instance Show StarWarsException where
|
|
||||||
show SecretBackstory = "secretBackstory is secret."
|
|
||||||
show InvalidArguments = "Invalid arguments."
|
|
||||||
|
|
||||||
instance Exception StarWarsException where
|
|
||||||
toException = toException . ResolverException
|
|
||||||
fromException e = do
|
|
||||||
ResolverException resolverException <- fromException e
|
|
||||||
cast resolverException
|
|
||||||
|
|
||||||
secretBackstory :: Resolve (Either SomeException)
|
|
||||||
secretBackstory = throwM SecretBackstory
|
|
||||||
|
|
||||||
typeName :: Character -> Text
|
|
||||||
typeName = either (const "Droid") (const "Human")
|
|
||||||
|
|
||||||
luke :: Character
|
|
||||||
luke = Right luke'
|
|
||||||
|
|
||||||
luke' :: Human
|
|
||||||
luke' = Human
|
|
||||||
{ _humanChar = CharCommon
|
|
||||||
{ _id_ = "1000"
|
|
||||||
, _name = "Luke Skywalker"
|
|
||||||
, _friends = ["1002","1003","2000","2001"]
|
|
||||||
, _appearsIn = [4,5,6]
|
|
||||||
}
|
|
||||||
, homePlanet = "Tatooine"
|
|
||||||
}
|
|
||||||
|
|
||||||
vader :: Human
|
|
||||||
vader = Human
|
|
||||||
{ _humanChar = CharCommon
|
|
||||||
{ _id_ = "1001"
|
|
||||||
, _name = "Darth Vader"
|
|
||||||
, _friends = ["1004"]
|
|
||||||
, _appearsIn = [4,5,6]
|
|
||||||
}
|
|
||||||
, homePlanet = "Tatooine"
|
|
||||||
}
|
|
||||||
|
|
||||||
han :: Human
|
|
||||||
han = Human
|
|
||||||
{ _humanChar = CharCommon
|
|
||||||
{ _id_ = "1002"
|
|
||||||
, _name = "Han Solo"
|
|
||||||
, _friends = ["1000","1003","2001" ]
|
|
||||||
, _appearsIn = [4,5,6]
|
|
||||||
}
|
|
||||||
, homePlanet = mempty
|
|
||||||
}
|
|
||||||
|
|
||||||
leia :: Human
|
|
||||||
leia = Human
|
|
||||||
{ _humanChar = CharCommon
|
|
||||||
{ _id_ = "1003"
|
|
||||||
, _name = "Leia Organa"
|
|
||||||
, _friends = ["1000","1002","2000","2001"]
|
|
||||||
, _appearsIn = [4,5,6]
|
|
||||||
}
|
|
||||||
, homePlanet = "Alderaan"
|
|
||||||
}
|
|
||||||
|
|
||||||
tarkin :: Human
|
|
||||||
tarkin = Human
|
|
||||||
{ _humanChar = CharCommon
|
|
||||||
{ _id_ = "1004"
|
|
||||||
, _name = "Wilhuff Tarkin"
|
|
||||||
, _friends = ["1001"]
|
|
||||||
, _appearsIn = [4]
|
|
||||||
}
|
|
||||||
, homePlanet = mempty
|
|
||||||
}
|
|
||||||
|
|
||||||
threepio :: Droid
|
|
||||||
threepio = Droid
|
|
||||||
{ _droidChar = CharCommon
|
|
||||||
{ _id_ = "2000"
|
|
||||||
, _name = "C-3PO"
|
|
||||||
, _friends = ["1000","1002","1003","2001" ]
|
|
||||||
, _appearsIn = [ 4, 5, 6 ]
|
|
||||||
}
|
|
||||||
, primaryFunction = "Protocol"
|
|
||||||
}
|
|
||||||
|
|
||||||
artoo :: Character
|
|
||||||
artoo = Left artoo'
|
|
||||||
|
|
||||||
artoo' :: Droid
|
|
||||||
artoo' = Droid
|
|
||||||
{ _droidChar = CharCommon
|
|
||||||
{ _id_ = "2001"
|
|
||||||
, _name = "R2-D2"
|
|
||||||
, _friends = ["1000","1002","1003"]
|
|
||||||
, _appearsIn = [4,5,6]
|
|
||||||
}
|
|
||||||
, primaryFunction = "Astrometch"
|
|
||||||
}
|
|
||||||
|
|
||||||
-- ** Helper functions
|
|
||||||
|
|
||||||
getHero :: Int -> Character
|
|
||||||
getHero 5 = luke
|
|
||||||
getHero _ = artoo
|
|
||||||
|
|
||||||
getHuman :: ID -> Maybe Character
|
|
||||||
getHuman = fmap Right . getHuman'
|
|
||||||
|
|
||||||
getHuman' :: ID -> Maybe Human
|
|
||||||
getHuman' "1000" = pure luke'
|
|
||||||
getHuman' "1001" = pure vader
|
|
||||||
getHuman' "1002" = pure han
|
|
||||||
getHuman' "1003" = pure leia
|
|
||||||
getHuman' "1004" = pure tarkin
|
|
||||||
getHuman' _ = empty
|
|
||||||
|
|
||||||
getDroid :: ID -> Maybe Character
|
|
||||||
getDroid = fmap Left . getDroid'
|
|
||||||
|
|
||||||
getDroid' :: ID -> Maybe Droid
|
|
||||||
getDroid' "2000" = pure threepio
|
|
||||||
getDroid' "2001" = pure artoo'
|
|
||||||
getDroid' _ = empty
|
|
||||||
|
|
||||||
getFriends :: Character -> [Character]
|
|
||||||
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
|
|
||||||
|
|
||||||
getEpisode :: Int -> Maybe Text
|
|
||||||
getEpisode 4 = pure "NEW_HOPE"
|
|
||||||
getEpisode 5 = pure "EMPIRE"
|
|
||||||
getEpisode 6 = pure "JEDI"
|
|
||||||
getEpisode _ = empty
|
|
|
@ -1,366 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
module Test.StarWars.QuerySpec
|
|
||||||
( spec
|
|
||||||
) where
|
|
||||||
|
|
||||||
import qualified Data.Aeson as Aeson
|
|
||||||
import Data.Aeson ((.=))
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Language.GraphQL
|
|
||||||
import Text.RawString.QQ (r)
|
|
||||||
import Test.Hspec.Expectations (Expectation, shouldBe)
|
|
||||||
import Test.Hspec (Spec, describe, it)
|
|
||||||
import Test.StarWars.Schema
|
|
||||||
|
|
||||||
-- * Test
|
|
||||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = describe "Star Wars Query Tests" $ do
|
|
||||||
describe "Basic Queries" $ do
|
|
||||||
it "R2-D2 hero" $ testQuery
|
|
||||||
[r| query HeroNameQuery {
|
|
||||||
hero {
|
|
||||||
id
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object
|
|
||||||
[ "data" .= Aeson.object
|
|
||||||
[ "hero" .= Aeson.object ["id" .= ("2001" :: Text)]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
it "R2-D2 ID and friends" $ testQuery
|
|
||||||
[r| query HeroNameAndFriendsQuery {
|
|
||||||
hero {
|
|
||||||
id
|
|
||||||
name
|
|
||||||
friends {
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object [
|
|
||||||
"hero" .= Aeson.object
|
|
||||||
[ "id" .= ("2001" :: Text)
|
|
||||||
, r2d2Name
|
|
||||||
, "friends" .=
|
|
||||||
[ Aeson.object [lukeName]
|
|
||||||
, Aeson.object [hanName]
|
|
||||||
, Aeson.object [leiaName]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]]
|
|
||||||
|
|
||||||
describe "Nested Queries" $ do
|
|
||||||
it "R2-D2 friends" $ testQuery
|
|
||||||
[r| query NestedQuery {
|
|
||||||
hero {
|
|
||||||
name
|
|
||||||
friends {
|
|
||||||
name
|
|
||||||
appearsIn
|
|
||||||
friends {
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object [
|
|
||||||
"hero" .= Aeson.object [
|
|
||||||
"name" .= ("R2-D2" :: Text)
|
|
||||||
, "friends" .= [
|
|
||||||
Aeson.object [
|
|
||||||
"name" .= ("Luke Skywalker" :: Text)
|
|
||||||
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
|
|
||||||
, "friends" .= [
|
|
||||||
Aeson.object [hanName]
|
|
||||||
, Aeson.object [leiaName]
|
|
||||||
, Aeson.object [c3poName]
|
|
||||||
, Aeson.object [r2d2Name]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
, Aeson.object [
|
|
||||||
hanName
|
|
||||||
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
|
|
||||||
, "friends" .=
|
|
||||||
[ Aeson.object [lukeName]
|
|
||||||
, Aeson.object [leiaName]
|
|
||||||
, Aeson.object [r2d2Name]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
, Aeson.object [
|
|
||||||
leiaName
|
|
||||||
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
|
|
||||||
, "friends" .=
|
|
||||||
[ Aeson.object [lukeName]
|
|
||||||
, Aeson.object [hanName]
|
|
||||||
, Aeson.object [c3poName]
|
|
||||||
, Aeson.object [r2d2Name]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]]
|
|
||||||
it "Luke ID" $ testQuery
|
|
||||||
[r| query FetchLukeQuery {
|
|
||||||
human(id: "1000") {
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object
|
|
||||||
[ "human" .= Aeson.object [lukeName]
|
|
||||||
]]
|
|
||||||
|
|
||||||
it "Luke ID with variable" $ testQueryParams
|
|
||||||
(HashMap.singleton "someId" "1000")
|
|
||||||
[r| query FetchSomeIDQuery($someId: String!) {
|
|
||||||
human(id: $someId) {
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object [
|
|
||||||
"human" .= Aeson.object [lukeName]
|
|
||||||
]]
|
|
||||||
it "Han ID with variable" $ testQueryParams
|
|
||||||
(HashMap.singleton "someId" "1002")
|
|
||||||
[r| query FetchSomeIDQuery($someId: String!) {
|
|
||||||
human(id: $someId) {
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object [
|
|
||||||
"human" .= Aeson.object [hanName]
|
|
||||||
]]
|
|
||||||
it "Invalid ID" $ testQueryParams
|
|
||||||
(HashMap.singleton "id" "Not a valid ID")
|
|
||||||
[r| query humanQuery($id: String!) {
|
|
||||||
human(id: $id) {
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|] $ Aeson.object ["data" .= Aeson.object ["human" .= Aeson.Null]]
|
|
||||||
it "Luke aliased" $ testQuery
|
|
||||||
[r| query FetchLukeAliased {
|
|
||||||
luke: human(id: "1000") {
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object [
|
|
||||||
"luke" .= Aeson.object [lukeName]
|
|
||||||
]]
|
|
||||||
it "R2-D2 ID and friends aliased" $ testQuery
|
|
||||||
[r| query HeroNameAndFriendsQuery {
|
|
||||||
hero {
|
|
||||||
id
|
|
||||||
name
|
|
||||||
friends {
|
|
||||||
friendName: name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object [
|
|
||||||
"hero" .= Aeson.object [
|
|
||||||
"id" .= ("2001" :: Text)
|
|
||||||
, r2d2Name
|
|
||||||
, "friends" .=
|
|
||||||
[ Aeson.object ["friendName" .= ("Luke Skywalker" :: Text)]
|
|
||||||
, Aeson.object ["friendName" .= ("Han Solo" :: Text)]
|
|
||||||
, Aeson.object ["friendName" .= ("Leia Organa" :: Text)]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]]
|
|
||||||
it "Luke and Leia aliased" $ testQuery
|
|
||||||
[r| query FetchLukeAndLeiaAliased {
|
|
||||||
luke: human(id: "1000") {
|
|
||||||
name
|
|
||||||
}
|
|
||||||
leia: human(id: "1003") {
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object
|
|
||||||
[ "luke" .= Aeson.object [lukeName]
|
|
||||||
, "leia" .= Aeson.object [leiaName]
|
|
||||||
]]
|
|
||||||
|
|
||||||
describe "Fragments for complex queries" $ do
|
|
||||||
it "Aliases to query for duplicate content" $ testQuery
|
|
||||||
[r| query DuplicateFields {
|
|
||||||
luke: human(id: "1000") {
|
|
||||||
name
|
|
||||||
homePlanet
|
|
||||||
}
|
|
||||||
leia: human(id: "1003") {
|
|
||||||
name
|
|
||||||
homePlanet
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object [
|
|
||||||
"luke" .= Aeson.object [lukeName, tatooine]
|
|
||||||
, "leia" .= Aeson.object [leiaName, alderaan]
|
|
||||||
]]
|
|
||||||
it "Fragment for duplicate content" $ testQuery
|
|
||||||
[r| query UseFragment {
|
|
||||||
luke: human(id: "1000") {
|
|
||||||
...HumanFragment
|
|
||||||
}
|
|
||||||
leia: human(id: "1003") {
|
|
||||||
...HumanFragment
|
|
||||||
}
|
|
||||||
}
|
|
||||||
fragment HumanFragment on Human {
|
|
||||||
name
|
|
||||||
homePlanet
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object [ "data" .= Aeson.object [
|
|
||||||
"luke" .= Aeson.object [lukeName, tatooine]
|
|
||||||
, "leia" .= Aeson.object [leiaName, alderaan]
|
|
||||||
]]
|
|
||||||
|
|
||||||
describe "__typename" $ do
|
|
||||||
it "R2D2 is a Droid" $ testQuery
|
|
||||||
[r| query CheckTypeOfR2 {
|
|
||||||
hero {
|
|
||||||
__typename
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object ["data" .= Aeson.object [
|
|
||||||
"hero" .= Aeson.object
|
|
||||||
[ "__typename" .= ("Droid" :: Text)
|
|
||||||
, r2d2Name
|
|
||||||
]
|
|
||||||
]]
|
|
||||||
it "Luke is a human" $ testQuery
|
|
||||||
[r| query CheckTypeOfLuke {
|
|
||||||
hero(episode: EMPIRE) {
|
|
||||||
__typename
|
|
||||||
name
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object ["data" .= Aeson.object [
|
|
||||||
"hero" .= Aeson.object
|
|
||||||
[ "__typename" .= ("Human" :: Text)
|
|
||||||
, lukeName
|
|
||||||
]
|
|
||||||
]]
|
|
||||||
|
|
||||||
describe "Errors in resolvers" $ do
|
|
||||||
it "error on secretBackstory" $ testQuery
|
|
||||||
[r|
|
|
||||||
query HeroNameQuery {
|
|
||||||
hero {
|
|
||||||
name
|
|
||||||
secretBackstory
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object
|
|
||||||
[ "data" .= Aeson.object
|
|
||||||
[ "hero" .= Aeson.object
|
|
||||||
[ "name" .= ("R2-D2" :: Text)
|
|
||||||
, "secretBackstory" .= Aeson.Null
|
|
||||||
]
|
|
||||||
]
|
|
||||||
, "errors" .=
|
|
||||||
[ Aeson.object
|
|
||||||
["message" .= ("secretBackstory is secret." :: Text)]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
it "Error in a list" $ testQuery
|
|
||||||
[r| query HeroNameQuery {
|
|
||||||
hero {
|
|
||||||
name
|
|
||||||
friends {
|
|
||||||
name
|
|
||||||
secretBackstory
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object ["data" .= Aeson.object
|
|
||||||
[ "hero" .= Aeson.object
|
|
||||||
[ "name" .= ("R2-D2" :: Text)
|
|
||||||
, "friends" .=
|
|
||||||
[ Aeson.object
|
|
||||||
[ "name" .= ("Luke Skywalker" :: Text)
|
|
||||||
, "secretBackstory" .= Aeson.Null
|
|
||||||
]
|
|
||||||
, Aeson.object
|
|
||||||
[ "name" .= ("Han Solo" :: Text)
|
|
||||||
, "secretBackstory" .= Aeson.Null
|
|
||||||
]
|
|
||||||
, Aeson.object
|
|
||||||
[ "name" .= ("Leia Organa" :: Text)
|
|
||||||
, "secretBackstory" .= Aeson.Null
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
, "errors" .=
|
|
||||||
[ Aeson.object
|
|
||||||
[ "message" .= ("secretBackstory is secret." :: Text)
|
|
||||||
]
|
|
||||||
, Aeson.object
|
|
||||||
[ "message" .= ("secretBackstory is secret." :: Text)
|
|
||||||
]
|
|
||||||
, Aeson.object
|
|
||||||
[ "message" .= ("secretBackstory is secret." :: Text)
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
it "error on secretBackstory with alias" $ testQuery
|
|
||||||
[r| query HeroNameQuery {
|
|
||||||
mainHero: hero {
|
|
||||||
name
|
|
||||||
story: secretBackstory
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|]
|
|
||||||
$ Aeson.object
|
|
||||||
[ "data" .= Aeson.object
|
|
||||||
[ "mainHero" .= Aeson.object
|
|
||||||
[ "name" .= ("R2-D2" :: Text)
|
|
||||||
, "story" .= Aeson.Null
|
|
||||||
]
|
|
||||||
]
|
|
||||||
, "errors" .=
|
|
||||||
[ Aeson.object
|
|
||||||
[ "message" .= ("secretBackstory is secret." :: Text)
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
where
|
|
||||||
lukeName = "name" .= ("Luke Skywalker" :: Text)
|
|
||||||
leiaName = "name" .= ("Leia Organa" :: Text)
|
|
||||||
hanName = "name" .= ("Han Solo" :: Text)
|
|
||||||
r2d2Name = "name" .= ("R2-D2" :: Text)
|
|
||||||
c3poName = "name" .= ("C-3PO" :: Text)
|
|
||||||
tatooine = "homePlanet" .= ("Tatooine" :: Text)
|
|
||||||
alderaan = "homePlanet" .= ("Alderaan" :: Text)
|
|
||||||
|
|
||||||
testQuery :: Text -> Aeson.Value -> Expectation
|
|
||||||
testQuery q expected =
|
|
||||||
let Right (Right actual) = graphql schema q
|
|
||||||
in Aeson.Object actual `shouldBe` expected
|
|
||||||
|
|
||||||
testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
|
|
||||||
testQueryParams f q expected =
|
|
||||||
let Right (Right actual) = graphqlSubs schema Nothing f q
|
|
||||||
in Aeson.Object actual `shouldBe` expected
|
|
|
@ -1,154 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
module Test.StarWars.Schema
|
|
||||||
( schema
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad.Catch (MonadThrow(..), SomeException)
|
|
||||||
import Control.Monad.Trans.Reader (asks)
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
|
||||||
import Data.Maybe (catMaybes)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Language.GraphQL.Type
|
|
||||||
import qualified Language.GraphQL.Type.In as In
|
|
||||||
import qualified Language.GraphQL.Type.Out as Out
|
|
||||||
import Test.StarWars.Data
|
|
||||||
import Prelude hiding (id)
|
|
||||||
|
|
||||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
|
||||||
|
|
||||||
schema :: Schema (Either SomeException)
|
|
||||||
schema = Schema
|
|
||||||
{ query = queryType
|
|
||||||
, mutation = Nothing
|
|
||||||
, subscription = Nothing
|
|
||||||
}
|
|
||||||
where
|
|
||||||
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
|
|
||||||
[ ("hero", heroFieldResolver)
|
|
||||||
, ("human", humanFieldResolver)
|
|
||||||
, ("droid", droidFieldResolver)
|
|
||||||
]
|
|
||||||
heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
|
|
||||||
$ HashMap.singleton "episode"
|
|
||||||
$ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
|
|
||||||
heroFieldResolver = ValueResolver heroField hero
|
|
||||||
humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
|
|
||||||
$ HashMap.singleton "id"
|
|
||||||
$ In.Argument Nothing (In.NonNullScalarType string) Nothing
|
|
||||||
humanFieldResolver = ValueResolver humanField human
|
|
||||||
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
|
|
||||||
droidFieldResolver = ValueResolver droidField droid
|
|
||||||
|
|
||||||
heroObject :: Out.ObjectType (Either SomeException)
|
|
||||||
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
|
|
||||||
[ ("id", idFieldType)
|
|
||||||
, ("name", nameFieldType)
|
|
||||||
, ("friends", friendsFieldType)
|
|
||||||
, ("appearsIn", appearsInField)
|
|
||||||
, ("homePlanet", homePlanetFieldType)
|
|
||||||
, ("secretBackstory", secretBackstoryFieldType)
|
|
||||||
, ("__typename", typenameFieldType)
|
|
||||||
]
|
|
||||||
where
|
|
||||||
homePlanetFieldType
|
|
||||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
|
||||||
$ idField "homePlanet"
|
|
||||||
|
|
||||||
droidObject :: Out.ObjectType (Either SomeException)
|
|
||||||
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
|
|
||||||
[ ("id", idFieldType)
|
|
||||||
, ("name", nameFieldType)
|
|
||||||
, ("friends", friendsFieldType)
|
|
||||||
, ("appearsIn", appearsInField)
|
|
||||||
, ("primaryFunction", primaryFunctionFieldType)
|
|
||||||
, ("secretBackstory", secretBackstoryFieldType)
|
|
||||||
, ("__typename", typenameFieldType)
|
|
||||||
]
|
|
||||||
where
|
|
||||||
primaryFunctionFieldType
|
|
||||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
|
||||||
$ idField "primaryFunction"
|
|
||||||
|
|
||||||
typenameFieldType :: Resolver (Either SomeException)
|
|
||||||
typenameFieldType
|
|
||||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
|
||||||
$ idField "__typename"
|
|
||||||
|
|
||||||
idFieldType :: Resolver (Either SomeException)
|
|
||||||
idFieldType
|
|
||||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
|
|
||||||
$ idField "id"
|
|
||||||
|
|
||||||
nameFieldType :: Resolver (Either SomeException)
|
|
||||||
nameFieldType
|
|
||||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
|
||||||
$ idField "name"
|
|
||||||
|
|
||||||
friendsFieldType :: Resolver (Either SomeException)
|
|
||||||
friendsFieldType
|
|
||||||
= ValueResolver (Out.Field Nothing fieldType mempty)
|
|
||||||
$ idField "friends"
|
|
||||||
where
|
|
||||||
fieldType = Out.ListType $ Out.NamedObjectType droidObject
|
|
||||||
|
|
||||||
appearsInField :: Resolver (Either SomeException)
|
|
||||||
appearsInField
|
|
||||||
= ValueResolver (Out.Field (Just description) fieldType mempty)
|
|
||||||
$ idField "appearsIn"
|
|
||||||
where
|
|
||||||
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
|
|
||||||
description = "Which movies they appear in."
|
|
||||||
|
|
||||||
secretBackstoryFieldType :: Resolver (Either SomeException)
|
|
||||||
secretBackstoryFieldType = ValueResolver field secretBackstory
|
|
||||||
where
|
|
||||||
field = Out.Field Nothing (Out.NamedScalarType string) mempty
|
|
||||||
|
|
||||||
idField :: Text -> Resolve (Either SomeException)
|
|
||||||
idField f = do
|
|
||||||
v <- asks values
|
|
||||||
let (Object v') = v
|
|
||||||
pure $ v' HashMap.! f
|
|
||||||
|
|
||||||
episodeEnum :: EnumType
|
|
||||||
episodeEnum = EnumType "Episode" (Just description)
|
|
||||||
$ HashMap.fromList [newHope, empire, jedi]
|
|
||||||
where
|
|
||||||
description = "One of the films in the Star Wars Trilogy"
|
|
||||||
newHope = ("NEW_HOPE", EnumValue $ Just "Released in 1977.")
|
|
||||||
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
|
|
||||||
jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
|
|
||||||
|
|
||||||
hero :: Resolve (Either SomeException)
|
|
||||||
hero = do
|
|
||||||
episode <- argument "episode"
|
|
||||||
pure $ character $ case episode of
|
|
||||||
Enum "NEW_HOPE" -> getHero 4
|
|
||||||
Enum "EMPIRE" -> getHero 5
|
|
||||||
Enum "JEDI" -> getHero 6
|
|
||||||
_ -> artoo
|
|
||||||
|
|
||||||
human :: Resolve (Either SomeException)
|
|
||||||
human = do
|
|
||||||
id' <- argument "id"
|
|
||||||
case id' of
|
|
||||||
String i -> pure $ maybe Null character $ getHuman i >>= Just
|
|
||||||
_ -> throwM InvalidArguments
|
|
||||||
|
|
||||||
droid :: Resolve (Either SomeException)
|
|
||||||
droid = do
|
|
||||||
id' <- argument "id"
|
|
||||||
case id' of
|
|
||||||
String i -> pure $ maybe Null character $ getDroid i >>= Just
|
|
||||||
_ -> throwM InvalidArguments
|
|
||||||
|
|
||||||
character :: Character -> Value
|
|
||||||
character char = Object $ HashMap.fromList
|
|
||||||
[ ("id", String $ id_ char)
|
|
||||||
, ("name", String $ name_ char)
|
|
||||||
, ("friends", List $ character <$> getFriends char)
|
|
||||||
, ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))
|
|
||||||
, ("homePlanet", String $ either mempty homePlanet char)
|
|
||||||
, ("__typename", String $ typeName char)
|
|
||||||
]
|
|
Loading…
Reference in New Issue