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
|
||||
[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
|
||||
## Changed
|
||||
### Changed
|
||||
- `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`.
|
||||
- The `Location` argument of `AST.Document.Definition.ExecutableDefinition` was
|
||||
moved to `OperationDefinition` and `FragmentDefinition` since these are the
|
||||
actual elements that have a location in the document.
|
||||
- `Validate.Rules` get the whole validation context (AST and schema).
|
||||
|
||||
## Added
|
||||
### Added
|
||||
- `Validate.Validation` contains data structures and functions used by the
|
||||
validator and concretet rules.
|
||||
- `Validate.Rules`: operation validation rules.
|
||||
|
||||
## [0.9.0.0] - 2020-07-24
|
||||
## Fixed
|
||||
### Fixed
|
||||
- Location of a parse error is returned in a singleton array with key
|
||||
`locations`.
|
||||
- Parsing comments in the front of definitions.
|
||||
- Some missing labels were added to the parsers, some labels were fixed to
|
||||
refer to the AST nodes being parsed.
|
||||
|
||||
## Added
|
||||
### Added
|
||||
- `AST` reexports `AST.Parser`.
|
||||
- `AST.Document.Location` is a token location as a line and column pair.
|
||||
- `Execute` reexports `Execute.Coerce`.
|
||||
|
@ -43,7 +109,7 @@ and this project adheres to
|
|||
- `Test.Hspec.GraphQL` contains some test helpers.
|
||||
- `Validate` contains the validator and standard rules.
|
||||
|
||||
## Changed
|
||||
### Changed
|
||||
- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
|
||||
have value resolvers, root subscription type resolvers need an additional
|
||||
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
|
||||
`MonadThrow`).
|
||||
|
||||
## Removed
|
||||
### Removed
|
||||
- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
|
||||
represents possible resolver configurations.
|
||||
- `Execute.executeWithName`. `Execute.execute` takes the operation name and
|
||||
|
@ -334,16 +400,17 @@ and this project adheres to
|
|||
### Added
|
||||
- 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.9.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...v0.9.0.0
|
||||
[0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0
|
||||
[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0
|
||||
[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0
|
||||
[0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0
|
||||
[0.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...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.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.4.0.0...v0.5.0.0
|
||||
[0.4.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.3...v0.4.0.0
|
||||
[0.3]: https://github.com/caraus-ecms/graphql/compare/v0.2.1...v0.3
|
||||
[0.2.1]: https://github.com/caraus-ecms/graphql/compare/v0.2...v0.2.1
|
||||
[0.2]: https://github.com/caraus-ecms/graphql/compare/v0.1...v0.2
|
||||
[0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0
|
||||
[0.10.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.10.0.0&rev_to=v0.9.0.0
|
||||
[0.9.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.9.0.0&rev_to=v0.8.0.0
|
||||
[0.8.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.8.0.0&rev_to=v0.7.0.0
|
||||
[0.7.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.7.0.0&rev_to=v0.6.1.0
|
||||
[0.6.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.6.1.0&rev_to=v0.6.0.0
|
||||
[0.6.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.6.0.0&rev_to=v0.5.1.0
|
||||
[0.5.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.1.0&rev_to=v0.5.0.1
|
||||
[0.5.0.1]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.0.1&rev_to=v0.5.0.0
|
||||
[0.5.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.0.0&rev_to=v0.4.0.0
|
||||
[0.4.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.4.0.0&rev_to=v0.3
|
||||
[0.3]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.3&rev_to=v0.2.1
|
||||
[0.2.1]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.2.1&rev_to=v0.2
|
||||
[0.2]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.2&rev_to=v0.1
|
||||
|
|
|
@ -1,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
|
||||
|
||||
[![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)
|
||||
[![CI/CD](https://img.shields.io/badge/CI-CD-brightgreen)](https://build.caraus.tech/go/pipelines)
|
||||
|
||||
This implementation is relatively low-level by design, it doesn't provide any
|
||||
mappings between the GraphQL types and Haskell's type system and avoids
|
||||
|
@ -24,125 +22,13 @@ For now this library provides:
|
|||
But the idea is to be a Haskell port of
|
||||
[`graphql-js`](https://github.com/graphql/graphql-js).
|
||||
|
||||
For a more precise list of currently missing features see issues marked as
|
||||
"[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)".
|
||||
For a more precise list of currently missing features see
|
||||
[issues](https://www.caraus.tech/projects/pub-graphql/issues).
|
||||
|
||||
## Documentation
|
||||
|
||||
API documentation is available through
|
||||
[Hackage](https://hackage.haskell.org/package/graphql).
|
||||
|
||||
You'll also find a small tutorial with some examples under
|
||||
[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
|
||||
|
||||
### Getting started
|
||||
|
||||
We start with a simple GraphQL API that provides us with some famous and less
|
||||
famous cites.
|
||||
|
||||
```graphql
|
||||
"""
|
||||
Root Query type.
|
||||
"""
|
||||
type Query {
|
||||
"""
|
||||
Provides a cite.
|
||||
"""
|
||||
cite: String!
|
||||
}
|
||||
```
|
||||
|
||||
This is called a GraphQL schema, it defines all queries supported by the API.
|
||||
`Query` is the root query type. Every GraphQL API should define a query type.
|
||||
|
||||
`Query` has a single field `cite` that returns a `String`. The `!` after the
|
||||
type denotes that the returned value cannot be `Null`. GraphQL fields are
|
||||
nullable by default.
|
||||
|
||||
To be able to work with this schema, we are going to implement it in Haskell.
|
||||
|
||||
```haskell
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import Control.Exception (SomeException)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Language.GraphQL
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
||||
-- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions.
|
||||
-- Our first schema supports only queries.
|
||||
schema :: Schema IO
|
||||
schema = Schema
|
||||
{ query = queryType, mutation = Nothing, subscription = Nothing }
|
||||
|
||||
-- GraphQL distinguishes between input and output types. Input types are field
|
||||
-- argument types and they are defined in Language.GraphQL.Type.In. Output types
|
||||
-- are result types, they are defined in Language.GraphQL.Type.Out. Root types
|
||||
-- are always object types.
|
||||
--
|
||||
-- Here we define a type "Query". The second argument is an optional
|
||||
-- description, the third one is the list of interfaces implemented by the
|
||||
-- object type. The last argument is a field map. Keys are field names, values
|
||||
-- are field definitions and resolvers. Resolvers are the functions, where the
|
||||
-- actual logic lives, they return values for the respective fields.
|
||||
queryType :: Out.ObjectType IO
|
||||
queryType = Out.ObjectType "Query" (Just "Root Query type.") []
|
||||
$ HashMap.singleton "cite" citeResolver
|
||||
where
|
||||
-- 'ValueResolver' is a 'Resolver' data constructor, it combines a field
|
||||
-- definition with its resolver function. This function resolves a value for
|
||||
-- a field (as opposed to the 'EventStreamResolver' used by subscriptions).
|
||||
-- Our resolver just returns a constant value.
|
||||
citeResolver = ValueResolver citeField
|
||||
$ pure "Piscis primum a capite foetat"
|
||||
-- The first argument is an optional field description. The second one is
|
||||
-- the field type and the third one is for arguments (we have none in this
|
||||
-- example).
|
||||
--
|
||||
-- GraphQL has named and wrapping types. String is a scalar, named type.
|
||||
-- Named types are nullable by default. To make our "cite" field
|
||||
-- non-nullable, we wrap it in the wrapping type, Non-Null.
|
||||
citeField = Out.Field
|
||||
(Just "Provides a cite.") (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
-- Now we can execute a query. Since our schema defines only one field,
|
||||
-- everything we can do is to ask to resolve it and give back the result.
|
||||
-- Since subscriptions don't return plain values, the 'graphql' function returns
|
||||
-- an 'Either'. 'Left' is for subscriptions, 'Right' is for queries and
|
||||
-- mutations.
|
||||
main :: IO ()
|
||||
main = do
|
||||
Right result <- graphql schema "{ cite }"
|
||||
ByteString.Lazy.Char8.putStrLn $ Aeson.encode result
|
||||
```
|
||||
|
||||
Executing this query produces the following JSON:
|
||||
|
||||
```json
|
||||
{
|
||||
"data": {
|
||||
"cite": "Piscis primum a capite foetat"
|
||||
}
|
||||
}
|
||||
```
|
||||
|
||||
## Further information
|
||||
|
||||
- [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/).
|
||||
Further documentation will be made available in the
|
||||
[Wiki](https://www.caraus.tech/projects/pub-graphql/wiki).
|
||||
|
|
|
@ -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.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 3ef060c57424074b84204bae61ee0a63e3470a7a060c45a977ff2bcbe4df8775
|
||||
-- hash: c89b0164372b6e02e4f338d3865dd6bb9dfd1a4475f25d808450480d73f94f91
|
||||
|
||||
name: graphql
|
||||
version: 0.10.0.0
|
||||
version: 0.11.0.0
|
||||
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
|
||||
homepage: https://github.com/caraus-ecms/graphql#readme
|
||||
bug-reports: https://github.com/caraus-ecms/graphql/issues
|
||||
homepage: https://www.caraus.tech/projects/pub-graphql
|
||||
bug-reports: https://www.caraus.tech/projects/pub-graphql/issues
|
||||
author: Danny Navarro <j@dannynavarro.net>,
|
||||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
maintainer: belka@caraus.de
|
||||
copyright: (c) 2019-2020 Eugen Wissner,
|
||||
(c) 2015-2017 J. Daniel Navarro
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
license: MPL-2.0 AND BSD-3-Clause
|
||||
license-files: LICENSE,
|
||||
LICENSE.MPL
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
CONTRIBUTING.md
|
||||
LICENSE
|
||||
README.md
|
||||
docs/tutorial/tutorial.lhs
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/caraus-ecms/graphql
|
||||
location: git://caraus.tech/pub/graphql.git
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
|
@ -76,7 +74,7 @@ library
|
|||
, unordered-containers
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tasty
|
||||
test-suite graphql-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
|
@ -91,9 +89,8 @@ test-suite tasty
|
|||
Test.DirectiveSpec
|
||||
Test.FragmentSpec
|
||||
Test.RootOperationSpec
|
||||
Test.StarWars.Data
|
||||
Test.StarWars.QuerySpec
|
||||
Test.StarWars.Schema
|
||||
Paths_graphql
|
||||
autogen-modules:
|
||||
Paths_graphql
|
||||
hs-source-dirs:
|
||||
tests
|
||||
|
|
29
package.yaml
29
package.yaml
|
@ -1,12 +1,15 @@
|
|||
name: graphql
|
||||
version: 0.10.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
name: graphql
|
||||
version: 0.11.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description:
|
||||
This package provides a rudimentary parser for the
|
||||
<https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
|
||||
maintainer: belka@caraus.de
|
||||
github: caraus-ecms/graphql
|
||||
category: Language
|
||||
Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
maintainer: belka@caraus.de
|
||||
git: git://caraus.tech/pub/graphql.git
|
||||
homepage: https://www.caraus.tech/projects/pub-graphql
|
||||
bug-reports: https://www.caraus.tech/projects/pub-graphql/issues
|
||||
category: Language
|
||||
license: MPL-2.0 AND BSD-3-Clause
|
||||
|
||||
copyright:
|
||||
- (c) 2019-2020 Eugen Wissner
|
||||
- (c) 2015-2017 J. Daniel Navarro
|
||||
|
@ -15,12 +18,12 @@ author:
|
|||
- Matthías Páll Gissurarson <mpg@mpg.is>
|
||||
- Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
|
||||
license-file:
|
||||
- LICENSE
|
||||
- LICENSE.MPL
|
||||
extra-source-files:
|
||||
- CHANGELOG.md
|
||||
- CONTRIBUTING.md
|
||||
- LICENSE
|
||||
- README.md
|
||||
- docs/tutorial/tutorial.lhs
|
||||
|
||||
dependencies:
|
||||
- aeson
|
||||
|
@ -47,7 +50,7 @@ library:
|
|||
- Language.GraphQL.Validate.Rules
|
||||
|
||||
tests:
|
||||
tasty:
|
||||
graphql-test:
|
||||
main: Spec.hs
|
||||
source-dirs: tests
|
||||
ghc-options:
|
||||
|
@ -60,3 +63,5 @@ tests:
|
|||
- hspec-megaparsec
|
||||
- QuickCheck
|
||||
- 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.Types as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (catMaybes)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute
|
||||
import qualified Language.GraphQL.Validate as Validate
|
||||
import Language.GraphQL.Type.Schema
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||
|
@ -55,24 +56,19 @@ graphqlSubs schema operationName variableValues document' =
|
|||
[ ("data", data'')
|
||||
, ("errors", Aeson.toJSON $ fromError <$> errors')
|
||||
]
|
||||
fromError Error{ locations = [], ..} =
|
||||
Aeson.object [("message", Aeson.toJSON message)]
|
||||
fromError Error{..} = Aeson.object
|
||||
fromError Error{..} = Aeson.object $ catMaybes
|
||||
[ Just ("message", Aeson.toJSON message)
|
||||
, toMaybe fromLocation "locations" locations
|
||||
, toMaybe fromPath "path" path
|
||||
]
|
||||
fromValidationError Validate.Error{..} = Aeson.object
|
||||
[ ("message", Aeson.toJSON message)
|
||||
, ("locations", Aeson.listValue fromLocation locations)
|
||||
]
|
||||
fromValidationError Validate.Error{..}
|
||||
| [] <- path = Aeson.object
|
||||
[ ("message", Aeson.toJSON message)
|
||||
, ("locations", Aeson.listValue fromLocation locations)
|
||||
]
|
||||
| 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
|
||||
toMaybe _ _ [] = Nothing
|
||||
toMaybe f key xs = Just (key, Aeson.listValue f xs)
|
||||
fromPath (Segment segment) = Aeson.String segment
|
||||
fromPath (Index index) = Aeson.toJSON index
|
||||
fromLocation Location{..} = Aeson.object
|
||||
[ ("line", Aeson.toJSON line)
|
||||
, ("column", Aeson.toJSON column)
|
||||
|
|
|
@ -2,6 +2,8 @@
|
|||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | Various parts of a GraphQL document can be annotated with directives.
|
||||
-- This module describes locations in a document where directives can appear.
|
||||
module Language.GraphQL.AST.DirectiveLocation
|
||||
|
@ -16,7 +18,13 @@ module Language.GraphQL.AST.DirectiveLocation
|
|||
data DirectiveLocation
|
||||
= ExecutableDirectiveLocation ExecutableDirectiveLocation
|
||||
| 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.
|
||||
data ExecutableDirectiveLocation
|
||||
|
@ -27,7 +35,16 @@ data ExecutableDirectiveLocation
|
|||
| FragmentDefinition
|
||||
| FragmentSpread
|
||||
| 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.
|
||||
data TypeSystemDirectiveLocation
|
||||
|
@ -42,4 +59,17 @@ data TypeSystemDirectiveLocation
|
|||
| EnumValue
|
||||
| InputObject
|
||||
| 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 RecordWildCards #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
|
||||
-- follows closely the structure given in the specification. Please refer to
|
||||
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
|
||||
-- for more information.
|
||||
module Language.GraphQL.AST.Document
|
||||
( Alias
|
||||
, Argument(..)
|
||||
( Argument(..)
|
||||
, ArgumentsDefinition(..)
|
||||
, ConstValue(..)
|
||||
, Definition(..)
|
||||
|
@ -15,13 +18,17 @@ module Language.GraphQL.AST.Document
|
|||
, Document
|
||||
, EnumValueDefinition(..)
|
||||
, ExecutableDefinition(..)
|
||||
, Field(..)
|
||||
, FieldDefinition(..)
|
||||
, FragmentDefinition(..)
|
||||
, FragmentSpread(..)
|
||||
, ImplementsInterfaces(..)
|
||||
, InlineFragment(..)
|
||||
, InputValueDefinition(..)
|
||||
, Location(..)
|
||||
, Name
|
||||
, NamedType
|
||||
, Node(..)
|
||||
, NonNullType(..)
|
||||
, ObjectField(..)
|
||||
, OperationDefinition(..)
|
||||
|
@ -47,7 +54,7 @@ import Data.Int (Int32)
|
|||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.DirectiveLocation
|
||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
|
||||
|
||||
-- * Language
|
||||
|
||||
|
@ -68,6 +75,15 @@ instance Ord Location where
|
|||
| thisLine > thatLine = GT
|
||||
| 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
|
||||
|
||||
-- | GraphQL document.
|
||||
|
@ -116,10 +132,15 @@ type SelectionSet = NonEmpty Selection
|
|||
-- | Field selection.
|
||||
type SelectionSetOpt = [Selection]
|
||||
|
||||
-- | Selection is a single entry in a selection set. It can be a single field,
|
||||
-- fragment spread or inline fragment.
|
||||
--
|
||||
-- The only required property of a field is its name. Optionally it can also
|
||||
-- | Selection is a single entry in a selection set. It can be a single 'Field',
|
||||
-- 'FragmentSpread' or an 'InlineFragment'.
|
||||
data Selection
|
||||
= 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.
|
||||
--
|
||||
-- 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.
|
||||
--
|
||||
-- @
|
||||
|
@ -148,23 +188,7 @@ type SelectionSetOpt = [Selection]
|
|||
-- name
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- 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
|
||||
data FragmentSpread = FragmentSpread Name [Directive] Location
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Arguments
|
||||
|
@ -180,23 +204,7 @@ data Selection
|
|||
-- @
|
||||
--
|
||||
-- Here "id" is an argument for the field "user" and its value is 4.
|
||||
data Argument = Argument Name Value 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
|
||||
data Argument = Argument Name (Node Value) Location deriving (Eq, Show)
|
||||
|
||||
-- ** Fragments
|
||||
|
||||
|
@ -238,8 +246,11 @@ data ConstValue
|
|||
-- | Key-value pair.
|
||||
--
|
||||
-- A list of 'ObjectField's represents a GraphQL object type.
|
||||
data ObjectField a = ObjectField Name a
|
||||
deriving (Eq, Show)
|
||||
data ObjectField a = ObjectField
|
||||
{ name :: Name
|
||||
, value :: Node a
|
||||
, location :: Location
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- ** Variables
|
||||
|
||||
|
@ -259,7 +270,8 @@ data ObjectField a = ObjectField Name a
|
|||
--
|
||||
-- Variables are usually passed along with the query, but not in the query
|
||||
-- itself. They make queries reusable.
|
||||
data VariableDefinition = VariableDefinition Name Type (Maybe ConstValue)
|
||||
data VariableDefinition =
|
||||
VariableDefinition Name Type (Maybe (Node ConstValue)) Location
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Type References
|
||||
|
@ -286,7 +298,7 @@ data NonNullType
|
|||
--
|
||||
-- Directives begin with "@", can accept arguments, and can be applied to the
|
||||
-- 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
|
||||
|
||||
|
@ -485,8 +497,8 @@ instance Monoid ArgumentsDefinition where
|
|||
-- @
|
||||
--
|
||||
-- The input type "Point2D" contains two value definitions: "x" and "y".
|
||||
data InputValueDefinition
|
||||
= InputValueDefinition Description Name Type (Maybe ConstValue) [Directive]
|
||||
data InputValueDefinition = InputValueDefinition
|
||||
Description Name Type (Maybe (Node ConstValue)) [Directive]
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Unions
|
||||
|
|
|
@ -1,6 +1,8 @@
|
|||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-- | This module defines a minifier and a printer for the @GraphQL@ language.
|
||||
module Language.GraphQL.AST.Encoder
|
||||
|
@ -25,7 +27,7 @@ import Data.Text.Lazy.Builder (Builder)
|
|||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
|
||||
import Data.Text.Lazy.Builder.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
|
||||
-- pretty printed.
|
||||
|
@ -44,77 +46,78 @@ minified :: Formatter
|
|||
minified = Minified
|
||||
|
||||
-- | Converts a Document' into a string.
|
||||
document :: Formatter -> Document -> Lazy.Text
|
||||
document :: Formatter -> Full.Document -> Lazy.Text
|
||||
document formatter defs
|
||||
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
|
||||
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
|
||||
where
|
||||
encodeDocument = foldr executableDefinition [] defs
|
||||
executableDefinition (ExecutableDefinition executableDefinition') acc =
|
||||
executableDefinition (Full.ExecutableDefinition executableDefinition') acc =
|
||||
definition formatter executableDefinition' : acc
|
||||
executableDefinition _ acc = acc
|
||||
|
||||
-- | Converts a t'ExecutableDefinition' into a string.
|
||||
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
|
||||
-- | Converts a t'Full.ExecutableDefinition' into a string.
|
||||
definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
|
||||
definition formatter x
|
||||
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
|
||||
| Minified <- formatter = encodeDefinition x
|
||||
where
|
||||
encodeDefinition (DefinitionOperation operation)
|
||||
encodeDefinition (Full.DefinitionOperation operation)
|
||||
= operationDefinition formatter operation
|
||||
encodeDefinition (DefinitionFragment fragment)
|
||||
encodeDefinition (Full.DefinitionFragment fragment)
|
||||
= fragmentDefinition formatter fragment
|
||||
|
||||
-- | Converts a 'OperationDefinition into a string.
|
||||
operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
|
||||
-- | Converts a 'Full.OperationDefinition into a string.
|
||||
operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
|
||||
operationDefinition formatter = \case
|
||||
SelectionSet sels _ -> selectionSet formatter sels
|
||||
OperationDefinition Query name vars dirs sels _ ->
|
||||
"query " <> node formatter name vars dirs sels
|
||||
OperationDefinition Mutation name vars dirs sels _ ->
|
||||
"mutation " <> node formatter name vars dirs sels
|
||||
OperationDefinition Subscription name vars dirs sels _ ->
|
||||
"subscription " <> node formatter name vars dirs sels
|
||||
Full.SelectionSet sels _ -> selectionSet formatter sels
|
||||
Full.OperationDefinition Full.Query name vars dirs sels _ ->
|
||||
"query " <> root name vars dirs sels
|
||||
Full.OperationDefinition Full.Mutation name vars dirs sels _ ->
|
||||
"mutation " <> root name vars dirs sels
|
||||
Full.OperationDefinition Full.Subscription 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.
|
||||
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 -> [Full.VariableDefinition] -> Lazy.Text
|
||||
variableDefinitions formatter
|
||||
= parensCommas formatter $ variableDefinition formatter
|
||||
|
||||
variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text
|
||||
variableDefinition formatter (VariableDefinition var ty defaultValue')
|
||||
= variable var
|
||||
variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
|
||||
variableDefinition formatter variableDefinition' =
|
||||
let Full.VariableDefinition variableName variableType defaultValue' _ =
|
||||
variableDefinition'
|
||||
in variable variableName
|
||||
<> eitherFormat formatter ": " ":"
|
||||
<> type' ty
|
||||
<> maybe mempty (defaultValue formatter) defaultValue'
|
||||
<> type' variableType
|
||||
<> maybe mempty (defaultValue formatter) (Full.node <$> defaultValue')
|
||||
|
||||
defaultValue :: Formatter -> ConstValue -> Lazy.Text
|
||||
defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text
|
||||
defaultValue formatter val
|
||||
= eitherFormat formatter " = " "="
|
||||
<> value formatter (fromConstValue val)
|
||||
|
||||
variable :: Name -> Lazy.Text
|
||||
variable :: Full.Name -> Lazy.Text
|
||||
variable var = "$" <> Lazy.Text.fromStrict var
|
||||
|
||||
selectionSet :: Formatter -> SelectionSet -> Lazy.Text
|
||||
selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
|
||||
selectionSet formatter
|
||||
= bracesList formatter (selection formatter)
|
||||
. NonEmpty.toList
|
||||
|
||||
selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text
|
||||
selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
|
||||
selectionSetOpt formatter = bracesList formatter $ selection formatter
|
||||
|
||||
indentSymbol :: Lazy.Text
|
||||
|
@ -123,15 +126,15 @@ indentSymbol = " "
|
|||
indent :: (Integral a) => a -> Lazy.Text
|
||||
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
|
||||
where
|
||||
encodeSelection (Field alias name args directives' selections) =
|
||||
field incrementIndent alias name args directives' selections
|
||||
encodeSelection (InlineFragment typeCondition directives' selections) =
|
||||
inlineFragment incrementIndent typeCondition directives' selections
|
||||
encodeSelection (FragmentSpread name directives') =
|
||||
fragmentSpread incrementIndent name directives'
|
||||
encodeSelection (Full.FieldSelection fieldSelection) =
|
||||
field incrementIndent fieldSelection
|
||||
encodeSelection (Full.InlineFragmentSelection fragmentSelection) =
|
||||
inlineFragment incrementIndent fragmentSelection
|
||||
encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =
|
||||
fragmentSpread incrementIndent fragmentSelection
|
||||
incrementIndent
|
||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||
| otherwise = Minified
|
||||
|
@ -142,15 +145,9 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
|
|||
colon :: Formatter -> Lazy.Text
|
||||
colon formatter = eitherFormat formatter ": " ":"
|
||||
|
||||
-- | Converts Field into a string
|
||||
field :: Formatter ->
|
||||
Maybe Name ->
|
||||
Name ->
|
||||
[Argument] ->
|
||||
[Directive] ->
|
||||
[Selection] ->
|
||||
Lazy.Text
|
||||
field formatter alias name args dirs set
|
||||
-- | Converts Field into a string.
|
||||
field :: Formatter -> Full.Field -> Lazy.Text
|
||||
field formatter (Full.Field alias name args dirs set _)
|
||||
= optempty prependAlias (fold alias)
|
||||
<> Lazy.Text.fromStrict name
|
||||
<> optempty (arguments formatter) args
|
||||
|
@ -161,36 +158,32 @@ field formatter alias name args dirs set
|
|||
selectionSetOpt' = (eitherFormat formatter " " "" <>)
|
||||
. selectionSetOpt formatter
|
||||
|
||||
arguments :: Formatter -> [Argument] -> Lazy.Text
|
||||
arguments :: Formatter -> [Full.Argument] -> Lazy.Text
|
||||
arguments formatter = parensCommas formatter $ argument formatter
|
||||
|
||||
argument :: Formatter -> Argument -> Lazy.Text
|
||||
argument formatter (Argument name value')
|
||||
argument :: Formatter -> Full.Argument -> Lazy.Text
|
||||
argument formatter (Full.Argument name value' _)
|
||||
= Lazy.Text.fromStrict name
|
||||
<> colon formatter
|
||||
<> value formatter value'
|
||||
<> value formatter (Full.node value')
|
||||
|
||||
-- * Fragments
|
||||
|
||||
fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
|
||||
fragmentSpread formatter name directives'
|
||||
fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
|
||||
fragmentSpread formatter (Full.FragmentSpread name directives' _)
|
||||
= "..." <> Lazy.Text.fromStrict name
|
||||
<> optempty (directives formatter) directives'
|
||||
|
||||
inlineFragment ::
|
||||
Formatter ->
|
||||
Maybe TypeCondition ->
|
||||
[Directive] ->
|
||||
SelectionSet ->
|
||||
Lazy.Text
|
||||
inlineFragment formatter tc dirs sels = "... on "
|
||||
<> Lazy.Text.fromStrict (fold tc)
|
||||
<> directives formatter dirs
|
||||
inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
|
||||
inlineFragment formatter (Full.InlineFragment typeCondition directives' selections _)
|
||||
= "... on "
|
||||
<> Lazy.Text.fromStrict (fold typeCondition)
|
||||
<> directives formatter directives'
|
||||
<> eitherFormat formatter " " mempty
|
||||
<> selectionSet formatter sels
|
||||
<> selectionSet formatter selections
|
||||
|
||||
fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
|
||||
fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
|
||||
fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
|
||||
fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels _)
|
||||
= "fragment " <> Lazy.Text.fromStrict name
|
||||
<> " on " <> Lazy.Text.fromStrict tc
|
||||
<> optempty (directives formatter) dirs
|
||||
|
@ -199,39 +192,39 @@ fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
|
|||
|
||||
-- * Miscellaneous
|
||||
|
||||
-- | Converts a 'Directive' into a string.
|
||||
directive :: Formatter -> Directive -> Lazy.Text
|
||||
directive formatter (Directive name args)
|
||||
-- | Converts a 'Full.Directive' into a string.
|
||||
directive :: Formatter -> Full.Directive -> Lazy.Text
|
||||
directive formatter (Full.Directive name 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 formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
|
||||
|
||||
-- | Converts a 'Value' into a string.
|
||||
value :: Formatter -> Value -> Lazy.Text
|
||||
value _ (Variable x) = variable x
|
||||
value _ (Int x) = Builder.toLazyText $ decimal x
|
||||
value _ (Float x) = Builder.toLazyText $ realFloat x
|
||||
value _ (Boolean x) = booleanValue x
|
||||
value _ Null = "null"
|
||||
value formatter (String string) = stringValue formatter string
|
||||
value _ (Enum x) = Lazy.Text.fromStrict x
|
||||
value formatter (List x) = listValue formatter x
|
||||
value formatter (Object x) = objectValue formatter x
|
||||
-- | Converts a 'Full.Value' into a string.
|
||||
value :: Formatter -> Full.Value -> Lazy.Text
|
||||
value _ (Full.Variable x) = variable x
|
||||
value _ (Full.Int x) = Builder.toLazyText $ decimal x
|
||||
value _ (Full.Float x) = Builder.toLazyText $ realFloat x
|
||||
value _ (Full.Boolean x) = booleanValue x
|
||||
value _ Full.Null = "null"
|
||||
value formatter (Full.String string) = stringValue formatter string
|
||||
value _ (Full.Enum x) = Lazy.Text.fromStrict x
|
||||
value formatter (Full.List x) = listValue formatter x
|
||||
value formatter (Full.Object x) = objectValue formatter x
|
||||
|
||||
fromConstValue :: ConstValue -> Value
|
||||
fromConstValue (ConstInt x) = Int x
|
||||
fromConstValue (ConstFloat x) = Float x
|
||||
fromConstValue (ConstBoolean x) = Boolean x
|
||||
fromConstValue ConstNull = Null
|
||||
fromConstValue (ConstString string) = String string
|
||||
fromConstValue (ConstEnum x) = Enum x
|
||||
fromConstValue (ConstList x) = List $ fromConstValue <$> x
|
||||
fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x
|
||||
fromConstValue :: Full.ConstValue -> Full.Value
|
||||
fromConstValue (Full.ConstInt x) = Full.Int x
|
||||
fromConstValue (Full.ConstFloat x) = Full.Float x
|
||||
fromConstValue (Full.ConstBoolean x) = Full.Boolean x
|
||||
fromConstValue Full.ConstNull = Full.Null
|
||||
fromConstValue (Full.ConstString string) = Full.String string
|
||||
fromConstValue (Full.ConstEnum x) = Full.Enum x
|
||||
fromConstValue (Full.ConstList x) = Full.List $ fromConstValue <$> x
|
||||
fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x
|
||||
where
|
||||
fromConstObjectField (ObjectField key value') =
|
||||
ObjectField key $ fromConstValue value'
|
||||
fromConstObjectField Full.ObjectField{value = value', ..} =
|
||||
Full.ObjectField name (fromConstValue <$> value') location
|
||||
|
||||
booleanValue :: Bool -> Lazy.Text
|
||||
booleanValue True = "true"
|
||||
|
@ -288,10 +281,10 @@ escape char'
|
|||
where
|
||||
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
|
||||
|
||||
objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text
|
||||
objectValue :: Formatter -> [Full.ObjectField Full.Value] -> Lazy.Text
|
||||
objectValue formatter = intercalate $ objectField formatter
|
||||
where
|
||||
intercalate f
|
||||
|
@ -299,22 +292,22 @@ objectValue formatter = intercalate $ objectField formatter
|
|||
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
|
||||
. fmap f
|
||||
|
||||
objectField :: Formatter -> ObjectField Value -> Lazy.Text
|
||||
objectField formatter (ObjectField name value') =
|
||||
objectField :: Formatter -> Full.ObjectField Full.Value -> Lazy.Text
|
||||
objectField formatter (Full.ObjectField name (Full.Node value' _) _) =
|
||||
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
|
||||
|
||||
-- | Converts a 'Type' a type into a string.
|
||||
type' :: Type -> Lazy.Text
|
||||
type' (TypeNamed x) = Lazy.Text.fromStrict x
|
||||
type' (TypeList x) = listType x
|
||||
type' (TypeNonNull x) = nonNullType x
|
||||
-- | Converts a 'Full.Type' a type into a string.
|
||||
type' :: Full.Type -> Lazy.Text
|
||||
type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
|
||||
type' (Full.TypeList x) = listType x
|
||||
type' (Full.TypeNonNull x) = nonNullType x
|
||||
|
||||
listType :: Type -> Lazy.Text
|
||||
listType :: Full.Type -> Lazy.Text
|
||||
listType x = brackets (type' x)
|
||||
|
||||
nonNullType :: NonNullType -> Lazy.Text
|
||||
nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
||||
nonNullType (NonNullTypeList x) = listType x <> "!"
|
||||
nonNullType :: Full.NonNullType -> Lazy.Text
|
||||
nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
||||
nonNullType (Full.NonNullTypeList x) = listType x <> "!"
|
||||
|
||||
-- * Internal
|
||||
|
||||
|
|
|
@ -92,16 +92,16 @@ dollar :: Parser T.Text
|
|||
dollar = symbol "$"
|
||||
|
||||
-- | Parser for "@".
|
||||
at :: Parser Text
|
||||
at = symbol "@"
|
||||
at :: Parser ()
|
||||
at = symbol "@" >> pure ()
|
||||
|
||||
-- | Parser for "&".
|
||||
amp :: Parser T.Text
|
||||
amp = symbol "&"
|
||||
|
||||
-- | Parser for ":".
|
||||
colon :: Parser T.Text
|
||||
colon = symbol ":"
|
||||
colon :: Parser ()
|
||||
colon = symbol ":" >> pure ()
|
||||
|
||||
-- | Parser for "=".
|
||||
equals :: Parser T.Text
|
||||
|
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
@ -18,7 +19,7 @@ import Language.GraphQL.AST.DirectiveLocation
|
|||
, ExecutableDirectiveLocation
|
||||
, TypeSystemDirectiveLocation
|
||||
)
|
||||
import Language.GraphQL.AST.Document
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import Language.GraphQL.AST.Lexer
|
||||
import Text.Megaparsec
|
||||
( MonadParsec(..)
|
||||
|
@ -32,13 +33,13 @@ import Text.Megaparsec
|
|||
)
|
||||
|
||||
-- | Parser for the GraphQL documents.
|
||||
document :: Parser Document
|
||||
document :: Parser Full.Document
|
||||
document = unicodeBOM
|
||||
*> spaceConsumer
|
||||
*> lexeme (NonEmpty.some definition)
|
||||
|
||||
definition :: Parser Definition
|
||||
definition = ExecutableDefinition <$> executableDefinition
|
||||
definition :: Parser Full.Definition
|
||||
definition = Full.ExecutableDefinition <$> executableDefinition
|
||||
<|> typeSystemDefinition'
|
||||
<|> typeSystemExtension'
|
||||
<?> "Definition"
|
||||
|
@ -46,41 +47,41 @@ definition = ExecutableDefinition <$> executableDefinition
|
|||
typeSystemDefinition' = do
|
||||
location <- getLocation
|
||||
definition' <- typeSystemDefinition
|
||||
pure $ TypeSystemDefinition definition' location
|
||||
pure $ Full.TypeSystemDefinition definition' location
|
||||
typeSystemExtension' = do
|
||||
location <- getLocation
|
||||
definition' <- typeSystemExtension
|
||||
pure $ TypeSystemExtension definition' location
|
||||
pure $ Full.TypeSystemExtension definition' location
|
||||
|
||||
getLocation :: Parser Location
|
||||
getLocation :: Parser Full.Location
|
||||
getLocation = fromSourcePosition <$> getSourcePos
|
||||
where
|
||||
fromSourcePosition SourcePos{..} =
|
||||
Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
|
||||
Full.Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
|
||||
wordFromPosition = fromIntegral . unPos
|
||||
|
||||
executableDefinition :: Parser ExecutableDefinition
|
||||
executableDefinition = DefinitionOperation <$> operationDefinition
|
||||
<|> DefinitionFragment <$> fragmentDefinition
|
||||
executableDefinition :: Parser Full.ExecutableDefinition
|
||||
executableDefinition = Full.DefinitionOperation <$> operationDefinition
|
||||
<|> Full.DefinitionFragment <$> fragmentDefinition
|
||||
<?> "ExecutableDefinition"
|
||||
|
||||
typeSystemDefinition :: Parser TypeSystemDefinition
|
||||
typeSystemDefinition :: Parser Full.TypeSystemDefinition
|
||||
typeSystemDefinition = schemaDefinition
|
||||
<|> typeSystemDefinitionWithDescription
|
||||
<?> "TypeSystemDefinition"
|
||||
where
|
||||
typeSystemDefinitionWithDescription = description
|
||||
>>= liftA2 (<|>) typeDefinition' directiveDefinition
|
||||
typeDefinition' description' = TypeDefinition
|
||||
typeDefinition' description' = Full.TypeDefinition
|
||||
<$> typeDefinition description'
|
||||
|
||||
typeSystemExtension :: Parser TypeSystemExtension
|
||||
typeSystemExtension = SchemaExtension <$> schemaExtension
|
||||
<|> TypeExtension <$> typeExtension
|
||||
typeSystemExtension :: Parser Full.TypeSystemExtension
|
||||
typeSystemExtension = Full.SchemaExtension <$> schemaExtension
|
||||
<|> Full.TypeExtension <$> typeExtension
|
||||
<?> "TypeSystemExtension"
|
||||
|
||||
directiveDefinition :: Description -> Parser TypeSystemDefinition
|
||||
directiveDefinition description' = DirectiveDefinition description'
|
||||
directiveDefinition :: Full.Description -> Parser Full.TypeSystemDefinition
|
||||
directiveDefinition description' = Full.DirectiveDefinition description'
|
||||
<$ symbol "directive"
|
||||
<* at
|
||||
<*> name
|
||||
|
@ -124,7 +125,7 @@ typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
|
|||
<|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
|
||||
<?> "TypeSystemDirectiveLocation"
|
||||
|
||||
typeDefinition :: Description -> Parser TypeDefinition
|
||||
typeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||
typeDefinition description' = scalarTypeDefinition description'
|
||||
<|> objectTypeDefinition description'
|
||||
<|> interfaceTypeDefinition description'
|
||||
|
@ -133,7 +134,7 @@ typeDefinition description' = scalarTypeDefinition description'
|
|||
<|> inputObjectTypeDefinition description'
|
||||
<?> "TypeDefinition"
|
||||
|
||||
typeExtension :: Parser TypeExtension
|
||||
typeExtension :: Parser Full.TypeExtension
|
||||
typeExtension = scalarTypeExtension
|
||||
<|> objectTypeExtension
|
||||
<|> interfaceTypeExtension
|
||||
|
@ -142,143 +143,143 @@ typeExtension = scalarTypeExtension
|
|||
<|> inputObjectTypeExtension
|
||||
<?> "TypeExtension"
|
||||
|
||||
scalarTypeDefinition :: Description -> Parser TypeDefinition
|
||||
scalarTypeDefinition description' = ScalarTypeDefinition description'
|
||||
scalarTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||
scalarTypeDefinition description' = Full.ScalarTypeDefinition description'
|
||||
<$ symbol "scalar"
|
||||
<*> name
|
||||
<*> directives
|
||||
<?> "ScalarTypeDefinition"
|
||||
|
||||
scalarTypeExtension :: Parser TypeExtension
|
||||
scalarTypeExtension :: Parser Full.TypeExtension
|
||||
scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
|
||||
$ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
|
||||
$ (Full.ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
|
||||
|
||||
objectTypeDefinition :: Description -> Parser TypeDefinition
|
||||
objectTypeDefinition description' = ObjectTypeDefinition description'
|
||||
objectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||
objectTypeDefinition description' = Full.ObjectTypeDefinition description'
|
||||
<$ symbol "type"
|
||||
<*> name
|
||||
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> directives
|
||||
<*> braces (many fieldDefinition)
|
||||
<?> "ObjectTypeDefinition"
|
||||
|
||||
objectTypeExtension :: Parser TypeExtension
|
||||
objectTypeExtension :: Parser Full.TypeExtension
|
||||
objectTypeExtension = extend "type" "ObjectTypeExtension"
|
||||
$ fieldsDefinitionExtension :|
|
||||
[ directivesExtension
|
||||
, implementsInterfacesExtension
|
||||
]
|
||||
where
|
||||
fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension
|
||||
fieldsDefinitionExtension = Full.ObjectTypeFieldsDefinitionExtension
|
||||
<$> name
|
||||
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> directives
|
||||
<*> braces (NonEmpty.some fieldDefinition)
|
||||
directivesExtension = ObjectTypeDirectivesExtension
|
||||
directivesExtension = Full.ObjectTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> NonEmpty.some directive
|
||||
implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension
|
||||
implementsInterfacesExtension = Full.ObjectTypeImplementsInterfacesExtension
|
||||
<$> name
|
||||
<*> implementsInterfaces NonEmpty.sepBy1
|
||||
|
||||
description :: Parser Description
|
||||
description = Description
|
||||
description :: Parser Full.Description
|
||||
description = Full.Description
|
||||
<$> optional stringValue
|
||||
<?> "Description"
|
||||
|
||||
unionTypeDefinition :: Description -> Parser TypeDefinition
|
||||
unionTypeDefinition description' = UnionTypeDefinition description'
|
||||
unionTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||
unionTypeDefinition description' = Full.UnionTypeDefinition description'
|
||||
<$ symbol "union"
|
||||
<*> name
|
||||
<*> directives
|
||||
<*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)
|
||||
<*> option (Full.UnionMemberTypes []) (unionMemberTypes sepBy1)
|
||||
<?> "UnionTypeDefinition"
|
||||
|
||||
unionTypeExtension :: Parser TypeExtension
|
||||
unionTypeExtension :: Parser Full.TypeExtension
|
||||
unionTypeExtension = extend "union" "UnionTypeExtension"
|
||||
$ unionMemberTypesExtension :| [directivesExtension]
|
||||
where
|
||||
unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension
|
||||
unionMemberTypesExtension = Full.UnionTypeUnionMemberTypesExtension
|
||||
<$> name
|
||||
<*> directives
|
||||
<*> unionMemberTypes NonEmpty.sepBy1
|
||||
directivesExtension = UnionTypeDirectivesExtension
|
||||
directivesExtension = Full.UnionTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> NonEmpty.some directive
|
||||
|
||||
unionMemberTypes ::
|
||||
Foldable t =>
|
||||
(Parser Text -> Parser Text -> Parser (t NamedType)) ->
|
||||
Parser (UnionMemberTypes t)
|
||||
unionMemberTypes sepBy' = UnionMemberTypes
|
||||
(Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
|
||||
Parser (Full.UnionMemberTypes t)
|
||||
unionMemberTypes sepBy' = Full.UnionMemberTypes
|
||||
<$ equals
|
||||
<* optional pipe
|
||||
<*> name `sepBy'` pipe
|
||||
<?> "UnionMemberTypes"
|
||||
|
||||
interfaceTypeDefinition :: Description -> Parser TypeDefinition
|
||||
interfaceTypeDefinition description' = InterfaceTypeDefinition description'
|
||||
interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||
interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
|
||||
<$ symbol "interface"
|
||||
<*> name
|
||||
<*> directives
|
||||
<*> braces (many fieldDefinition)
|
||||
<?> "InterfaceTypeDefinition"
|
||||
|
||||
interfaceTypeExtension :: Parser TypeExtension
|
||||
interfaceTypeExtension :: Parser Full.TypeExtension
|
||||
interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
|
||||
$ fieldsDefinitionExtension :| [directivesExtension]
|
||||
where
|
||||
fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension
|
||||
fieldsDefinitionExtension = Full.InterfaceTypeFieldsDefinitionExtension
|
||||
<$> name
|
||||
<*> directives
|
||||
<*> braces (NonEmpty.some fieldDefinition)
|
||||
directivesExtension = InterfaceTypeDirectivesExtension
|
||||
directivesExtension = Full.InterfaceTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> NonEmpty.some directive
|
||||
|
||||
enumTypeDefinition :: Description -> Parser TypeDefinition
|
||||
enumTypeDefinition description' = EnumTypeDefinition description'
|
||||
enumTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||
enumTypeDefinition description' = Full.EnumTypeDefinition description'
|
||||
<$ symbol "enum"
|
||||
<*> name
|
||||
<*> directives
|
||||
<*> listOptIn braces enumValueDefinition
|
||||
<?> "EnumTypeDefinition"
|
||||
|
||||
enumTypeExtension :: Parser TypeExtension
|
||||
enumTypeExtension :: Parser Full.TypeExtension
|
||||
enumTypeExtension = extend "enum" "EnumTypeExtension"
|
||||
$ enumValuesDefinitionExtension :| [directivesExtension]
|
||||
where
|
||||
enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension
|
||||
enumValuesDefinitionExtension = Full.EnumTypeEnumValuesDefinitionExtension
|
||||
<$> name
|
||||
<*> directives
|
||||
<*> braces (NonEmpty.some enumValueDefinition)
|
||||
directivesExtension = EnumTypeDirectivesExtension
|
||||
directivesExtension = Full.EnumTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> NonEmpty.some directive
|
||||
|
||||
inputObjectTypeDefinition :: Description -> Parser TypeDefinition
|
||||
inputObjectTypeDefinition description' = InputObjectTypeDefinition description'
|
||||
inputObjectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||
inputObjectTypeDefinition description' = Full.InputObjectTypeDefinition description'
|
||||
<$ symbol "input"
|
||||
<*> name
|
||||
<*> directives
|
||||
<*> listOptIn braces inputValueDefinition
|
||||
<?> "InputObjectTypeDefinition"
|
||||
|
||||
inputObjectTypeExtension :: Parser TypeExtension
|
||||
inputObjectTypeExtension :: Parser Full.TypeExtension
|
||||
inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
|
||||
$ inputFieldsDefinitionExtension :| [directivesExtension]
|
||||
where
|
||||
inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension
|
||||
inputFieldsDefinitionExtension = Full.InputObjectTypeInputFieldsDefinitionExtension
|
||||
<$> name
|
||||
<*> directives
|
||||
<*> braces (NonEmpty.some inputValueDefinition)
|
||||
directivesExtension = InputObjectTypeDirectivesExtension
|
||||
directivesExtension = Full.InputObjectTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> NonEmpty.some directive
|
||||
|
||||
enumValueDefinition :: Parser EnumValueDefinition
|
||||
enumValueDefinition = EnumValueDefinition
|
||||
enumValueDefinition :: Parser Full.EnumValueDefinition
|
||||
enumValueDefinition = Full.EnumValueDefinition
|
||||
<$> description
|
||||
<*> enumValue
|
||||
<*> directives
|
||||
|
@ -286,16 +287,16 @@ enumValueDefinition = EnumValueDefinition
|
|||
|
||||
implementsInterfaces ::
|
||||
Foldable t =>
|
||||
(Parser Text -> Parser Text -> Parser (t NamedType)) ->
|
||||
Parser (ImplementsInterfaces t)
|
||||
implementsInterfaces sepBy' = ImplementsInterfaces
|
||||
(Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
|
||||
Parser (Full.ImplementsInterfaces t)
|
||||
implementsInterfaces sepBy' = Full.ImplementsInterfaces
|
||||
<$ symbol "implements"
|
||||
<* optional amp
|
||||
<*> name `sepBy'` amp
|
||||
<?> "ImplementsInterfaces"
|
||||
|
||||
inputValueDefinition :: Parser InputValueDefinition
|
||||
inputValueDefinition = InputValueDefinition
|
||||
inputValueDefinition :: Parser Full.InputValueDefinition
|
||||
inputValueDefinition = Full.InputValueDefinition
|
||||
<$> description
|
||||
<*> name
|
||||
<* colon
|
||||
|
@ -304,13 +305,13 @@ inputValueDefinition = InputValueDefinition
|
|||
<*> directives
|
||||
<?> "InputValueDefinition"
|
||||
|
||||
argumentsDefinition :: Parser ArgumentsDefinition
|
||||
argumentsDefinition = ArgumentsDefinition
|
||||
argumentsDefinition :: Parser Full.ArgumentsDefinition
|
||||
argumentsDefinition = Full.ArgumentsDefinition
|
||||
<$> listOptIn parens inputValueDefinition
|
||||
<?> "ArgumentsDefinition"
|
||||
|
||||
fieldDefinition :: Parser FieldDefinition
|
||||
fieldDefinition = FieldDefinition
|
||||
fieldDefinition :: Parser Full.FieldDefinition
|
||||
fieldDefinition = Full.FieldDefinition
|
||||
<$> description
|
||||
<*> name
|
||||
<*> argumentsDefinition
|
||||
|
@ -319,33 +320,33 @@ fieldDefinition = FieldDefinition
|
|||
<*> directives
|
||||
<?> "FieldDefinition"
|
||||
|
||||
schemaDefinition :: Parser TypeSystemDefinition
|
||||
schemaDefinition = SchemaDefinition
|
||||
schemaDefinition :: Parser Full.TypeSystemDefinition
|
||||
schemaDefinition = Full.SchemaDefinition
|
||||
<$ symbol "schema"
|
||||
<*> directives
|
||||
<*> operationTypeDefinitions
|
||||
<?> "SchemaDefinition"
|
||||
|
||||
operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition)
|
||||
operationTypeDefinitions :: Parser (NonEmpty Full.OperationTypeDefinition)
|
||||
operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
|
||||
|
||||
schemaExtension :: Parser SchemaExtension
|
||||
schemaExtension :: Parser Full.SchemaExtension
|
||||
schemaExtension = extend "schema" "SchemaExtension"
|
||||
$ schemaOperationExtension :| [directivesExtension]
|
||||
where
|
||||
directivesExtension = SchemaDirectivesExtension
|
||||
directivesExtension = Full.SchemaDirectivesExtension
|
||||
<$> NonEmpty.some directive
|
||||
schemaOperationExtension = SchemaOperationExtension
|
||||
schemaOperationExtension = Full.SchemaOperationExtension
|
||||
<$> directives
|
||||
<*> operationTypeDefinitions
|
||||
|
||||
operationTypeDefinition :: Parser OperationTypeDefinition
|
||||
operationTypeDefinition = OperationTypeDefinition
|
||||
operationTypeDefinition :: Parser Full.OperationTypeDefinition
|
||||
operationTypeDefinition = Full.OperationTypeDefinition
|
||||
<$> operationType <* colon
|
||||
<*> name
|
||||
<?> "OperationTypeDefinition"
|
||||
|
||||
operationDefinition :: Parser OperationDefinition
|
||||
operationDefinition :: Parser Full.OperationDefinition
|
||||
operationDefinition = shorthand
|
||||
<|> operationDefinition'
|
||||
<?> "OperationDefinition"
|
||||
|
@ -353,7 +354,7 @@ operationDefinition = shorthand
|
|||
shorthand = do
|
||||
location <- getLocation
|
||||
selectionSet' <- selectionSet
|
||||
pure $ SelectionSet selectionSet' location
|
||||
pure $ Full.SelectionSet selectionSet' location
|
||||
operationDefinition' = do
|
||||
location <- getLocation
|
||||
operationType' <- operationType
|
||||
|
@ -361,60 +362,74 @@ operationDefinition = shorthand
|
|||
variableDefinitions' <- variableDefinitions
|
||||
directives' <- directives
|
||||
selectionSet' <- selectionSet
|
||||
pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location
|
||||
pure $ Full.OperationDefinition
|
||||
operationType'
|
||||
operationName
|
||||
variableDefinitions'
|
||||
directives'
|
||||
selectionSet'
|
||||
location
|
||||
|
||||
operationType :: Parser OperationType
|
||||
operationType = Query <$ symbol "query"
|
||||
<|> Mutation <$ symbol "mutation"
|
||||
<|> Subscription <$ symbol "subscription"
|
||||
operationType :: Parser Full.OperationType
|
||||
operationType = Full.Query <$ symbol "query"
|
||||
<|> Full.Mutation <$ symbol "mutation"
|
||||
<|> Full.Subscription <$ symbol "subscription"
|
||||
<?> "OperationType"
|
||||
|
||||
selectionSet :: Parser SelectionSet
|
||||
selectionSet :: Parser Full.SelectionSet
|
||||
selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"
|
||||
|
||||
selectionSetOpt :: Parser SelectionSetOpt
|
||||
selectionSetOpt :: Parser Full.SelectionSetOpt
|
||||
selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
|
||||
|
||||
selection :: Parser Selection
|
||||
selection = field
|
||||
<|> try fragmentSpread
|
||||
<|> inlineFragment
|
||||
selection :: Parser Full.Selection
|
||||
selection = Full.FieldSelection <$> field
|
||||
<|> Full.FragmentSpreadSelection <$> try fragmentSpread
|
||||
<|> Full.InlineFragmentSelection <$> inlineFragment
|
||||
<?> "Selection"
|
||||
|
||||
field :: Parser Selection
|
||||
field = Field
|
||||
<$> optional alias
|
||||
<*> name
|
||||
<*> arguments
|
||||
<*> directives
|
||||
<*> selectionSetOpt
|
||||
<?> "Field"
|
||||
field :: Parser Full.Field
|
||||
field = label "Field" $ do
|
||||
location <- getLocation
|
||||
alias' <- optional alias
|
||||
name' <- name
|
||||
arguments' <- arguments
|
||||
directives' <- directives
|
||||
selectionSetOpt' <- selectionSetOpt
|
||||
pure $ Full.Field alias' name' arguments' directives' selectionSetOpt' location
|
||||
|
||||
alias :: Parser Alias
|
||||
alias :: Parser Full.Name
|
||||
alias = try (name <* colon) <?> "Alias"
|
||||
|
||||
arguments :: Parser [Argument]
|
||||
arguments :: Parser [Full.Argument]
|
||||
arguments = listOptIn parens argument <?> "Arguments"
|
||||
|
||||
argument :: Parser Argument
|
||||
argument = Argument <$> name <* colon <*> value <?> "Argument"
|
||||
argument :: Parser Full.Argument
|
||||
argument = label "Argument" $ do
|
||||
location <- getLocation
|
||||
name' <- name
|
||||
colon
|
||||
value' <- valueNode value
|
||||
pure $ Full.Argument name' value' location
|
||||
|
||||
fragmentSpread :: Parser Selection
|
||||
fragmentSpread = FragmentSpread
|
||||
<$ spread
|
||||
<*> fragmentName
|
||||
<*> directives
|
||||
<?> "FragmentSpread"
|
||||
fragmentSpread :: Parser Full.FragmentSpread
|
||||
fragmentSpread = label "FragmentSpread" $ do
|
||||
location <- getLocation
|
||||
_ <- spread
|
||||
fragmentName' <- fragmentName
|
||||
directives' <- directives
|
||||
pure $ Full.FragmentSpread fragmentName' directives' location
|
||||
|
||||
inlineFragment :: Parser Selection
|
||||
inlineFragment = InlineFragment
|
||||
<$ spread
|
||||
<*> optional typeCondition
|
||||
<*> directives
|
||||
<*> selectionSet
|
||||
<?> "InlineFragment"
|
||||
inlineFragment :: Parser Full.InlineFragment
|
||||
inlineFragment = label "InlineFragment" $ do
|
||||
location <- getLocation
|
||||
_ <- spread
|
||||
typeCondition' <- optional typeCondition
|
||||
directives' <- directives
|
||||
selectionSet' <- selectionSet
|
||||
pure $ Full.InlineFragment typeCondition' directives' selectionSet' location
|
||||
|
||||
fragmentDefinition :: Parser FragmentDefinition
|
||||
fragmentDefinition :: Parser Full.FragmentDefinition
|
||||
fragmentDefinition = label "FragmentDefinition" $ do
|
||||
location <- getLocation
|
||||
_ <- symbol "fragment"
|
||||
|
@ -422,36 +437,42 @@ fragmentDefinition = label "FragmentDefinition" $ do
|
|||
typeCondition' <- typeCondition
|
||||
directives' <- directives
|
||||
selectionSet' <- selectionSet
|
||||
pure $ FragmentDefinition
|
||||
pure $ Full.FragmentDefinition
|
||||
fragmentName' typeCondition' directives' selectionSet' location
|
||||
|
||||
fragmentName :: Parser Name
|
||||
fragmentName :: Parser Full.Name
|
||||
fragmentName = but (symbol "on") *> name <?> "FragmentName"
|
||||
|
||||
typeCondition :: Parser TypeCondition
|
||||
typeCondition :: Parser Full.TypeCondition
|
||||
typeCondition = symbol "on" *> name <?> "TypeCondition"
|
||||
|
||||
value :: Parser Value
|
||||
value = Variable <$> variable
|
||||
<|> Float <$> try float
|
||||
<|> Int <$> integer
|
||||
<|> Boolean <$> booleanValue
|
||||
<|> Null <$ nullValue
|
||||
<|> String <$> stringValue
|
||||
<|> Enum <$> try enumValue
|
||||
<|> List <$> brackets (some value)
|
||||
<|> Object <$> braces (some $ objectField value)
|
||||
valueNode :: forall a. Parser a -> Parser (Full.Node a)
|
||||
valueNode valueParser = do
|
||||
location <- getLocation
|
||||
value' <- valueParser
|
||||
pure $ Full.Node value' location
|
||||
|
||||
value :: Parser Full.Value
|
||||
value = Full.Variable <$> variable
|
||||
<|> Full.Float <$> try float
|
||||
<|> 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"
|
||||
|
||||
constValue :: Parser ConstValue
|
||||
constValue = ConstFloat <$> try float
|
||||
<|> ConstInt <$> integer
|
||||
<|> ConstBoolean <$> booleanValue
|
||||
<|> ConstNull <$ nullValue
|
||||
<|> ConstString <$> stringValue
|
||||
<|> ConstEnum <$> try enumValue
|
||||
<|> ConstList <$> brackets (some constValue)
|
||||
<|> ConstObject <$> braces (some $ objectField constValue)
|
||||
constValue :: Parser Full.ConstValue
|
||||
constValue = Full.ConstFloat <$> try float
|
||||
<|> Full.ConstInt <$> integer
|
||||
<|> Full.ConstBoolean <$> booleanValue
|
||||
<|> Full.ConstNull <$ nullValue
|
||||
<|> Full.ConstString <$> stringValue
|
||||
<|> Full.ConstEnum <$> try enumValue
|
||||
<|> Full.ConstList <$> brackets (some constValue)
|
||||
<|> Full.ConstObject <$> braces (some $ objectField $ valueNode constValue)
|
||||
<?> "Value"
|
||||
|
||||
booleanValue :: Parser Bool
|
||||
|
@ -459,7 +480,7 @@ booleanValue = True <$ symbol "true"
|
|||
<|> False <$ symbol "false"
|
||||
<?> "BooleanValue"
|
||||
|
||||
enumValue :: Parser Name
|
||||
enumValue :: Parser Full.Name
|
||||
enumValue = but (symbol "true")
|
||||
*> but (symbol "false")
|
||||
*> but (symbol "null")
|
||||
|
@ -472,51 +493,54 @@ stringValue = blockString <|> string <?> "StringValue"
|
|||
nullValue :: Parser Text
|
||||
nullValue = symbol "null" <?> "NullValue"
|
||||
|
||||
objectField :: Parser a -> Parser (ObjectField a)
|
||||
objectField valueParser = ObjectField
|
||||
<$> name
|
||||
<* colon
|
||||
<*> valueParser
|
||||
<?> "ObjectField"
|
||||
objectField :: forall a. Parser (Full.Node a) -> Parser (Full.ObjectField a)
|
||||
objectField valueParser = label "ObjectField" $ do
|
||||
location <- getLocation
|
||||
fieldName <- name
|
||||
colon
|
||||
fieldValue <- valueParser
|
||||
pure $ Full.ObjectField fieldName fieldValue location
|
||||
|
||||
variableDefinitions :: Parser [VariableDefinition]
|
||||
variableDefinitions :: Parser [Full.VariableDefinition]
|
||||
variableDefinitions = listOptIn parens variableDefinition
|
||||
<?> "VariableDefinitions"
|
||||
|
||||
variableDefinition :: Parser VariableDefinition
|
||||
variableDefinition = VariableDefinition
|
||||
<$> variable
|
||||
<* colon
|
||||
<*> type'
|
||||
<*> defaultValue
|
||||
<?> "VariableDefinition"
|
||||
variableDefinition :: Parser Full.VariableDefinition
|
||||
variableDefinition = label "VariableDefinition" $ do
|
||||
location <- getLocation
|
||||
variableName <- variable
|
||||
colon
|
||||
variableType <- type'
|
||||
variableValue <- defaultValue
|
||||
pure $ Full.VariableDefinition variableName variableType variableValue location
|
||||
|
||||
variable :: Parser Name
|
||||
variable :: Parser Full.Name
|
||||
variable = dollar *> name <?> "Variable"
|
||||
|
||||
defaultValue :: Parser (Maybe ConstValue)
|
||||
defaultValue = optional (equals *> constValue) <?> "DefaultValue"
|
||||
defaultValue :: Parser (Maybe (Full.Node Full.ConstValue))
|
||||
defaultValue = optional (equals *> valueNode constValue) <?> "DefaultValue"
|
||||
|
||||
type' :: Parser Type
|
||||
type' = try (TypeNonNull <$> nonNullType)
|
||||
<|> TypeList <$> brackets type'
|
||||
<|> TypeNamed <$> name
|
||||
type' :: Parser Full.Type
|
||||
type' = try (Full.TypeNonNull <$> nonNullType)
|
||||
<|> Full.TypeList <$> brackets type'
|
||||
<|> Full.TypeNamed <$> name
|
||||
<?> "Type"
|
||||
|
||||
nonNullType :: Parser NonNullType
|
||||
nonNullType = NonNullTypeNamed <$> name <* bang
|
||||
<|> NonNullTypeList <$> brackets type' <* bang
|
||||
nonNullType :: Parser Full.NonNullType
|
||||
nonNullType = Full.NonNullTypeNamed <$> name <* bang
|
||||
<|> Full.NonNullTypeList <$> brackets type' <* bang
|
||||
<?> "NonNullType"
|
||||
|
||||
directives :: Parser [Directive]
|
||||
directives :: Parser [Full.Directive]
|
||||
directives = many directive <?> "Directives"
|
||||
|
||||
directive :: Parser Directive
|
||||
directive = Directive
|
||||
<$ at
|
||||
<*> name
|
||||
<*> arguments
|
||||
<?> "Directive"
|
||||
directive :: Parser Full.Directive
|
||||
directive = label "Directive" $ do
|
||||
location <- getLocation
|
||||
at
|
||||
directiveName <- name
|
||||
directiveArguments <- arguments
|
||||
pure $ Full.Directive directiveName directiveArguments location
|
||||
|
||||
listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
|
||||
listOptIn surround = option [] . surround . some
|
||||
|
|
|
@ -5,15 +5,16 @@
|
|||
|
||||
-- | Error handling.
|
||||
module Language.GraphQL.Error
|
||||
( parseError
|
||||
, CollectErrsT
|
||||
( CollectErrsT
|
||||
, Error(..)
|
||||
, Path(..)
|
||||
, Resolution(..)
|
||||
, ResolverException(..)
|
||||
, Response(..)
|
||||
, ResponseEventStream
|
||||
, addErr
|
||||
, addErrMsg
|
||||
, parseError
|
||||
, runCollectErrs
|
||||
, singleError
|
||||
) where
|
||||
|
@ -28,7 +29,7 @@ import Data.Text (Text)
|
|||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Location(..), Name)
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Type.Schema
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import Prelude hiding (null)
|
||||
import Text.Megaparsec
|
||||
( ParseErrorBundle(..)
|
||||
|
@ -43,7 +44,7 @@ import Text.Megaparsec
|
|||
-- | Executor context.
|
||||
data Resolution m = Resolution
|
||||
{ errors :: Seq Error
|
||||
, types :: HashMap Name (Type m)
|
||||
, types :: HashMap Name (Schema.Type m)
|
||||
}
|
||||
|
||||
-- | Wraps a parse error into a list of errors.
|
||||
|
@ -57,6 +58,7 @@ parseError ParseErrorBundle{..} =
|
|||
errorObject s SourcePos{..} = Error
|
||||
{ message = Text.pack $ init $ parseErrorTextPretty s
|
||||
, locations = [Location (unPos' sourceLine) (unPos' sourceColumn)]
|
||||
, path = []
|
||||
}
|
||||
unPos' = fromIntegral . unPos
|
||||
go (result, state) x =
|
||||
|
@ -75,7 +77,7 @@ addErr v = modify appender
|
|||
appender resolution@Resolution{..} = resolution{ errors = errors |> v }
|
||||
|
||||
makeErrorMessage :: Text -> Error
|
||||
makeErrorMessage s = Error s []
|
||||
makeErrorMessage s = Error s [] []
|
||||
|
||||
-- | Constructs a response object containing only the error with the given
|
||||
-- message.
|
||||
|
@ -86,10 +88,20 @@ singleError message = Response null $ Seq.singleton $ makeErrorMessage message
|
|||
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
|
||||
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.
|
||||
data Error = Error
|
||||
{ message :: Text
|
||||
, locations :: [Location]
|
||||
, path :: [Path]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | 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
|
||||
-- list, which is then sent back with the data.
|
||||
runCollectErrs :: (Monad m, Serialize a)
|
||||
=> HashMap Name (Type m)
|
||||
=> HashMap Name (Schema.Type m)
|
||||
-> CollectErrsT m a
|
||||
-> m (Response a)
|
||||
runCollectErrs types' res = do
|
||||
|
|
|
@ -32,8 +32,8 @@ execute :: (MonadCatch m, VariableValue a, Serialize b)
|
|||
-> HashMap Name a -- ^ Variable substitution function.
|
||||
-> Document -- @GraphQL@ document.
|
||||
-> m (Either (ResponseEventStream m b) (Response b))
|
||||
execute schema operationName subs document =
|
||||
case Transform.document schema operationName subs document of
|
||||
execute schema' operationName subs document =
|
||||
case Transform.document schema' operationName subs document of
|
||||
Left queryError -> pure
|
||||
$ Right
|
||||
$ 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.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Internal
|
||||
import Language.GraphQL.Type.Schema
|
||||
import qualified Language.GraphQL.Type.Internal as Internal
|
||||
import Prelude hiding (null)
|
||||
|
||||
resolveFieldValue :: MonadCatch m
|
||||
|
@ -43,7 +42,7 @@ resolveFieldValue result args resolver =
|
|||
=> ResolverException
|
||||
-> CollectErrsT m Type.Value
|
||||
handleFieldError e =
|
||||
addErr (Error (Text.pack $ displayException e) []) >> pure Type.Null
|
||||
addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null
|
||||
context = Type.Context
|
||||
{ Type.arguments = Type.Arguments args
|
||||
, Type.values = result
|
||||
|
@ -60,7 +59,7 @@ collectFields objectType = foldl forEach Map.empty
|
|||
in Map.insertWith (<>) responseKey (field :| []) groupedFields
|
||||
forEach groupedFields (Transform.SelectionFragment selectionFragment)
|
||||
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
|
||||
, doesFragmentTypeApply fragmentType objectType =
|
||||
, Internal.doesFragmentTypeApply fragmentType objectType =
|
||||
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
|
||||
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
|
||||
| otherwise = groupedFields
|
||||
|
@ -69,15 +68,15 @@ aliasOrName :: forall m. Transform.Field m -> Name
|
|||
aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
|
||||
|
||||
resolveAbstractType :: Monad m
|
||||
=> AbstractType m
|
||||
=> Internal.AbstractType m
|
||||
-> Type.Subs
|
||||
-> CollectErrsT m (Maybe (Out.ObjectType m))
|
||||
resolveAbstractType abstractType values'
|
||||
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
|
||||
types' <- gets types
|
||||
case HashMap.lookup typeName types' of
|
||||
Just (ObjectType objectType) ->
|
||||
if instanceOf objectType abstractType
|
||||
Just (Internal.ObjectType objectType) ->
|
||||
if Internal.instanceOf objectType abstractType
|
||||
then pure $ Just objectType
|
||||
else pure Nothing
|
||||
_ -> pure Nothing
|
||||
|
@ -124,25 +123,25 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
|
|||
let Type.EnumType _ _ enumMembers = enumType
|
||||
in if HashMap.member enum enumMembers
|
||||
then coerceResult outputType $ Enum enum
|
||||
else addErrMsg "Value completion failed."
|
||||
else addErrMsg "Enum value completion failed."
|
||||
completeValue (Out.ObjectBaseType objectType) fields result =
|
||||
executeSelectionSet result objectType $ mergeSelectionSets fields
|
||||
completeValue (Out.InterfaceBaseType interfaceType) fields result
|
||||
| Type.Object objectMap <- result = do
|
||||
let abstractType = AbstractInterfaceType interfaceType
|
||||
let abstractType = Internal.AbstractInterfaceType interfaceType
|
||||
concreteType <- resolveAbstractType abstractType objectMap
|
||||
case concreteType of
|
||||
Just objectType -> executeSelectionSet result objectType
|
||||
$ mergeSelectionSets fields
|
||||
Nothing -> addErrMsg "Value completion failed."
|
||||
Nothing -> addErrMsg "Interface value completion failed."
|
||||
completeValue (Out.UnionBaseType unionType) fields result
|
||||
| Type.Object objectMap <- result = do
|
||||
let abstractType = AbstractUnionType unionType
|
||||
let abstractType = Internal.AbstractUnionType unionType
|
||||
concreteType <- resolveAbstractType abstractType objectMap
|
||||
case concreteType of
|
||||
Just objectType -> executeSelectionSet result objectType
|
||||
$ mergeSelectionSets fields
|
||||
Nothing -> addErrMsg "Value completion failed."
|
||||
Nothing -> addErrMsg "Union value completion failed."
|
||||
completeValue _ _ _ = addErrMsg "Value completion failed."
|
||||
|
||||
mergeSelectionSets :: MonadCatch m
|
||||
|
|
|
@ -47,24 +47,23 @@ import Language.GraphQL.AST (Name)
|
|||
import qualified Language.GraphQL.Execute.Coerce as Coerce
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import Language.GraphQL.Type.Internal
|
||||
import qualified Language.GraphQL.Type.Internal as Type
|
||||
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.
|
||||
data Replacement m = Replacement
|
||||
{ fragments :: HashMap Full.Name (Fragment m)
|
||||
, fragmentDefinitions :: FragmentDefinitions
|
||||
, variableValues :: Type.Subs
|
||||
, types :: HashMap Full.Name (Type m)
|
||||
, types :: HashMap Full.Name (Schema.Type m)
|
||||
}
|
||||
|
||||
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
|
||||
|
||||
-- | Represents fragments and inline fragments.
|
||||
data Fragment m
|
||||
= Fragment (CompositeType m) (Seq (Selection m))
|
||||
= Fragment (Type.CompositeType m) (Seq (Selection m))
|
||||
|
||||
-- | Single selection element.
|
||||
data Selection m
|
||||
|
@ -85,7 +84,7 @@ data Field m = Field
|
|||
|
||||
-- | Contains the operation to be executed along with its root type.
|
||||
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
|
||||
Full.OperationType
|
||||
|
@ -139,38 +138,9 @@ getOperation (Just operationName) operations
|
|||
matchingName (OperationDefinition _ name _ _ _) =
|
||||
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
|
||||
=> forall m
|
||||
. HashMap Full.Name (Type m)
|
||||
. HashMap Full.Name (Schema.Type m)
|
||||
-> OperationDefinition
|
||||
-> HashMap.HashMap Full.Name a
|
||||
-> Either QueryError Type.Subs
|
||||
|
@ -180,10 +150,10 @@ coerceVariableValues types operationDefinition variableValues =
|
|||
$ foldr forEach (Just HashMap.empty) variableDefinitions
|
||||
where
|
||||
forEach variableDefinition coercedValues = do
|
||||
let Full.VariableDefinition variableName variableTypeName defaultValue =
|
||||
let Full.VariableDefinition variableName variableTypeName defaultValue _ =
|
||||
variableDefinition
|
||||
let defaultValue' = constValue <$> defaultValue
|
||||
variableType <- lookupInputType variableTypeName types
|
||||
let defaultValue' = constValue . Full.node <$> defaultValue
|
||||
variableType <- Type.lookupInputType variableTypeName types
|
||||
|
||||
Coerce.matchFieldValues
|
||||
coerceVariableValue'
|
||||
|
@ -207,19 +177,20 @@ constValue (Full.ConstList l) = Type.List $ constValue <$> l
|
|||
constValue (Full.ConstObject o) =
|
||||
Type.Object $ HashMap.fromList $ constObjectField <$> o
|
||||
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
|
||||
-- for query execution.
|
||||
document :: Coerce.VariableValue a
|
||||
=> forall m
|
||||
. Schema m
|
||||
. Type.Schema m
|
||||
-> Maybe Full.Name
|
||||
-> HashMap Full.Name a
|
||||
-> Full.Document
|
||||
-> Either QueryError (Document m)
|
||||
document schema operationName subs ast = do
|
||||
let referencedTypes = collectReferencedTypes schema
|
||||
let referencedTypes = Schema.types schema
|
||||
|
||||
(operations, fragmentTable) <- defragment ast
|
||||
chosenOperation <- getOperation operationName operations
|
||||
|
@ -233,14 +204,14 @@ document schema operationName subs ast = do
|
|||
}
|
||||
case chosenOperation of
|
||||
OperationDefinition Full.Query _ _ _ _ ->
|
||||
pure $ Document referencedTypes (query schema)
|
||||
pure $ Document referencedTypes (Schema.query schema)
|
||||
$ operation chosenOperation replacement
|
||||
OperationDefinition Full.Mutation _ _ _ _
|
||||
| Just mutationType <- mutation schema ->
|
||||
| Just mutationType <- Schema.mutation schema ->
|
||||
pure $ Document referencedTypes mutationType
|
||||
$ operation chosenOperation replacement
|
||||
OperationDefinition Full.Subscription _ _ _ _
|
||||
| Just subscriptionType <- subscription schema ->
|
||||
| Just subscriptionType <- Schema.subscription schema ->
|
||||
pure $ Document referencedTypes subscriptionType
|
||||
$ operation chosenOperation replacement
|
||||
_ -> Left UnsupportedRootOperation
|
||||
|
@ -288,33 +259,47 @@ operation operationDefinition replacement
|
|||
selection
|
||||
:: Full.Selection
|
||||
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
||||
selection (Full.Field alias name arguments' directives' selections) =
|
||||
maybe (Left mempty) (Right . SelectionField) <$> 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
|
||||
selection (Full.FieldSelection fieldSelection) =
|
||||
maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection
|
||||
selection (Full.FragmentSpreadSelection fragmentSelection)
|
||||
= maybe (Left mempty) (Right . SelectionFragment)
|
||||
<$> fragmentSpread fragmentSelection
|
||||
selection (Full.InlineFragmentSelection fragmentSelection) =
|
||||
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
|
||||
go arguments (Full.Argument name' value') =
|
||||
go arguments (Full.Argument name' (Full.Node value' _) _) =
|
||||
inputField arguments name' value'
|
||||
|
||||
selection (Full.FragmentSpread name directives') =
|
||||
maybe (Left mempty) (Right . SelectionFragment) <$> do
|
||||
spreadDirectives <- Definition.selection <$> directives directives'
|
||||
fragments' <- gets fragments
|
||||
fragmentSpread
|
||||
:: Full.FragmentSpread
|
||||
-> State (Replacement m) (Maybe (Fragment m))
|
||||
fragmentSpread (Full.FragmentSpread name directives' _) = do
|
||||
spreadDirectives <- Definition.selection <$> directives directives'
|
||||
fragments' <- gets fragments
|
||||
|
||||
fragmentDefinitions' <- gets fragmentDefinitions
|
||||
case HashMap.lookup name fragments' of
|
||||
Just definition -> lift $ pure $ definition <$ spreadDirectives
|
||||
Nothing
|
||||
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
|
||||
fragDef <- fragmentDefinition definition
|
||||
case fragDef of
|
||||
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
|
||||
_ -> lift $ pure Nothing
|
||||
| otherwise -> lift $ pure Nothing
|
||||
selection (Full.InlineFragment type' directives' selections) = do
|
||||
fragmentDefinitions' <- gets fragmentDefinitions
|
||||
case HashMap.lookup name fragments' of
|
||||
Just definition -> lift $ pure $ definition <$ spreadDirectives
|
||||
Nothing
|
||||
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
|
||||
fragDef <- fragmentDefinition definition
|
||||
case fragDef of
|
||||
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
|
||||
_ -> lift $ pure Nothing
|
||||
| otherwise -> lift $ pure Nothing
|
||||
|
||||
inlineFragment
|
||||
:: Full.InlineFragment
|
||||
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
||||
inlineFragment (Full.InlineFragment type' directives' selections _) = do
|
||||
fragmentDirectives <- Definition.selection <$> directives directives'
|
||||
case fragmentDirectives of
|
||||
Nothing -> pure $ Left mempty
|
||||
|
@ -325,7 +310,7 @@ selection (Full.InlineFragment type' directives' selections) = do
|
|||
Nothing -> pure $ Left fragmentSelectionSet
|
||||
Just typeName -> do
|
||||
types' <- gets types
|
||||
case lookupTypeCondition typeName types' of
|
||||
case Type.lookupTypeCondition typeName types' of
|
||||
Just typeCondition -> pure $
|
||||
selectionFragment typeCondition fragmentSelectionSet
|
||||
Nothing -> pure $ Left mempty
|
||||
|
@ -346,10 +331,10 @@ appendSelection = foldM go mempty
|
|||
directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
|
||||
directives = traverse directive
|
||||
where
|
||||
directive (Full.Directive directiveName directiveArguments)
|
||||
directive (Full.Directive directiveName directiveArguments _)
|
||||
= Definition.Directive directiveName . Type.Arguments
|
||||
<$> foldM go HashMap.empty directiveArguments
|
||||
go arguments (Full.Argument name value') = do
|
||||
go arguments (Full.Argument name (Full.Node value' _) _) = do
|
||||
substitutedValue <- value value'
|
||||
return $ HashMap.insert name substitutedValue arguments
|
||||
|
||||
|
@ -372,7 +357,7 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do
|
|||
fragmentSelection <- appendSelection selections
|
||||
types' <- gets types
|
||||
|
||||
case lookupTypeCondition type' types' of
|
||||
case Type.lookupTypeCondition type' types' of
|
||||
Just compositeType -> do
|
||||
let newValue = Fragment compositeType fragmentSelection
|
||||
modify $ insertFragment newValue
|
||||
|
@ -399,7 +384,8 @@ value (Full.List list) = Type.List <$> traverse value list
|
|||
value (Full.Object object) =
|
||||
Type.Object . HashMap.fromList <$> traverse objectField object
|
||||
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 (Full.Variable name) =
|
||||
|
@ -415,8 +401,8 @@ input (Full.Object object) = do
|
|||
objectFields <- foldM objectField HashMap.empty object
|
||||
pure $ pure $ Object objectFields
|
||||
where
|
||||
objectField resultMap (Full.ObjectField name value') =
|
||||
inputField resultMap name value'
|
||||
objectField resultMap Full.ObjectField{value = value', ..} =
|
||||
inputField resultMap name $ Full.node value'
|
||||
|
||||
inputField :: forall m
|
||||
. HashMap Full.Name Input
|
||||
|
|
|
@ -21,6 +21,6 @@ module Language.GraphQL.Type
|
|||
) where
|
||||
|
||||
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.Out as Out
|
||||
|
|
|
@ -11,6 +11,7 @@
|
|||
-- with 'Language.GraphQL.Type.Out'.
|
||||
module Language.GraphQL.Type.In
|
||||
( Argument(..)
|
||||
, Arguments
|
||||
, InputField(..)
|
||||
, InputObjectType(..)
|
||||
, Type(..)
|
||||
|
@ -24,10 +25,10 @@ module Language.GraphQL.Type.In
|
|||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.Document (Name)
|
||||
import Language.GraphQL.Type.Definition
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
|
||||
-- | 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.
|
||||
--
|
||||
|
@ -45,25 +46,28 @@ instance Eq InputObjectType where
|
|||
-- type can wrap other wrapping or named types. Wrapping types are lists and
|
||||
-- Non-Null types (named types are nullable by default).
|
||||
data Type
|
||||
= NamedScalarType ScalarType
|
||||
| NamedEnumType EnumType
|
||||
= NamedScalarType Definition.ScalarType
|
||||
| NamedEnumType Definition.EnumType
|
||||
| NamedInputObjectType InputObjectType
|
||||
| ListType Type
|
||||
| NonNullScalarType ScalarType
|
||||
| NonNullEnumType EnumType
|
||||
| NonNullScalarType Definition.ScalarType
|
||||
| NonNullEnumType Definition.EnumType
|
||||
| NonNullInputObjectType InputObjectType
|
||||
| NonNullListType Type
|
||||
deriving Eq
|
||||
|
||||
-- | 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'.
|
||||
pattern ScalarBaseType :: ScalarType -> Type
|
||||
pattern ScalarBaseType :: Definition.ScalarType -> Type
|
||||
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
|
||||
|
||||
-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
|
||||
pattern EnumBaseType :: EnumType -> Type
|
||||
pattern EnumBaseType :: Definition.EnumType -> Type
|
||||
pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
|
||||
|
||||
-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.
|
||||
|
@ -76,7 +80,7 @@ pattern ListBaseType listType <- (isListType -> Just listType)
|
|||
|
||||
{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}
|
||||
|
||||
isScalarType :: Type -> Maybe ScalarType
|
||||
isScalarType :: Type -> Maybe Definition.ScalarType
|
||||
isScalarType (NamedScalarType inputType) = Just inputType
|
||||
isScalarType (NonNullScalarType inputType) = Just inputType
|
||||
isScalarType _ = Nothing
|
||||
|
@ -86,7 +90,7 @@ isInputObjectType (NamedInputObjectType inputType) = Just inputType
|
|||
isInputObjectType (NonNullInputObjectType inputType) = Just inputType
|
||||
isInputObjectType _ = Nothing
|
||||
|
||||
isEnumType :: Type -> Maybe EnumType
|
||||
isEnumType :: Type -> Maybe Definition.EnumType
|
||||
isEnumType (NamedEnumType inputType) = Just inputType
|
||||
isEnumType (NonNullEnumType inputType) = Just inputType
|
||||
isEnumType _ = Nothing
|
||||
|
|
|
@ -3,23 +3,85 @@
|
|||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Language.GraphQL.Type.Internal
|
||||
( AbstractType(..)
|
||||
, CompositeType(..)
|
||||
, collectReferencedTypes
|
||||
, Directive(..)
|
||||
, Directives
|
||||
, Schema(..)
|
||||
, Type(..)
|
||||
, directives
|
||||
, doesFragmentTypeApply
|
||||
, instanceOf
|
||||
, lookupInputType
|
||||
, lookupTypeCondition
|
||||
, lookupTypeField
|
||||
, mutation
|
||||
, subscription
|
||||
, query
|
||||
, types
|
||||
) where
|
||||
|
||||
import Data.HashMap.Strict (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.In as In
|
||||
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.
|
||||
data CompositeType m
|
||||
|
@ -34,65 +96,6 @@ data AbstractType m
|
|||
| AbstractInterfaceType (Out.InterfaceType m)
|
||||
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
|
||||
. CompositeType m
|
||||
-> Out.ObjectType m
|
||||
|
@ -118,13 +121,56 @@ instanceOf objectType (AbstractUnionType unionType) =
|
|||
go unionMemberType acc = acc || objectType == unionMemberType
|
||||
|
||||
lookupTypeCondition :: forall m
|
||||
. Name
|
||||
-> HashMap Name (Type m)
|
||||
. Full.Name
|
||||
-> HashMap Full.Name (Type m)
|
||||
-> Maybe (CompositeType m)
|
||||
lookupTypeCondition type' types' =
|
||||
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 (InterfaceType interfaceType) ->
|
||||
Just $ CompositeInterfaceType interfaceType
|
||||
_ -> 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
|
||||
(Maybe Text) -- ^ Description.
|
||||
(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.
|
||||
--
|
||||
|
|
|
@ -2,36 +2,154 @@
|
|||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
||||
-- functions for defining and manipulating schemas.
|
||||
module Language.GraphQL.Type.Schema
|
||||
( Schema(..)
|
||||
, Type(..)
|
||||
( schema
|
||||
, module Language.GraphQL.Type.Internal
|
||||
) 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.Internal as Internal
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
||||
-- | 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
|
||||
-- | Schema constructor.
|
||||
schema :: forall m
|
||||
. Out.ObjectType m -- ^ Query type.
|
||||
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
|
||||
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
|
||||
-> Directives -- ^ Directive definitions.
|
||||
-> Schema m -- ^ Schema.
|
||||
schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
|
||||
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,
|
||||
-- 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
|
||||
{ query :: Out.ObjectType m
|
||||
, mutation :: Maybe (Out.ObjectType m)
|
||||
, subscription :: Maybe (Out.ObjectType m)
|
||||
}
|
||||
-- | Traverses the schema and finds all referenced types.
|
||||
collectReferencedTypes :: forall m
|
||||
. Out.ObjectType m
|
||||
-> Maybe (Out.ObjectType m)
|
||||
-> Maybe (Out.ObjectType m)
|
||||
-> HashMap Full.Name (Type m)
|
||||
collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
|
||||
let queryTypes = traverseObjectType queryRoot HashMap.empty
|
||||
mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
|
||||
mutationRoot
|
||||
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
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-- | GraphQL validator.
|
||||
module Language.GraphQL.Validate
|
||||
( Error(..)
|
||||
, Path(..)
|
||||
( Validation.Error(..)
|
||||
, document
|
||||
, module Language.GraphQL.Validate.Rules
|
||||
) where
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
|
||||
import Data.Foldable (foldrM)
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
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 qualified Data.Sequence as Seq
|
||||
import Language.GraphQL.AST.Document
|
||||
import Language.GraphQL.Type.Internal
|
||||
import Language.GraphQL.Type.Schema (Schema(..))
|
||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||
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.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
|
||||
-- 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' =
|
||||
runReader (foldrM go Seq.empty document') context
|
||||
runReaderT reader context
|
||||
where
|
||||
context = Validation
|
||||
{ ast = document'
|
||||
, schema = schema'
|
||||
, types = collectReferencedTypes schema'
|
||||
, rules = rules'
|
||||
{ Validation.ast = document'
|
||||
, Validation.schema = schema'
|
||||
}
|
||||
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 = \case
|
||||
definition'@(ExecutableDefinition executableDefinition') -> do
|
||||
applied <- applyRules definition'
|
||||
children <- executableDefinition executableDefinition'
|
||||
pure $ children >< applied
|
||||
definition' -> applyRules definition'
|
||||
definition :: Validation.Rule m
|
||||
-> Validation m
|
||||
-> Full.Definition
|
||||
-> Seq (Validation.RuleT m)
|
||||
-> Seq (Validation.RuleT m)
|
||||
definition (Validation.DefinitionRule rule) _ definition' accumulator =
|
||||
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
|
||||
applyRules definition' =
|
||||
asks rules >>= foldM (ruleFilter definition') Seq.empty
|
||||
ruleFilter definition' accumulator (DefinitionRule rule) =
|
||||
mapReaderT (runRule accumulator) $ rule definition'
|
||||
ruleFilter _ accumulator _ = pure accumulator
|
||||
forEachInputFieldDefinition =
|
||||
inputValueDefinition context rule inputFieldDefinitionLocation
|
||||
|
||||
runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
|
||||
runRule accumulator (Just error') = pure $ accumulator |> error'
|
||||
runRule accumulator Nothing = pure accumulator
|
||||
schemaExtension :: forall m. Validation m -> ApplyRule m Full.SchemaExtension
|
||||
schemaExtension context rule = \case
|
||||
Full.SchemaOperationExtension directives' _ ->
|
||||
directives context rule schemaLocation directives'
|
||||
Full.SchemaDirectivesExtension directives' ->
|
||||
directives context rule schemaLocation directives'
|
||||
|
||||
executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
|
||||
executableDefinition (DefinitionOperation definition') =
|
||||
operationDefinition definition'
|
||||
executableDefinition (DefinitionFragment definition') =
|
||||
fragmentDefinition definition'
|
||||
schemaLocation :: DirectiveLocation
|
||||
schemaLocation = TypeSystemDirectiveLocation DirectiveLocation.Schema
|
||||
|
||||
operationDefinition :: forall m. OperationDefinition -> ValidateT m
|
||||
operationDefinition operation =
|
||||
asks rules >>= foldM ruleFilter Seq.empty
|
||||
interfaceLocation :: DirectiveLocation
|
||||
interfaceLocation = TypeSystemDirectiveLocation DirectiveLocation.Interface
|
||||
|
||||
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
|
||||
ruleFilter accumulator (OperationDefinitionRule rule) =
|
||||
mapReaderT (runRule accumulator) $ rule operation
|
||||
ruleFilter accumulator _ = pure accumulator
|
||||
forEachInputFieldDefinition =
|
||||
inputValueDefinition context rule inputFieldDefinitionLocation
|
||||
|
||||
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
|
||||
fragmentDefinition fragment =
|
||||
asks rules >>= foldM ruleFilter Seq.empty
|
||||
enumValueDefinition :: forall m
|
||||
. Validation m
|
||||
-> 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
|
||||
ruleFilter accumulator (FragmentDefinitionRule rule) =
|
||||
mapReaderT (runRule accumulator) $ rule fragment
|
||||
ruleFilter accumulator _ = pure accumulator
|
||||
forEachArgument =
|
||||
inputValueDefinition context rule argumentDefinitionLocation
|
||||
|
||||
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.
|
||||
module Language.GraphQL.Validate.Validation
|
||||
( Error(..)
|
||||
, Path(..)
|
||||
, Rule(..)
|
||||
, RuleT
|
||||
, Validation(..)
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Reader (ReaderT(..))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Text (Text)
|
||||
import Control.Monad.Trans.Reader (ReaderT)
|
||||
import Data.Sequence (Seq)
|
||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
|
||||
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 qualified Language.GraphQL.Type.Schema as Schema
|
||||
|
||||
-- | If an error can be associated to a particular field in the GraphQL result,
|
||||
-- it must contain an entry with the key path that details the path of the
|
||||
-- response field which experienced the error. This allows clients to identify
|
||||
-- whether a null result is intentional or caused by a runtime error.
|
||||
data Path
|
||||
= Segment Text -- ^ Field name.
|
||||
| Index Int -- ^ List index if a field returned a list.
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Validation error.
|
||||
data Error = Error
|
||||
{ message :: String
|
||||
, locations :: [Location]
|
||||
, path :: [Path]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | Validation rule context.
|
||||
data Validation m = Validation
|
||||
{ ast :: Document
|
||||
, schema :: Schema m
|
||||
, types :: HashMap Name (Schema.Type m)
|
||||
, rules :: [Rule m]
|
||||
}
|
||||
|
||||
-- | 'Rule' assigns a function to each AST node that can be validated. If the
|
||||
|
@ -49,6 +37,14 @@ data Rule m
|
|||
= DefinitionRule (Definition -> RuleT m)
|
||||
| OperationDefinitionRule (OperationDefinition -> 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.
|
||||
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:
|
||||
- .
|
||||
|
@ -6,4 +6,4 @@ packages:
|
|||
extra-deps: []
|
||||
flags: {}
|
||||
|
||||
pvp-bounds: both
|
||||
pvp-bounds: lower
|
||||
|
|
|
@ -4,7 +4,7 @@ module Language.GraphQL.AST.EncoderSpec
|
|||
( spec
|
||||
) where
|
||||
|
||||
import Language.GraphQL.AST
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import Language.GraphQL.AST.Encoder
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
|
||||
import Test.QuickCheck (choose, oneof, forAll)
|
||||
|
@ -15,52 +15,52 @@ spec :: Spec
|
|||
spec = do
|
||||
describe "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 "pretty" $ testNull pretty
|
||||
|
||||
context "minified" $ do
|
||||
it "escapes \\" $
|
||||
value minified (String "\\") `shouldBe` "\"\\\\\""
|
||||
value minified (Full.String "\\") `shouldBe` "\"\\\\\""
|
||||
it "escapes double quotes" $
|
||||
value minified (String "\"") `shouldBe` "\"\\\"\""
|
||||
value minified (Full.String "\"") `shouldBe` "\"\\\"\""
|
||||
it "escapes \\f" $
|
||||
value minified (String "\f") `shouldBe` "\"\\f\""
|
||||
value minified (Full.String "\f") `shouldBe` "\"\\f\""
|
||||
it "escapes \\n" $
|
||||
value minified (String "\n") `shouldBe` "\"\\n\""
|
||||
value minified (Full.String "\n") `shouldBe` "\"\\n\""
|
||||
it "escapes \\r" $
|
||||
value minified (String "\r") `shouldBe` "\"\\r\""
|
||||
value minified (Full.String "\r") `shouldBe` "\"\\r\""
|
||||
it "escapes \\t" $
|
||||
value minified (String "\t") `shouldBe` "\"\\t\""
|
||||
value minified (Full.String "\t") `shouldBe` "\"\\t\""
|
||||
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
|
||||
it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\""
|
||||
it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\""
|
||||
it "Null" $ value minified (Full.String "\x0000") `shouldBe` "\"\\u0000\""
|
||||
it "bell" $ value minified (Full.String "\x0007") `shouldBe` "\"\\u0007\""
|
||||
context "escapes Unicode for char less than 0020" $ do
|
||||
it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\""
|
||||
it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\""
|
||||
it "DLE" $ value minified (Full.String "\x0010") `shouldBe` "\"\\u0010\""
|
||||
it "EM" $ value minified (Full.String "\x0019") `shouldBe` "\"\\u0019\""
|
||||
context "encodes without escape" $ do
|
||||
it "space" $ value minified (String "\x0020") `shouldBe` "\" \""
|
||||
it "~" $ value minified (String "\x007E") `shouldBe` "\"~\""
|
||||
it "space" $ value minified (Full.String "\x0020") `shouldBe` "\" \""
|
||||
it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\""
|
||||
|
||||
context "pretty" $ do
|
||||
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" $
|
||||
value pretty (String "Line 1\nLine 2")
|
||||
value pretty (Full.String "Line 1\nLine 2")
|
||||
`shouldBe` [r|"""
|
||||
Line 1
|
||||
Line 2
|
||||
"""|]
|
||||
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|"""
|
||||
Line 1
|
||||
Line 2
|
||||
"""|]
|
||||
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|"""
|
||||
Line 1
|
||||
Line 2
|
||||
|
@ -77,12 +77,12 @@ spec = do
|
|||
forAll genNotAllowedSymbol $ \x -> do
|
||||
let
|
||||
rawValue = "Short \n" <> cons x "text"
|
||||
encoded = value pretty (String $ toStrict rawValue)
|
||||
encoded = value pretty (Full.String $ toStrict rawValue)
|
||||
shouldStartWith (unpack encoded) "\""
|
||||
shouldEndWith (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|"""
|
||||
Hello,
|
||||
World!
|
||||
|
@ -91,29 +91,29 @@ spec = do
|
|||
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" $
|
||||
value pretty (String "a\n\n") `shouldBe` [r|"""
|
||||
value pretty (Full.String "a\n\n") `shouldBe` [r|"""
|
||||
a
|
||||
|
||||
|
||||
"""|]
|
||||
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
|
||||
"""|]
|
||||
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
|
||||
|
||||
"""|]
|
||||
it "skip trailing whitespaces" $ value pretty (String " Short\ntext ")
|
||||
it "skip trailing whitespaces" $ value pretty (Full.String " Short\ntext ")
|
||||
`shouldBe` [r|"""
|
||||
Short
|
||||
text
|
||||
|
@ -121,11 +121,13 @@ spec = do
|
|||
|
||||
describe "definition" $
|
||||
it "indents block strings in arguments" $
|
||||
let arguments = [Argument "message" (String "line1\nline2")]
|
||||
field = Field Nothing "field" arguments [] []
|
||||
operation = DefinitionOperation
|
||||
$ SelectionSet (pure field)
|
||||
$ Location 0 0
|
||||
let location = Full.Location 0 0
|
||||
argumentValue = Full.Node (Full.String "line1\nline2") location
|
||||
arguments = [Full.Argument "message" argumentValue location]
|
||||
field = Full.Field Nothing "field" arguments [] [] location
|
||||
fieldSelection = pure $ Full.FieldSelection field
|
||||
operation = Full.DefinitionOperation
|
||||
$ Full.SelectionSet fieldSelection location
|
||||
in definition pretty operation `shouldBe` [r|{
|
||||
field(message: """
|
||||
line1
|
||||
|
|
|
@ -75,9 +75,9 @@ spec = describe "Lexer" $ do
|
|||
parse dollar "" "$" `shouldParse` "$"
|
||||
runBetween parens `shouldSucceedOn` "()"
|
||||
parse spread "" "..." `shouldParse` "..."
|
||||
parse colon "" ":" `shouldParse` ":"
|
||||
parse colon "" `shouldSucceedOn` ":"
|
||||
parse equals "" "=" `shouldParse` "="
|
||||
parse at "" "@" `shouldParse` "@"
|
||||
parse at "" `shouldSucceedOn` "@"
|
||||
runBetween brackets `shouldSucceedOn` "[]"
|
||||
runBetween braces `shouldSucceedOn` "{}"
|
||||
parse pipe "" "|" `shouldParse` "|"
|
||||
|
|
|
@ -128,7 +128,7 @@ spec = describe "Parser" $ do
|
|||
parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]
|
||||
|
||||
it "parses schema extension with an operation type and directive" $
|
||||
let newDirective = Directive "newDirective" []
|
||||
let newDirective = Directive "newDirective" [] $ Location 1 15
|
||||
schemaExtension = SchemaExtension
|
||||
$ SchemaOperationExtension [newDirective]
|
||||
$ OperationTypeDefinition Query "Query" :| []
|
||||
|
|
|
@ -19,6 +19,6 @@ import Test.Hspec ( Spec
|
|||
spec :: Spec
|
||||
spec = describe "singleError" $
|
||||
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''
|
||||
in singleError "Message." `shouldBe` expected
|
||||
|
|
|
@ -3,6 +3,7 @@
|
|||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Language.GraphQL.ExecuteSpec
|
||||
( spec
|
||||
) where
|
||||
|
@ -10,10 +11,11 @@ module Language.GraphQL.ExecuteSpec
|
|||
import Control.Exception (SomeException)
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson.Types (emptyObject)
|
||||
import Data.Conduit
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.AST (Document, Name)
|
||||
import Language.GraphQL.AST.Parser (document)
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute
|
||||
|
@ -21,13 +23,10 @@ import Language.GraphQL.Type as Type
|
|||
import Language.GraphQL.Type.Out as Out
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
schema :: Schema (Either SomeException)
|
||||
schema = Schema
|
||||
{ query = queryType
|
||||
, mutation = Nothing
|
||||
, subscription = Just subscriptionType
|
||||
}
|
||||
philosopherSchema :: Schema (Either SomeException)
|
||||
philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty
|
||||
|
||||
queryType :: Out.ObjectType (Either SomeException)
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
|
@ -71,9 +70,32 @@ quoteType = Out.ObjectType "Quote" Nothing []
|
|||
quoteField =
|
||||
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 =
|
||||
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
|
||||
it "skips unknown fields" $
|
||||
let data'' = Aeson.object
|
||||
|
@ -82,7 +104,6 @@ spec =
|
|||
]
|
||||
]
|
||||
expected = Response data'' mempty
|
||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName surname } }"
|
||||
in actual `shouldBe` expected
|
||||
|
@ -94,7 +115,6 @@ spec =
|
|||
]
|
||||
]
|
||||
expected = Response data'' mempty
|
||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
|
@ -106,7 +126,6 @@ spec =
|
|||
]
|
||||
]
|
||||
expected = Response data'' mempty
|
||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
Right (Left stream) = either (pure . parseError) execute'
|
||||
$ parse document "" "subscription { newQuote { quote } }"
|
||||
Right (Just actual) = runConduit $ stream .| await
|
||||
|
|
|
@ -9,8 +9,7 @@ module Language.GraphQL.ValidateSpec
|
|||
( spec
|
||||
) where
|
||||
|
||||
import Data.Sequence (Seq(..))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Foldable (toList)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
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.Out as Out
|
||||
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.RawString.QQ (r)
|
||||
|
||||
schema :: Schema IO
|
||||
schema = Schema
|
||||
{ query = queryType
|
||||
, mutation = Nothing
|
||||
, subscription = Nothing
|
||||
}
|
||||
petSchema :: Schema IO
|
||||
petSchema = schema queryType Nothing (Just subscriptionType) mempty
|
||||
|
||||
queryType :: ObjectType IO
|
||||
queryType = ObjectType "Query" Nothing []
|
||||
$ HashMap.singleton "dog" dogResolver
|
||||
queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
[ ("dog", dogResolver)
|
||||
, ("findDog", findDogResolver)
|
||||
]
|
||||
where
|
||||
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
||||
dogResolver = ValueResolver dogField $ pure Null
|
||||
findDogArguments = HashMap.singleton "complex"
|
||||
$ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing
|
||||
findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments
|
||||
findDogResolver = ValueResolver findDogField $ pure Null
|
||||
|
||||
dogCommandType :: EnumType
|
||||
dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
|
||||
|
@ -72,6 +73,12 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
|
|||
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
|
||||
ownerResolver = ValueResolver ownerField $ pure Null
|
||||
|
||||
dogDataType :: InputObjectType
|
||||
dogDataType = InputObjectType "DogData" Nothing
|
||||
$ HashMap.singleton "name" nameInputField
|
||||
where
|
||||
nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing
|
||||
|
||||
sentientType :: InterfaceType IO
|
||||
sentientType = InterfaceType "Sentient" Nothing []
|
||||
$ HashMap.singleton "name"
|
||||
|
@ -81,19 +88,28 @@ petType :: InterfaceType IO
|
|||
petType = InterfaceType "Pet" Nothing []
|
||||
$ HashMap.singleton "name"
|
||||
$ Field Nothing (Out.NonNullScalarType string) mempty
|
||||
{-
|
||||
alienType :: ObjectType IO
|
||||
alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList
|
||||
[ ("name", nameResolver)
|
||||
, ("homePlanet", homePlanetResolver)
|
||||
|
||||
subscriptionType :: ObjectType IO
|
||||
subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList
|
||||
[ ("newMessage", newMessageResolver)
|
||||
, ("disallowedSecondRootField", newMessageResolver)
|
||||
]
|
||||
where
|
||||
nameField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
nameResolver = ValueResolver nameField $ pure "Name"
|
||||
homePlanetField =
|
||||
Field Nothing (Out.NamedScalarType string) mempty
|
||||
homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet"
|
||||
-}
|
||||
newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty
|
||||
newMessageResolver = ValueResolver newMessageField
|
||||
$ pure $ Object HashMap.empty
|
||||
|
||||
messageType :: ObjectType IO
|
||||
messageType = ObjectType "Message" Nothing [] $ HashMap.fromList
|
||||
[ ("sender", senderResolver)
|
||||
, ("body", bodyResolver)
|
||||
]
|
||||
where
|
||||
senderField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
senderResolver = ValueResolver senderField $ pure "Sender"
|
||||
bodyField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
bodyResolver = ValueResolver bodyField $ pure "Message body."
|
||||
|
||||
humanType :: ObjectType IO
|
||||
humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
|
||||
[ ("name", nameResolver)
|
||||
|
@ -106,45 +122,14 @@ humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
|
|||
Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
|
||||
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 "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 =
|
||||
case parse AST.document "" queryString of
|
||||
Left _ -> Seq.empty
|
||||
Right ast -> document schema specifiedRules ast
|
||||
Left _ -> []
|
||||
Right ast -> toList $ document petSchema specifiedRules ast
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
|
@ -166,9 +151,8 @@ spec =
|
|||
{ message =
|
||||
"Definition must be OperationDefinition or FragmentDefinition."
|
||||
, locations = [AST.Location 9 15]
|
||||
, path = []
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects multiple subscription root fields" $
|
||||
let queryString = [r|
|
||||
|
@ -182,11 +166,11 @@ spec =
|
|||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Subscription sub must select only one top level field."
|
||||
"Subscription \"sub\" must select only one top level \
|
||||
\field."
|
||||
, 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" $
|
||||
let queryString = [r|
|
||||
|
@ -204,11 +188,11 @@ spec =
|
|||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Subscription sub must select only one top level field."
|
||||
"Subscription \"sub\" must select only one top level \
|
||||
\field."
|
||||
, locations = [AST.Location 2 15]
|
||||
, path = []
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects multiple anonymous operations" $
|
||||
let queryString = [r|
|
||||
|
@ -230,9 +214,8 @@ spec =
|
|||
{ message =
|
||||
"This anonymous operation must be the only defined operation."
|
||||
, 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" $
|
||||
let queryString = [r|
|
||||
|
@ -252,9 +235,8 @@ spec =
|
|||
{ message =
|
||||
"There can be only one operation named \"dogOperation\"."
|
||||
, locations = [AST.Location 2 15, AST.Location 8 15]
|
||||
, path = []
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects fragments with the same name" $
|
||||
let queryString = [r|
|
||||
|
@ -278,6 +260,406 @@ spec =
|
|||
{ message =
|
||||
"There can be only one fragment named \"fragmentOne\"."
|
||||
, locations = [AST.Location 8 15, AST.Location 12 15]
|
||||
, path = []
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
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)
|
||||
|
||||
experimentalResolver :: Schema IO
|
||||
experimentalResolver = Schema
|
||||
{ query = queryType, mutation = Nothing, subscription = Nothing }
|
||||
experimentalResolver = schema queryType Nothing Nothing mempty
|
||||
where
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.singleton "experimentalField"
|
||||
|
@ -72,7 +71,7 @@ spec =
|
|||
...experimentalFragment @skip(if: true)
|
||||
}
|
||||
|
||||
fragment experimentalFragment on ExperimentalType {
|
||||
fragment experimentalFragment on Query {
|
||||
experimentalField
|
||||
}
|
||||
|]
|
||||
|
@ -83,7 +82,7 @@ spec =
|
|||
it "should be able to @skip an inline fragment" $ do
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
... on ExperimentalType @skip(if: true) {
|
||||
... on Query @skip(if: true) {
|
||||
experimentalField
|
||||
}
|
||||
}
|
||||
|
|
|
@ -46,18 +46,15 @@ inlineQuery = [r|{
|
|||
}|]
|
||||
|
||||
shirtType :: Out.ObjectType IO
|
||||
shirtType = Out.ObjectType "Shirt" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("size", sizeFieldType)
|
||||
, ("circumference", circumferenceFieldType)
|
||||
]
|
||||
shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList
|
||||
[ ("size", sizeFieldType)
|
||||
]
|
||||
|
||||
hatType :: Out.ObjectType IO
|
||||
hatType = Out.ObjectType "Hat" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("size", sizeFieldType)
|
||||
, ("circumference", circumferenceFieldType)
|
||||
]
|
||||
hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList
|
||||
[ ("size", sizeFieldType)
|
||||
, ("circumference", circumferenceFieldType)
|
||||
]
|
||||
|
||||
circumferenceFieldType :: Out.Resolver IO
|
||||
circumferenceFieldType
|
||||
|
@ -70,12 +67,11 @@ sizeFieldType
|
|||
$ pure $ snd size
|
||||
|
||||
toSchema :: Text -> (Text, Value) -> Schema IO
|
||||
toSchema t (_, resolve) = Schema
|
||||
{ query = queryType, mutation = Nothing, subscription = Nothing }
|
||||
toSchema t (_, resolve) = schema queryType Nothing Nothing mempty
|
||||
where
|
||||
unionMember = if t == "Hat" then hatType else shirtType
|
||||
garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
|
||||
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 =
|
||||
case t of
|
||||
"circumference" -> hatType
|
||||
|
@ -111,22 +107,16 @@ spec = do
|
|||
|
||||
it "embeds inline fragments without type" $ do
|
||||
let sourceQuery = [r|{
|
||||
garment {
|
||||
circumference
|
||||
... {
|
||||
size
|
||||
}
|
||||
circumference
|
||||
... {
|
||||
size
|
||||
}
|
||||
}|]
|
||||
resolvers = ("garment", Object $ HashMap.fromList [circumference, size])
|
||||
|
||||
actual <- graphql (toSchema "garment" resolvers) sourceQuery
|
||||
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
||||
let expected = HashMap.singleton "data"
|
||||
$ Aeson.object
|
||||
[ "garment" .= Aeson.object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
, "size" .= ("L" :: Text)
|
||||
]
|
||||
[ "circumference" .= (60 :: Int)
|
||||
, "size" .= ("L" :: Text)
|
||||
]
|
||||
in actual `shouldResolveTo` expected
|
||||
|
||||
|
@ -183,21 +173,6 @@ spec = do
|
|||
]
|
||||
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
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
|
|
|
@ -23,13 +23,11 @@ hatType = Out.ObjectType "Hat" Nothing []
|
|||
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||
$ pure $ Int 60
|
||||
|
||||
schema :: Schema IO
|
||||
schema = Schema
|
||||
{ query = Out.ObjectType "Query" Nothing [] hatFieldResolver
|
||||
, mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
|
||||
, subscription = Nothing
|
||||
}
|
||||
garmentSchema :: Schema IO
|
||||
garmentSchema = schema queryType (Just mutationType) Nothing mempty
|
||||
where
|
||||
queryType = Out.ObjectType "Query" Nothing [] hatFieldResolver
|
||||
mutationType = Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
|
||||
garment = pure $ Object $ HashMap.fromList
|
||||
[ ("circumference", Int 60)
|
||||
]
|
||||
|
@ -57,7 +55,7 @@ spec =
|
|||
[ "circumference" .= (60 :: Int)
|
||||
]
|
||||
]
|
||||
actual <- graphql schema querySource
|
||||
actual <- graphql garmentSchema querySource
|
||||
actual `shouldResolveTo` expected
|
||||
|
||||
it "chooses Mutation" $ do
|
||||
|
@ -70,5 +68,5 @@ spec =
|
|||
$ object
|
||||
[ "incrementCircumference" .= (61 :: Int)
|
||||
]
|
||||
actual <- graphql schema querySource
|
||||
actual <- graphql garmentSchema querySource
|
||||
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