diff options
39 files changed, 3180 insertions, 2006 deletions
diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml deleted file mode 100644 index 665ac93..0000000 --- a/.github/workflows/haskell.yml +++ /dev/null @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md index b9fc93f..6c3cd40 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md deleted file mode 100644 index a1441f5..0000000 --- a/CONTRIBUTING.md +++ /dev/null @@ -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 -``` diff --git a/LICENSE.MPL b/LICENSE.MPL new file mode 100644 index 0000000..a612ad9 --- /dev/null +++ b/LICENSE.MPL @@ -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. @@ -1,9 +1,7 @@ # GraphQL implementation in Haskell -[](https://hackage.haskell.org/package/graphql) -[](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22) -[](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE) [](https://www.simplehaskell.org) +[](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). diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs deleted file mode 100644 index dc44c1e..0000000 --- a/docs/tutorial/tutorial.lhs +++ /dev/null @@ -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 diff --git a/graphql.cabal b/graphql.cabal index 672f9b0..ebc3f4b 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -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 diff --git a/package.yaml b/package.yaml index a55c8a7..15b6ad1 100644 --- a/package.yaml +++ b/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 diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 9fce1d3..03ef54b 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -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) diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs index c38c9ff..511225f 100644 --- a/src/Language/GraphQL/AST/DirectiveLocation.hs +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -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" diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 72d39bb..b30271c 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index ba89d36..9ba51b8 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -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 - --- | 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 + 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 + +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 - -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 +-- | 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 :: 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 diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index 17d3f9c..ecefaf6 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index 7bc51cb..46c8fa3 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -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 - -operationType :: Parser OperationType -operationType = Query <$ symbol "query" - <|> Mutation <$ symbol "mutation" - <|> Subscription <$ symbol "subscription" + pure $ Full.OperationDefinition + operationType' + operationName + variableDefinitions' + directives' + selectionSet' + location + +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 diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 9df69de..b084c78 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -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 diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 2b615f4..283e56c 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 71a2baa..9d588ca 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 9c7ad0a..010899b 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -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 - - 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 +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 + +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 diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index e84fc03..3ed8bb9 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -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 diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs index 8b08041..59a6d59 100644 --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 6f25777..eb8489c 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index 89bbf1d..b0668f5 100644 --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -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. -- diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 581d9b2..099c256 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -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 diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 53dc6f9..277f84d 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -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' - -definition :: forall m. Definition -> ValidateT m -definition = \case - definition'@(ExecutableDefinition executableDefinition') -> do - applied <- applyRules definition' - children <- executableDefinition executableDefinition' - pure $ children >< applied - definition' -> applyRules definition' - where - applyRules definition' = - asks rules >>= foldM (ruleFilter definition') Seq.empty - ruleFilter definition' accumulator (DefinitionRule rule) = - mapReaderT (runRule accumulator) $ rule definition' - ruleFilter _ accumulator _ = pure accumulator - -runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error) -runRule accumulator (Just error') = pure $ accumulator |> error' -runRule accumulator Nothing = pure accumulator - -executableDefinition :: forall m. ExecutableDefinition -> ValidateT m -executableDefinition (DefinitionOperation definition') = - operationDefinition definition' -executableDefinition (DefinitionFragment definition') = - fragmentDefinition definition' - -operationDefinition :: forall m. OperationDefinition -> ValidateT m -operationDefinition operation = - asks rules >>= foldM ruleFilter Seq.empty - where - ruleFilter accumulator (OperationDefinitionRule rule) = - mapReaderT (runRule accumulator) $ rule operation - ruleFilter accumulator _ = pure accumulator - -fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m -fragmentDefinition fragment = - asks rules >>= foldM ruleFilter Seq.empty - where - ruleFilter accumulator (FragmentDefinitionRule rule) = - mapReaderT (runRule accumulator) $ rule fragment - ruleFilter accumulator _ = pure accumulator + reader = do + rule' <- lift $ Seq.fromList rules' + join $ lift $ foldr (definition rule' context) Seq.empty document' + +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 + forEachInputFieldDefinition = + inputValueDefinition context rule inputFieldDefinitionLocation + +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' + +schemaLocation :: DirectiveLocation +schemaLocation = TypeSystemDirectiveLocation DirectiveLocation.Schema + +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 + forEachInputFieldDefinition = + inputValueDefinition context rule inputFieldDefinitionLocation + +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 + 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 diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 690631e..c67df1c 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -2,160 +2,229 @@ 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 OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | This module contains default rules defined in the GraphQL specification. module Language.GraphQL.Validate.Rules - ( executableDefinitionsRule + ( directivesInValidLocationsRule + , executableDefinitionsRule + , fieldsOnCorrectTypeRule + , fragmentsOnCompositeTypesRule + , fragmentSpreadTargetDefinedRule + , fragmentSpreadTypeExistenceRule , loneAnonymousOperationRule + , knownArgumentNamesRule + , knownDirectiveNamesRule + , knownInputFieldNamesRule + , noFragmentCyclesRule + , noUndefinedVariablesRule + , noUnusedFragmentsRule + , noUnusedVariablesRule + , providedRequiredInputFieldsRule + , providedRequiredArgumentsRule + , scalarLeafsRule , singleFieldSubscriptionsRule , specifiedRules + , uniqueArgumentNamesRule + , uniqueDirectiveNamesRule , uniqueFragmentNamesRule + , uniqueInputFieldNamesRule , uniqueOperationNamesRule + , uniqueVariableNamesRule + , variablesAreInputTypesRule ) where -import Control.Monad (foldM) +import Control.Monad ((>=>), foldM) import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Reader (asks) -import Control.Monad.Trans.State (evalStateT, gets, modify) +import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT) +import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) +import Data.Bifunctor (first) +import Data.Foldable (find, toList) +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet +import Data.List (groupBy, sortBy, sortOn) +import Data.Maybe (isNothing, mapMaybe) +import Data.List.NonEmpty (NonEmpty) +import Data.Ord (comparing) +import Data.Sequence (Seq(..), (|>)) +import qualified Data.Sequence as Seq +import Data.Text (Text) import qualified Data.Text as Text -import Language.GraphQL.AST.Document -import Language.GraphQL.Type.Internal +import qualified Language.GraphQL.AST.Document as Full +import qualified Language.GraphQL.Type.Definition as Definition +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 qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Validate.Validation +-- Local help type that contains a hash set to track visited fragments. +type ValidationState m a = + StateT (HashSet Full.Name) (ReaderT (Validation m) Seq) a + -- | Default rules given in the specification. specifiedRules :: forall m. [Rule m] specifiedRules = + -- Documents. [ executableDefinitionsRule + -- Operations. , singleFieldSubscriptionsRule , loneAnonymousOperationRule , uniqueOperationNamesRule + -- Fields + , fieldsOnCorrectTypeRule + , scalarLeafsRule + -- Arguments. + , knownArgumentNamesRule + , uniqueArgumentNamesRule + , providedRequiredArgumentsRule + -- Fragments. , uniqueFragmentNamesRule + , fragmentSpreadTypeExistenceRule + , fragmentsOnCompositeTypesRule + , noUnusedFragmentsRule + , fragmentSpreadTargetDefinedRule + , noFragmentCyclesRule + -- Values + , knownInputFieldNamesRule + , uniqueInputFieldNamesRule + , providedRequiredInputFieldsRule + -- Directives. + , knownDirectiveNamesRule + , directivesInValidLocationsRule + , uniqueDirectiveNamesRule + -- Variables. + , uniqueVariableNamesRule + , variablesAreInputTypesRule + , noUndefinedVariablesRule + , noUnusedVariablesRule ] -- | Definition must be OperationDefinition or FragmentDefinition. executableDefinitionsRule :: forall m. Rule m executableDefinitionsRule = DefinitionRule $ \case - ExecutableDefinition _ -> lift Nothing - TypeSystemDefinition _ location -> pure $ error' location - TypeSystemExtension _ location -> pure $ error' location + Full.ExecutableDefinition _ -> lift mempty + Full.TypeSystemDefinition _ location' -> pure $ error' location' + Full.TypeSystemExtension _ location' -> pure $ error' location' where - error' location = Error + error' location' = Error { message = "Definition must be OperationDefinition or FragmentDefinition." - , locations = [location] - , path = [] + , locations = [location'] } -- | Subscription operations must have exactly one root field. singleFieldSubscriptionsRule :: forall m. Rule m singleFieldSubscriptionsRule = OperationDefinitionRule $ \case - OperationDefinition Subscription name' _ _ rootFields location -> do + Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty case HashSet.size groupedFieldSet of - 1 -> lift Nothing + 1 -> lift mempty _ | Just name <- name' -> pure $ Error - { message = unwords - [ "Subscription" + { message = concat + [ "Subscription \"" , Text.unpack name - , "must select only one top level field." + , "\" must select only one top level field." ] - , locations = [location] - , path = [] + , locations = [location'] } | otherwise -> pure $ Error { message = errorMessage - , locations = [location] - , path = [] + , locations = [location'] } - _ -> lift Nothing + _ -> lift mempty where errorMessage = "Anonymous Subscription must select only one top level field." collectFields selectionSet = foldM forEach HashSet.empty selectionSet - forEach accumulator (Field alias name _ directives _) - | any skip directives = pure accumulator + forEach accumulator = \case + Full.FieldSelection fieldSelection -> forField accumulator fieldSelection + Full.FragmentSpreadSelection fragmentSelection -> + forSpread accumulator fragmentSelection + Full.InlineFragmentSelection fragmentSelection -> + forInline accumulator fragmentSelection + forField accumulator (Full.Field alias name _ directives' _ _) + | any skip directives' = pure accumulator | Just aliasedName <- alias = pure $ HashSet.insert aliasedName accumulator | otherwise = pure $ HashSet.insert name accumulator - forEach accumulator (FragmentSpread fragmentName directives) - | any skip directives = pure accumulator + forSpread accumulator (Full.FragmentSpread fragmentName directives' _) + | any skip directives' = pure accumulator | otherwise = do inVisitetFragments <- gets $ HashSet.member fragmentName if inVisitetFragments then pure accumulator else collectFromSpread fragmentName accumulator - forEach accumulator (InlineFragment typeCondition' directives selectionSet) - | any skip directives = pure accumulator - | Just typeCondition <- typeCondition' = - collectFromFragment typeCondition selectionSet accumulator + forInline accumulator (Full.InlineFragment maybeType directives' selections _) + | any skip directives' = pure accumulator + | Just typeCondition <- maybeType = + collectFromFragment typeCondition selections accumulator | otherwise = HashSet.union accumulator - <$> collectFields selectionSet - skip (Directive "skip" [Argument "if" (Boolean True)]) = True - skip (Directive "include" [Argument "if" (Boolean False)]) = True + <$> collectFields selections + skip (Full.Directive "skip" [Full.Argument "if" (Full.Node argumentValue _) _] _) = + Full.Boolean True == argumentValue + skip (Full.Directive "include" [Full.Argument "if" (Full.Node argumentValue _) _] _) = + Full.Boolean False == argumentValue skip _ = False - findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing - | DefinitionFragment fragmentDefinition <- executableDefinition = - Just fragmentDefinition - findFragmentDefinition _ accumulator = accumulator collectFromFragment typeCondition selectionSet accumulator = do - types' <- lift $ asks types + types' <- lift $ asks $ Schema.types . schema schema' <- lift $ asks schema - case lookupTypeCondition typeCondition types' of + case Type.lookupTypeCondition typeCondition types' of Nothing -> pure accumulator Just compositeType | Just objectType <- Schema.subscription schema' - , True <- doesFragmentTypeApply compositeType objectType -> - HashSet.union accumulator<$> collectFields selectionSet + , True <- Type.doesFragmentTypeApply compositeType objectType -> + HashSet.union accumulator <$> collectFields selectionSet | otherwise -> pure accumulator collectFromSpread fragmentName accumulator = do modify $ HashSet.insert fragmentName ast' <- lift $ asks ast - case foldr findFragmentDefinition Nothing ast' of + case findFragmentDefinition fragmentName ast' of Nothing -> pure accumulator - Just (FragmentDefinition _ typeCondition _ selectionSet _) -> + Just (Full.FragmentDefinition _ typeCondition _ selectionSet _) -> collectFromFragment typeCondition selectionSet accumulator -- | GraphQL allows a short‐hand form for defining query operations when only -- that one operation exists in the document. loneAnonymousOperationRule :: forall m. Rule m loneAnonymousOperationRule = OperationDefinitionRule $ \case - SelectionSet _ thisLocation -> check thisLocation - OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation - _ -> lift Nothing + Full.SelectionSet _ thisLocation -> check thisLocation + Full.OperationDefinition _ Nothing _ _ _ thisLocation -> + check thisLocation + _ -> lift mempty where check thisLocation = asks ast - >>= lift . foldr (filterAnonymousOperations thisLocation) Nothing - filterAnonymousOperations thisLocation definition Nothing + >>= lift . foldr (filterAnonymousOperations thisLocation) mempty + filterAnonymousOperations thisLocation definition Empty | (viewOperation -> Just operationDefinition) <- definition = compareAnonymousOperations thisLocation operationDefinition filterAnonymousOperations _ _ accumulator = accumulator compareAnonymousOperations thisLocation = \case - OperationDefinition _ _ _ _ _ thatLocation + Full.OperationDefinition _ _ _ _ _ thatLocation | thisLocation /= thatLocation -> pure $ error' thisLocation - SelectionSet _ thatLocation + Full.SelectionSet _ thatLocation | thisLocation /= thatLocation -> pure $ error' thisLocation - _ -> Nothing - error' location = Error + _ -> mempty + error' location' = Error { message = "This anonymous operation must be the only defined operation." - , locations = [location] - , path = [] + , locations = [location'] } -- | Each named operation definition must be unique within a document when -- referred to by its name. uniqueOperationNamesRule :: forall m. Rule m uniqueOperationNamesRule = OperationDefinitionRule $ \case - OperationDefinition _ (Just thisName) _ _ _ thisLocation -> + Full.OperationDefinition _ (Just thisName) _ _ _ thisLocation -> findDuplicates (filterByName thisName) thisLocation (error' thisName) - _ -> lift Nothing + _ -> lift mempty where error' operationName = concat [ "There can be only one operation named \"" @@ -164,12 +233,12 @@ uniqueOperationNamesRule = OperationDefinitionRule $ \case ] filterByName thisName definition' accumulator | (viewOperation -> Just operationDefinition) <- definition' - , OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition + , Full.OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition , thisName == thatName = thatLocation : accumulator | otherwise = accumulator -findDuplicates :: (Definition -> [Location] -> [Location]) - -> Location +findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location]) + -> Full.Location -> String -> RuleT m findDuplicates filterByName thisLocation errorMessage = do @@ -177,21 +246,27 @@ findDuplicates filterByName thisLocation errorMessage = do let locations' = foldr filterByName [] ast' if length locations' > 1 && head locations' == thisLocation then pure $ error' locations' - else lift Nothing + else lift mempty where error' locations' = Error { message = errorMessage , locations = locations' - , path = [] } -viewOperation :: Definition -> Maybe OperationDefinition +viewOperation :: Full.Definition -> Maybe Full.OperationDefinition viewOperation definition - | ExecutableDefinition executableDefinition <- definition - , DefinitionOperation operationDefinition <- executableDefinition = + | Full.ExecutableDefinition executableDefinition <- definition + , Full.DefinitionOperation operationDefinition <- executableDefinition = Just operationDefinition viewOperation _ = Nothing +viewFragment :: Full.Definition -> Maybe Full.FragmentDefinition +viewFragment definition + | Full.ExecutableDefinition executableDefinition <- definition + , Full.DefinitionFragment fragmentDefinition <- executableDefinition = + Just fragmentDefinition +viewFragment _ = Nothing + -- | Fragment definitions are referenced in fragment spreads by name. To avoid -- ambiguity, each fragment’s name must be unique within a document. -- @@ -199,7 +274,7 @@ viewOperation _ = Nothing -- by this validation rule. uniqueFragmentNamesRule :: forall m. Rule m uniqueFragmentNamesRule = FragmentDefinitionRule $ \case - FragmentDefinition thisName _ _ _ thisLocation -> + Full.FragmentDefinition thisName _ _ _ thisLocation -> findDuplicates (filterByName thisName) thisLocation (error' thisName) where error' fragmentName = concat @@ -208,8 +283,733 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case , "\"." ] filterByName thisName definition accumulator - | ExecutableDefinition executableDefinition <- definition - , DefinitionFragment fragmentDefinition <- executableDefinition - , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition + | Just fragmentDefinition <- viewFragment definition + , Full.FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition , thisName == thatName = thatLocation : accumulator | otherwise = accumulator + +-- | Named fragment spreads must refer to fragments defined within the document. +-- It is a validation error if the target of a spread is not defined. +fragmentSpreadTargetDefinedRule :: forall m. Rule m +fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case + Full.FragmentSpread fragmentName _ location' -> do + ast' <- asks ast + case find (isSpreadTarget fragmentName) ast' of + Nothing -> pure $ Error + { message = error' fragmentName + , locations = [location'] + } + Just _ -> lift mempty + where + error' fragmentName = concat + [ "Fragment target \"" + , Text.unpack fragmentName + , "\" is undefined." + ] + +isSpreadTarget :: Text -> Full.Definition -> Bool +isSpreadTarget thisName (viewFragment -> Just fragmentDefinition) + | Full.FragmentDefinition thatName _ _ _ _ <- fragmentDefinition + , thisName == thatName = True +isSpreadTarget _ _ = False + +-- | Fragments must be specified on types that exist in the schema. This applies +-- for both named and inline fragments. If they are not defined in the schema, +-- the query does not validate. +fragmentSpreadTypeExistenceRule :: forall m. Rule m +fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case + Full.FragmentSpreadSelection fragmentSelection + | Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do + ast' <- asks ast + let target = find (isSpreadTarget fragmentName) ast' + typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition + types' <- asks $ Schema.types . schema + case HashMap.lookup typeCondition types' of + Nothing -> pure $ Error + { message = spreadError fragmentName typeCondition + , locations = [location'] + } + Just _ -> lift mempty + Full.InlineFragmentSelection fragmentSelection + | Full.InlineFragment maybeType _ _ location' <- fragmentSelection + , Just typeCondition <- maybeType -> do + types' <- asks $ Schema.types . schema + case HashMap.lookup typeCondition types' of + Nothing -> pure $ Error + { message = inlineError typeCondition + , locations = [location'] + } + Just _ -> lift mempty + _ -> lift mempty + where + extractTypeCondition (viewFragment -> Just fragmentDefinition) = + let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition + in Just typeCondition + extractTypeCondition _ = Nothing + spreadError fragmentName typeCondition = concat + [ "Fragment \"" + , Text.unpack fragmentName + , "\" is specified on type \"" + , Text.unpack typeCondition + , "\" which doesn't exist in the schema." + ] + inlineError typeCondition = concat + [ "Inline fragment is specified on type \"" + , Text.unpack typeCondition + , "\" which doesn't exist in the schema." + ] + +maybeToSeq :: forall a. Maybe a -> Seq a +maybeToSeq (Just x) = pure x +maybeToSeq Nothing = mempty + +-- | Fragments can only be declared on unions, interfaces, and objects. They are +-- invalid on scalars. They can only be applied on non‐leaf fields. This rule +-- applies to both inline and named fragments. +fragmentsOnCompositeTypesRule :: forall m. Rule m +fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule + where + inlineRule (Full.InlineFragment (Just typeCondition) _ _ location') = + check typeCondition location' + inlineRule _ = lift mempty + definitionRule (Full.FragmentDefinition _ typeCondition _ _ location') = + check typeCondition location' + check typeCondition location' = do + types' <- asks $ Schema.types . schema + -- Skip unknown types, they are checked by another rule. + _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types' + case Type.lookupTypeCondition typeCondition types' of + Nothing -> pure $ Error + { message = errorMessage typeCondition + , locations = [location'] + } + Just _ -> lift mempty + errorMessage typeCondition = concat + [ "Fragment cannot condition on non composite type \"" + , Text.unpack typeCondition, + "\"." + ] + +-- | Defined fragments must be used within a document. +noUnusedFragmentsRule :: forall m. Rule m +noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do + let Full.FragmentDefinition fragmentName _ _ _ location' = fragment + in mapReaderT (checkFragmentName fragmentName location') + $ asks ast + >>= flip evalStateT HashSet.empty + . filterSelections evaluateSelection + . foldMap definitionSelections + where + checkFragmentName fragmentName location' elements + | fragmentName `elem` elements = mempty + | otherwise = pure $ makeError fragmentName location' + makeError fragName location' = Error + { message = errorMessage fragName + , locations = [location'] + } + errorMessage fragName = concat + [ "Fragment \"" + , Text.unpack fragName + , "\" is never used." + ] + evaluateSelection selection + | Full.FragmentSpreadSelection spreadSelection <- selection + , Full.FragmentSpread spreadName _ _ <- spreadSelection = + lift $ pure spreadName + evaluateSelection _ = lift $ lift mempty + +definitionSelections :: Full.Definition -> Full.SelectionSetOpt +definitionSelections (viewOperation -> Just operation) + | Full.OperationDefinition _ _ _ _ selections _ <- operation = + toList selections + | Full.SelectionSet selections _ <- operation = toList selections +definitionSelections (viewFragment -> Just fragment) + | Full.FragmentDefinition _ _ _ selections _ <- fragment = toList selections +definitionSelections _ = [] + +filterSelections :: Foldable t + => forall a m + . (Full.Selection -> ValidationState m a) + -> t Full.Selection + -> ValidationState m a +filterSelections applyFilter selections + = (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections) + >>= applyFilter + where + evaluateSelection selection accumulator + | Full.FragmentSpreadSelection{} <- selection = selection : accumulator + | Full.FieldSelection fieldSelection <- selection + , Full.Field _ _ _ _ subselections _ <- fieldSelection = + selection : foldr evaluateSelection accumulator subselections + | Full.InlineFragmentSelection inlineSelection <- selection + , Full.InlineFragment _ _ subselections _ <- inlineSelection = + selection : foldr evaluateSelection accumulator subselections + +-- | The graph of fragment spreads must not form any cycles including spreading +-- itself. Otherwise an operation could infinitely spread or infinitely execute +-- on cycles in the underlying data. +noFragmentCyclesRule :: forall m. Rule m +noFragmentCyclesRule = FragmentDefinitionRule $ \case + Full.FragmentDefinition fragmentName _ _ selections location' -> do + state <- evalStateT (collectFields selections) + (0, fragmentName) + let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state) + case reverse spreadPath of + x : _ | x == fragmentName -> pure $ Error + { message = concat + [ "Cannot spread fragment \"" + , Text.unpack fragmentName + , "\" within itself (via " + , Text.unpack $ Text.intercalate " -> " $ fragmentName : spreadPath + , ")." + ] + , locations = [location'] + } + _ -> lift mempty + where + collectFields :: Traversable t + => t Full.Selection + -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int) + collectFields selectionSet = foldM forEach HashMap.empty selectionSet + forEach accumulator = \case + Full.FieldSelection fieldSelection -> forField accumulator fieldSelection + Full.InlineFragmentSelection fragmentSelection -> + forInline accumulator fragmentSelection + Full.FragmentSpreadSelection fragmentSelection -> + forSpread accumulator fragmentSelection + forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do + firstFragmentName <- gets snd + modify $ first (+ 1) + lastIndex <- gets fst + let newAccumulator = HashMap.insert fragmentName lastIndex accumulator + let inVisitetFragment = HashMap.member fragmentName accumulator + if fragmentName == firstFragmentName || inVisitetFragment + then pure newAccumulator + else collectFromSpread fragmentName newAccumulator + forInline accumulator (Full.InlineFragment _ _ selections _) = + (accumulator <>) <$> collectFields selections + forField accumulator (Full.Field _ _ _ _ selections _) = + (accumulator <>) <$> collectFields selections + collectFromSpread fragmentName accumulator = do + ast' <- lift $ asks ast + case findFragmentDefinition fragmentName ast' of + Nothing -> pure accumulator + Just (Full.FragmentDefinition _ _ _ selections _) -> + (accumulator <>) <$> collectFields selections + +findFragmentDefinition :: Text + -> NonEmpty Full.Definition + -> Maybe Full.FragmentDefinition +findFragmentDefinition fragmentName = foldr compareDefinition Nothing + where + compareDefinition (Full.ExecutableDefinition executableDefinition) Nothing + | Full.DefinitionFragment fragmentDefinition <- executableDefinition + , Full.FragmentDefinition anotherName _ _ _ _ <- fragmentDefinition + , anotherName == fragmentName = Just fragmentDefinition + compareDefinition _ accumulator = accumulator + +-- | Fields and directives treat arguments as a mapping of argument name to +-- value. More than one argument with the same name in an argument set is +-- ambiguous and invalid. +uniqueArgumentNamesRule :: forall m. Rule m +uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule + where + fieldRule _ (Full.Field _ _ arguments _ _ _) = + lift $ filterDuplicates extract "argument" arguments + directiveRule (Full.Directive _ arguments _) = + lift $ filterDuplicates extract "argument" arguments + extract (Full.Argument argumentName _ location') = (argumentName, location') + +-- | Directives are used to describe some metadata or behavioral change on the +-- definition they apply to. When more than one directive of the same name is +-- used, the expected metadata or behavior becomes ambiguous, therefore only one +-- of each directive is allowed per location. +uniqueDirectiveNamesRule :: forall m. Rule m +uniqueDirectiveNamesRule = DirectivesRule + $ const $ lift . filterDuplicates extract "directive" + where + extract (Full.Directive directiveName _ location') = + (directiveName, location') + +filterDuplicates :: (a -> (Text, Full.Location)) -> String -> [a] -> Seq Error +filterDuplicates extract nodeType = Seq.fromList + . fmap makeError + . filter ((> 1) . length) + . groupBy equalByName + . sortOn getName + where + getName = fst . extract + equalByName lhs rhs = getName lhs == getName rhs + makeError directives' = Error + { message = makeMessage $ head directives' + , locations = snd . extract <$> directives' + } + makeMessage directive = concat + [ "There can be only one " + , nodeType + , " named \"" + , Text.unpack $ fst $ extract directive + , "\"." + ] + +-- | If any operation defines more than one variable with the same name, it is +-- ambiguous and invalid. It is invalid even if the type of the duplicate +-- variable is the same. +uniqueVariableNamesRule :: forall m. Rule m +uniqueVariableNamesRule = VariablesRule + $ lift . filterDuplicates extract "variable" + where + extract (Full.VariableDefinition variableName _ _ location') = + (variableName, location') + +-- | Variables can only be input types. Objects, unions and interfaces cannot be +-- used as inputs. +variablesAreInputTypesRule :: forall m. Rule m +variablesAreInputTypesRule = VariablesRule + $ (traverse check . Seq.fromList) >=> lift + where + check (Full.VariableDefinition name typeName _ location') + = asks (Schema.types . schema) + >>= lift + . maybe (makeError name typeName location') (const mempty) + . Type.lookupInputType typeName + makeError name typeName location' = pure $ Error + { message = concat + [ "Variable \"$" + , Text.unpack name + , "\" cannot be non-input type \"" + , Text.unpack $ getTypeName typeName + , "\"." + ] + , locations = [location'] + } + getTypeName (Full.TypeNamed name) = name + getTypeName (Full.TypeList name) = getTypeName name + getTypeName (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) = nonNull + getTypeName (Full.TypeNonNull (Full.NonNullTypeList nonNull)) = + getTypeName nonNull + +-- | Variables are scoped on a per‐operation basis. That means that any variable +-- used within the context of an operation must be defined at the top level of +-- that operation. +noUndefinedVariablesRule :: forall m. Rule m +noUndefinedVariablesRule = + variableUsageDifference (flip HashMap.difference) errorMessage + where + errorMessage Nothing variableName = concat + [ "Variable \"$" + , Text.unpack variableName + , "\" is not defined." + ] + errorMessage (Just operationName) variableName = concat + [ "Variable \"$" + , Text.unpack variableName + , "\" is not defined by operation \"" + , Text.unpack operationName + , "\"." + ] + +type UsageDifference + = HashMap Full.Name [Full.Location] + -> HashMap Full.Name [Full.Location] + -> HashMap Full.Name [Full.Location] + +variableUsageDifference :: forall m. UsageDifference + -> (Maybe Full.Name -> Full.Name -> String) + -> Rule m +variableUsageDifference difference errorMessage = OperationDefinitionRule $ \case + Full.SelectionSet _ _ -> lift mempty + Full.OperationDefinition _ operationName variables _ selections _ -> + let variableNames = HashMap.fromList $ getVariableName <$> variables + in mapReaderT (readerMapper operationName variableNames) + $ flip evalStateT HashSet.empty + $ filterSelections' + $ toList selections + where + readerMapper operationName variableNames' = Seq.fromList + . fmap (makeError operationName) + . HashMap.toList + . difference variableNames' + . HashMap.fromListWith (++) + . toList + getVariableName (Full.VariableDefinition variableName _ _ location') = + (variableName, [location']) + filterSelections' :: Foldable t + => t Full.Selection + -> ValidationState m (Full.Name, [Full.Location]) + filterSelections' = filterSelections variableFilter + variableFilter :: Full.Selection -> ValidationState m (Full.Name, [Full.Location]) + variableFilter (Full.InlineFragmentSelection inline) + | Full.InlineFragment _ directives' _ _ <- inline = + lift $ lift $ mapDirectives directives' + variableFilter (Full.FieldSelection fieldSelection) + | Full.Field _ _ arguments directives' _ _ <- fieldSelection = + lift $ lift $ mapArguments arguments <> mapDirectives directives' + variableFilter (Full.FragmentSpreadSelection spread) + | Full.FragmentSpread fragmentName _ _ <- spread = do + definitions <- lift $ asks ast + visited <- gets (HashSet.member fragmentName) + modify (HashSet.insert fragmentName) + case find (isSpreadTarget fragmentName) definitions of + Just (viewFragment -> Just fragmentDefinition) + | not visited -> diveIntoSpread fragmentDefinition + _ -> lift $ lift mempty + diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _) + = filterSelections' selections + >>= lift . mapReaderT (<> mapDirectives directives') . pure + findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments + mapArguments = Seq.fromList . mapMaybe findArgumentVariables + mapDirectives = foldMap findDirectiveVariables + findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) = + Just (value', [location]) + findArgumentVariables _ = Nothing + makeError operationName (variableName, locations') = Error + { message = errorMessage operationName variableName + , locations = locations' + } + +-- | All variables defined by an operation must be used in that operation or a +-- fragment transitively included by that operation. Unused variables cause a +-- validation error. +noUnusedVariablesRule :: forall m. Rule m +noUnusedVariablesRule = variableUsageDifference HashMap.difference errorMessage + where + errorMessage Nothing variableName = concat + [ "Variable \"$" + , Text.unpack variableName + , "\" is never used." + ] + errorMessage (Just operationName) variableName = concat + [ "Variable \"$" + , Text.unpack variableName + , "\" is never used in operation \"" + , Text.unpack operationName + , "\"." + ] + +-- | Input objects must not contain more than one field of the same name, +-- otherwise an ambiguity would exist which includes an ignored portion of +-- syntax. +uniqueInputFieldNamesRule :: forall m. Rule m +uniqueInputFieldNamesRule = + ValueRule (const $ lift . go) (const $ lift . constGo) + where + go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields + go _ = mempty + filterFieldDuplicates fields = + filterDuplicates getFieldName "input field" fields + getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location') + constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields + constGo _ = mempty + +-- | The target field of a field selection must be defined on the scoped type of +-- the selection set. There are no limitations on alias names. +fieldsOnCorrectTypeRule :: forall m. Rule m +fieldsOnCorrectTypeRule = FieldRule fieldRule + where + fieldRule parentType (Full.Field _ fieldName _ _ _ location') + | Just objectType <- parentType + , Nothing <- Type.lookupTypeField fieldName objectType + , Just typeName <- compositeTypeName objectType = pure $ Error + { message = errorMessage fieldName typeName + , locations = [location'] + } + | otherwise = lift mempty + errorMessage fieldName typeName = concat + [ "Cannot query field \"" + , Text.unpack fieldName + , "\" on type \"" + , Text.unpack typeName + , "\"." + ] + +compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name +compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = + Just typeName +compositeTypeName (Out.InterfaceBaseType interfaceType) = + let Out.InterfaceType typeName _ _ _ = interfaceType + in Just typeName +compositeTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) = + Just typeName +compositeTypeName (Out.ScalarBaseType _) = + Nothing +compositeTypeName (Out.EnumBaseType _) = + Nothing +compositeTypeName (Out.ListBaseType wrappedType) = + compositeTypeName wrappedType + +-- | Field selections on scalars or enums are never allowed, because they are +-- the leaf nodes of any GraphQL query. +scalarLeafsRule :: forall m. Rule m +scalarLeafsRule = FieldRule fieldRule + where + fieldRule parentType selectionField@(Full.Field _ fieldName _ _ _ _) + | Just objectType <- parentType + , Just field <- Type.lookupTypeField fieldName objectType = + let Out.Field _ fieldType _ = field + in lift $ check fieldType selectionField + | otherwise = lift mempty + check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = + checkNotEmpty typeName + check (Out.InterfaceBaseType (Out.InterfaceType typeName _ _ _)) = + checkNotEmpty typeName + check (Out.UnionBaseType (Out.UnionType typeName _ _)) = + checkNotEmpty typeName + check (Out.ScalarBaseType (Definition.ScalarType typeName _)) = + checkEmpty typeName + check (Out.EnumBaseType (Definition.EnumType typeName _ _)) = + checkEmpty typeName + check (Out.ListBaseType wrappedType) = check wrappedType + checkNotEmpty typeName (Full.Field _ fieldName _ _ [] location') = + let fieldName' = Text.unpack fieldName + in makeError location' $ concat + [ "Field \"" + , fieldName' + , "\" of type \"" + , Text.unpack typeName + , "\" must have a selection of subfields. Did you mean \"" + , fieldName' + , " { ... }\"?" + ] + checkNotEmpty _ _ = mempty + checkEmpty _ (Full.Field _ _ _ _ [] _) = mempty + checkEmpty typeName field' = + let Full.Field _ fieldName _ _ _ location' = field' + in makeError location' $ concat + [ "Field \"" + , Text.unpack fieldName + , "\" must not have a selection since type \"" + , Text.unpack typeName + , "\" has no subfields." + ] + makeError location' errorMessage = pure $ Error + { message = errorMessage + , locations = [location'] + } + +-- | Every argument provided to a field or directive must be defined in the set +-- of possible arguments of that field or directive. +knownArgumentNamesRule :: forall m. Rule m +knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule + where + fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ _) + | Just typeField <- Type.lookupTypeField fieldName objectType + , Just typeName <- compositeTypeName objectType = + lift $ foldr (go typeName fieldName typeField) Seq.empty arguments + fieldRule _ _ = lift mempty + go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors + | Out.Field _ _ definitions <- fieldDefinition + , Just _ <- HashMap.lookup argumentName definitions = errors + | otherwise = errors |> Error + { message = fieldMessage argumentName fieldName typeName + , locations = [location'] + } + fieldMessage argumentName fieldName typeName = concat + [ "Unknown argument \"" + , Text.unpack argumentName + , "\" on field \"" + , Text.unpack typeName + , "." + , Text.unpack fieldName + , "\"." + ] + directiveRule (Full.Directive directiveName arguments _) = do + available <- asks $ HashMap.lookup directiveName + . Schema.directives . schema + Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments + case available of + Just (Schema.Directive _ _ definitions) + | not $ HashMap.member argumentName definitions -> + pure $ makeError argumentName directiveName location' + _ -> lift mempty + makeError argumentName directiveName location' = Error + { message = directiveMessage argumentName directiveName + , locations = [location'] + } + directiveMessage argumentName directiveName = concat + [ "Unknown argument \"" + , Text.unpack argumentName + , "\" on directive \"@" + , Text.unpack directiveName + , "\"." + ] + +-- | GraphQL servers define what directives they support. For each usage of a +-- directive, the directive must be available on that server. +knownDirectiveNamesRule :: Rule m +knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do + definitions' <- asks $ Schema.directives . schema + let directiveSet = HashSet.fromList $ fmap directiveName directives' + let definitionSet = HashSet.fromList $ HashMap.keys definitions' + let difference = HashSet.difference directiveSet definitionSet + let undefined' = filter (definitionFilter difference) directives' + lift $ Seq.fromList $ makeError <$> undefined' + where + definitionFilter difference = flip HashSet.member difference + . directiveName + directiveName (Full.Directive directiveName' _ _) = directiveName' + makeError (Full.Directive directiveName' _ location') = Error + { message = errorMessage directiveName' + , locations = [location'] + } + errorMessage directiveName' = concat + [ "Unknown directive \"@" + , Text.unpack directiveName' + , "\"." + ] + +-- | Every input field provided in an input object value must be defined in the +-- set of possible fields of that input object’s expected type. +knownInputFieldNamesRule :: Rule m +knownInputFieldNamesRule = ValueRule go constGo + where + go (Just valueType) (Full.Node (Full.Object inputFields) _) + | In.InputObjectBaseType objectType <- valueType = + lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields + go _ _ = lift mempty + constGo (Just valueType) (Full.Node (Full.ConstObject inputFields) _) + | In.InputObjectBaseType objectType <- valueType = + lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields + constGo _ _ = lift mempty + forEach objectType (Full.ObjectField inputFieldName _ location') + | In.InputObjectType _ _ fieldTypes <- objectType + , Just _ <- HashMap.lookup inputFieldName fieldTypes = Nothing + | otherwise + , In.InputObjectType typeName _ _ <- objectType = pure $ Error + { message = errorMessage inputFieldName typeName + , locations = [location'] + } + errorMessage fieldName typeName = concat + [ "Field \"" + , Text.unpack fieldName + , "\" is not defined by type \"" + , Text.unpack typeName + , "\"." + ] + +-- | GraphQL servers define what directives they support and where they support +-- them. For each usage of a directive, the directive must be used in a location +-- that the server has declared support for. +directivesInValidLocationsRule :: Rule m +directivesInValidLocationsRule = DirectivesRule directivesRule + where + directivesRule directiveLocation directives' = do + Full.Directive directiveName _ location <- lift $ Seq.fromList directives' + maybeDefinition <- asks + $ HashMap.lookup directiveName . Schema.directives . schema + case maybeDefinition of + Just (Schema.Directive _ allowedLocations _) + | directiveLocation `notElem` allowedLocations -> pure $ Error + { message = errorMessage directiveName directiveLocation + , locations = [location] + } + _ -> lift mempty + errorMessage directiveName directiveLocation = concat + [ "Directive \"@" + , Text.unpack directiveName + , "\" may not be used on " + , show directiveLocation + , "." + ] + +-- | Arguments can be required. An argument is required if the argument type is +-- non‐null and does not have a default value. Otherwise, the argument is +-- optional. +providedRequiredArgumentsRule :: Rule m +providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule + where + fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ location') + | Just typeField <- Type.lookupTypeField fieldName objectType + , Out.Field _ _ definitions <- typeField = + let forEach = go (fieldMessage fieldName) arguments location' + in lift $ HashMap.foldrWithKey forEach Seq.empty definitions + fieldRule _ _ = lift mempty + directiveRule (Full.Directive directiveName arguments location') = do + available <- asks + $ HashMap.lookup directiveName . Schema.directives . schema + case available of + Just (Schema.Directive _ _ definitions) -> + let forEach = go (directiveMessage directiveName) arguments location' + in lift $ HashMap.foldrWithKey forEach Seq.empty definitions + _ -> lift mempty + go makeMessage arguments location' argumentName argumentType errors + | In.Argument _ type' optionalValue <- argumentType + , In.isNonNullType type' + , typeName <- inputTypeName type' + , isNothing optionalValue + , isNothingOrNull $ find (lookupArgument argumentName) arguments + = errors + |> makeError (makeMessage argumentName typeName) location' + | otherwise = errors + makeError errorMessage location' = Error + { message = errorMessage + , locations = [location'] + } + isNothingOrNull (Just (Full.Argument _ (Full.Node Full.Null _) _)) = True + isNothingOrNull x = isNothing x + lookupArgument needle (Full.Argument argumentName _ _) = + needle == argumentName + fieldMessage fieldName argumentName typeName = concat + [ "Field \"" + , Text.unpack fieldName + , "\" argument \"" + , Text.unpack argumentName + , "\" of type \"" + , Text.unpack typeName + , "\" is required, but it was not provided." + ] + directiveMessage directiveName argumentName typeName = concat + [ "Directive \"@" + , Text.unpack directiveName + , "\" argument \"" + , Text.unpack argumentName + , "\" of type \"" + , Text.unpack typeName + , "\" is required, but it was not provided." + ] + +inputTypeName :: In.Type -> Text +inputTypeName (In.ScalarBaseType (Definition.ScalarType typeName _)) = typeName +inputTypeName (In.EnumBaseType (Definition.EnumType typeName _ _)) = typeName +inputTypeName (In.InputObjectBaseType (In.InputObjectType typeName _ _)) = + typeName +inputTypeName (In.ListBaseType listType) = inputTypeName listType + +-- | Input object fields may be required. Much like a field may have required +-- arguments, an input object may have required fields. An input field is +-- required if it has a non‐null type and does not have a default value. +-- Otherwise, the input object field is optional. +providedRequiredInputFieldsRule :: Rule m +providedRequiredInputFieldsRule = ValueRule go constGo + where + go (Just valueType) (Full.Node (Full.Object inputFields) location') + | In.InputObjectBaseType objectType <- valueType + , In.InputObjectType objectTypeName _ fieldDefinitions <- objectType + = lift + $ Seq.fromList + $ HashMap.elems + $ flip HashMap.mapMaybeWithKey fieldDefinitions + $ forEach inputFields objectTypeName location' + go _ _ = lift mempty + constGo _ _ = lift mempty + forEach inputFields typeName location' definitionName fieldDefinition + | In.InputField _ inputType optionalValue <- fieldDefinition + , In.isNonNullType inputType + , isNothing optionalValue + , isNothingOrNull $ find (lookupField definitionName) inputFields = + Just $ makeError definitionName typeName location' + | otherwise = Nothing + isNothingOrNull (Just (Full.ObjectField _ (Full.Node Full.Null _) _)) = True + isNothingOrNull x = isNothing x + lookupField needle (Full.ObjectField fieldName _ _) = needle == fieldName + makeError fieldName typeName location' = Error + { message = errorMessage fieldName typeName + , locations = [location'] + } + errorMessage fieldName typeName = concat + [ "Input field \"" + , Text.unpack fieldName + , "\" of type \"" + , Text.unpack typeName + , "\" is required, but it was not provided." + ] diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index 03bbf33..0432a1a 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -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 diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs index 5fa3706..0c7dd39 100644 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -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 diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs index 0b4cb31..c4fae45 100644 --- a/tests/Language/GraphQL/AST/LexerSpec.hs +++ b/tests/Language/GraphQL/AST/LexerSpec.hs @@ -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` "|" diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index f59e5a9..5c4d39e 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -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" :| [] diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs index 1497c48..38d7d3a 100644 --- a/tests/Language/GraphQL/ErrorSpec.hs +++ b/tests/Language/GraphQL/ErrorSpec.hs @@ -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 diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 8fbb55b..f6e3e6f 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -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 diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index 8f6626b..318045c 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -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] diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index e6b6cea..2d586f6 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -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 } } diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 089b721..f426e2c 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -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| { diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index ea89279..1921ec9 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -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 diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs deleted file mode 100644 index e3dd696..0000000 --- a/tests/Test/StarWars/Data.hs +++ /dev/null @@ -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 diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs deleted file mode 100644 index 95b18d3..0000000 --- a/tests/Test/StarWars/QuerySpec.hs +++ /dev/null @@ -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 diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs deleted file mode 100644 index cecd8eb..0000000 --- a/tests/Test/StarWars/Schema.hs +++ /dev/null @@ -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) - ] |