Repository: jml/graphql-api Branch: master Commit: 8ced344485cd Files: 68 Total size: 304.8 KB Directory structure: gitextract_pt0f4ya5/ ├── .circleci/ │ └── config.yml ├── .gitignore ├── .hindent.yaml ├── CHANGELOG.rst ├── HLint.hs ├── LICENSE.Apache-2.0 ├── LICENSE.BSD3 ├── Makefile ├── README.md ├── Setup.hs ├── benchmarks/ │ ├── Main.hs │ └── Validation.hs ├── docs/ │ ├── .gitignore │ ├── Makefile │ ├── README.md │ └── source/ │ ├── conf.py │ ├── index.rst │ └── tutorial/ │ ├── Introduction.lhs │ ├── LICENSE │ ├── package.yaml │ └── tutorial.cabal ├── examples/ │ ├── InputObject.hs │ └── UnionExample.hs ├── graphql-api.cabal ├── graphql-wai/ │ ├── graphql-wai.cabal │ ├── package.yaml │ ├── src/ │ │ └── GraphQL/ │ │ └── Wai.hs │ └── tests/ │ └── Tests.hs ├── package.yaml ├── scripts/ │ ├── build-image │ ├── hpc-ratchet │ ├── image-tag │ └── lint ├── src/ │ ├── GraphQL/ │ │ ├── API.hs │ │ ├── Internal/ │ │ │ ├── API/ │ │ │ │ └── Enum.hs │ │ │ ├── API.hs │ │ │ ├── Arbitrary.hs │ │ │ ├── Execution.hs │ │ │ ├── Name.hs │ │ │ ├── OrderedMap.hs │ │ │ ├── Output.hs │ │ │ ├── Resolver.hs │ │ │ ├── Schema.hs │ │ │ ├── Syntax/ │ │ │ │ ├── AST.hs │ │ │ │ ├── Encoder.hs │ │ │ │ ├── Parser.hs │ │ │ │ └── Tokens.hs │ │ │ ├── Validation.hs │ │ │ ├── Value/ │ │ │ │ ├── FromValue.hs │ │ │ │ └── ToValue.hs │ │ │ └── Value.hs │ │ ├── Resolver.hs │ │ └── Value.hs │ └── GraphQL.hs ├── stack-8.0.yaml ├── stack-8.2.yaml └── tests/ ├── ASTSpec.hs ├── EndToEndSpec.hs ├── EnumTests.hs ├── ExampleSchema.hs ├── Main.hs ├── OrderedMapSpec.hs ├── ResolverSpec.hs ├── SchemaSpec.hs ├── Spec.hs ├── ValidationSpec.hs ├── ValueSpec.hs └── doctests/ └── Main.hs ================================================ FILE CONTENTS ================================================ ================================================ FILE: .circleci/config.yml ================================================ version: 2 jobs: build-8.0: docker: # GHC 8.0.2 is the lowest supported compiler version. - image: fpco/stack-build:lts-9.21 steps: - checkout - restore_cache: keys: - stack-ghc-{{ checksum "stack-8.0.yaml" }} - restore_cache: keys: - stack-deps-{{ checksum "package.yaml" }} - run: name: Set up Stack command: STACK_YAML=stack-8.0.yaml stack setup --no-terminal --no-reinstall - save_cache: key: stack-ghc-{{ checksum "stack-8.0.yaml" }} paths: - /root/.stack - run: name: Install dependencies command: STACK_YAML=stack-8.0.yaml stack build --skip-ghc-check --no-terminal --test --only-dependencies - save_cache: key: stack-deps-{{ checksum "package.yaml" }} paths: - /root/.stack - .stack-work - run: # Build with --pedantic here to avoid introducing warnings. We # *don't* build with -Werror on Hackage as that is strongly # discouraged. name: Tests command: STACK_YAML=stack-8.0.yaml stack test --skip-ghc-check --no-terminal --pedantic build-8.2: docker: # Latest stackage LTS for GHC 8.2 at time of writing - image: fpco/stack-build:lts-10.4 steps: - checkout - restore_cache: keys: - stack-ghc-{{ checksum "stack-8.2.yaml" }} - restore_cache: keys: - stack-deps-{{ checksum "package.yaml" }} - run: name: Set up Stack command: STACK_YAML=stack-8.2.yaml stack setup --no-terminal --no-reinstall - save_cache: key: stack-ghc-{{ checksum "stack-8.2.yaml" }} paths: - /root/.stack - run: name: Install dependencies command: STACK_YAML=stack-8.2.yaml stack build --skip-ghc-check --no-terminal --test --only-dependencies - save_cache: key: stack-deps-{{ checksum "package.yaml" }} paths: - /root/.stack - .stack-work - run: # Build with --pedantic here to avoid introducing warnings. We # *don't* build with -Werror on Hackage as that is strongly # discouraged. # # Build with --coverage to ratchet our test coverage. name: Tests command: STACK_YAML=stack-8.2.yaml stack test --skip-ghc-check --no-terminal --pedantic --coverage - store_artifacts: path: /root/project/.stack-work/install/x86_64-linux/lts-10.4/8.2.2/hpc - run: # There's probably a clever way of separating this from the 8.2 build, # but I can't be bothered figuring that out right now. # Thus, tacking the coverage check onto one of the builds, # arbitrarily picking 8.2 because I feel like it. name: Coverage command: STACK_YAML=stack-8.2.yaml ./scripts/hpc-ratchet workflows: version: 2 build_all_versions: jobs: - build-8.0 - build-8.2 ================================================ FILE: .gitignore ================================================ .stack-work ================================================ FILE: .hindent.yaml ================================================ indent-size: 2 line-length: 80 force-trailing-newline: true ================================================ FILE: CHANGELOG.rst ================================================ ===================== graphql-api changelog ===================== 0.4.0 (YYYY-MM-DD) ================== * Schemas that have empty field lists or empty unions will fail much earlier 0.3.0 (2018-02-08) ================== Breaking changes ---------------- * ``Enum`` handlers are now monadic (see `#118`_) * You must use protolude 0.2.1 or later * ``Defaultable`` must now be imported from ``GraphQL.API``, rather than ``GraphQL.Resolver``, this moves ``GraphQL.API`` closer to being sufficient for API definition. (see `#149`_) * ``GraphQL.Value.ToValue`` and ``GraphQL.Value.FromValue`` modules have been removed. Import ``ToValue(..)`` and ``FromValue(..)`` from ``GraphQL.Value`` directly. Improvements ------------ * Now support GHC 8.2 as well as 8.0.2 and later * Added support for anonymous queries (thanks `@sunwukonga`_) .. _`#118`: https://github.com/jml/graphql-api/issues/118 .. _`#149`: https://github.com/haskell-graphql/graphql-api/issues/149 .. _`@sunwukonga`: https://github.com/sunwukonga v0.2.0 (2017-10-12) =================== * Make ``Name`` an overloaded string that panics if an invalid name is provided. * Correctly descend into the type parameter of a ``Maybe``. See https://github.com/jml/graphql-api/issues/119. This is a backwards-incompatible change. A common update would be having to ``fmap pure callback`` instead of just ``callback`` for ``Maybe`` handlers. v0.1.0 (2017-01-30) =================== No code changes. * Remove ``-Werror`` in order to upload to hackage v0.1.0 (2017-01-29) =================== Initial release, support basic handling of GraphQL queries. ================================================ FILE: HLint.hs ================================================ import "hint" HLint.HLint import "hint" HLint.Generalise ignore "Use fmap" ignore "Redundant do" ignore "Use =<<" ================================================ FILE: LICENSE.Apache-2.0 ================================================ Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: You must give any other recipients of the Work or Derivative Works a copy of this License; and You must cause any modified files to carry prominent notices stating that You changed the files; and You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS ================================================ FILE: LICENSE.BSD3 ================================================ Copyright J. Daniel Navarro (c) 2015 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of J. Daniel Navarro nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: Makefile ================================================ .PHONY: check clean docs format lint check: stack test --fast clean: stack clean docs: stack haddock format: ./scripts/hindent-everything lint: hlint -q . ================================================ FILE: README.md ================================================ # graphql-api [![CircleCI](https://circleci.com/gh/jml/graphql-api.svg?style=shield)](https://circleci.com/gh/jml/graphql-api) [![Documentation Status](https://readthedocs.org/projects/haskell-graphql-api/badge/?version=latest)](http://haskell-graphql-api.readthedocs.io/en/latest/?badge=latest) `graphql-api` helps you implement a robust [GraphQL](http://graphql.org/) API in Haskell. By the time a query makes it to your handler you are dealing with strong, static types that make sense for your problem domain. All your handlers are normal Haskell functions because we derive their type signature from the schema. If you have used [servant](http://haskell-servant.readthedocs.io/en/stable/), this will sound familiar. The library provides type combinators to create a GraphQL schema, and functions to parse and evaluate queries against the schema. You can find the latest release on [hackage](https://hackage.haskell.org/package/graphql-api). We implement the [GraphQL specification](https://facebook.github.io/graphql/) as best as we can in Haskell. We figure they know what they're doing. Even if an alternative API or behaviour looks nicer, we will defer to the spec. ## Tutorial A simple graphql-api tutorial can be read at [readthedocs.io](http://haskell-graphql-api.readthedocs.io/en/latest/tutorial/Introduction.html). To follow along and get your hands dirty, clone this repository, enter the `graphql-api` root directory, and run: ``` stack repl tutorial ``` ## Example Say we have a simple GraphQL schema like: ```graphql type Hello { greeting(who: String!): String! } ``` which defines a single top-level type `Hello` which contains a single field, `greeting`, that takes a single, required argument `who`. We can define this schema in Haskell and implement a simple handler like so: ```haskell {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} import Data.Text (Text) import Data.Monoid ((<>)) import GraphQL import GraphQL.API import GraphQL.Resolver (Handler, returns) type Hello = Object "Hello" '[] '[ Argument "who" Text :> Field "greeting" Text ] hello :: Handler IO Hello hello = pure (\who -> returns ("Hello " <> who)) run :: Text -> IO Response run = interpretAnonymousQuery @Hello hello ``` We require GHC 8.0.2 or later for features like the `@Hello` type application, and for certain bug fixes. We also support GHC 8.2. With the code above we can now run a query: ```haskell run "{ greeting(who: \"mort\") }" ``` Which will produce the following GraphQL response: ```json { "data": { "greeting": "Hello mort" } } ``` ## Status Our current goal is to gather feedback. We have learned a lot about GraphQL in the course of making this library, but we don't know what a good GraphQL library looks like in Haskell. Please [let us know](https://github.com/jml/graphql-api/issues/new) what you think. We won't mind if you file a bug telling us how good the library is. Because we're still learning, we make **no** guarantees about API stability, or anything at all really. We are tracking open problems, missing features & wishlist items in [GitHub's issue tracker](https://github.com/jml/graphql-api/issues). ## Roadmap * Near future: - Better error messages (this is really important to us) - Full support for recursive data types - Close off loose ends in current implementation & gather feedback * Medium future: - Full schema validation - Schema introspection - Stabilize public API * Long term: - Derive client implementations from types - Allow users to implement their own type combinators ## References * [GraphQL Specification](http://facebook.github.io/graphql/) ([source](https://github.com/facebook/graphql)) * [GraphQL tutorial](http://graphql.org/learn/) * [GraphQL AST in Haskell](http://hackage.haskell.org/package/graphql-0.3/docs/Data-GraphQL-AST.html) ## Copyright All files Copyright (c) 2016-2017 Thomas E. Hunger & Jonathan M. Lange, except: * src/GraphQL/Internal/Syntax/AST.hs * src/GraphQL/Internal/Syntax/Encoder.hs * src/GraphQL/Internal/Syntax/Parser.hs for which see LICENSE.BSD3 in this repository. ================================================ FILE: Setup.hs ================================================ import Distribution.Simple main = defaultMain ================================================ FILE: benchmarks/Main.hs ================================================ module Main (main) where import Protolude import Criterion.Main (bgroup, defaultMain) import qualified Validation main :: IO () main = do defaultMain [ bgroup "GraphQL API" Validation.benchmarks ] ================================================ FILE: benchmarks/Validation.hs ================================================ {-# LANGUAGE TypeApplications #-} module Validation (benchmarks) where import Protolude import Criterion (Benchmark, bench, nf) import GraphQL.Internal.Validation (findDuplicates) benchmarks :: [Benchmark] benchmarks = [ bench "findDuplicates" (nf findDuplicates exampleData) ] where exampleData :: [Int] exampleData = [2, 8, 9, 8, 1, 7, 5, 0, 1, 3, 5, 4] ================================================ FILE: docs/.gitignore ================================================ build source/tutorial/dist ================================================ FILE: docs/Makefile ================================================ # Makefile for Sphinx documentation # # You can set these variables from the command line. SPHINXOPTS = SPHINXBUILD = sphinx-build PAPER = BUILDDIR = build # User-friendly check for sphinx-build ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1) $(error The '$(SPHINXBUILD)' command was not found. Make sure you have Sphinx installed, then set the SPHINXBUILD environment variable to point to the full path of the '$(SPHINXBUILD)' executable. Alternatively you can add the directory with the executable to your PATH. If you don't have Sphinx installed, grab it from http://sphinx-doc.org/) endif # Internal variables. PAPEROPT_a4 = -D latex_paper_size=a4 PAPEROPT_letter = -D latex_paper_size=letter ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source # the i18n builder cannot share the environment and doctrees with the others I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source .PHONY: help help: @echo "Please use \`make ' where is one of" @echo " html to make standalone HTML files" @echo " dirhtml to make HTML files named index.html in directories" @echo " singlehtml to make a single large HTML file" @echo " pickle to make pickle files" @echo " json to make JSON files" @echo " htmlhelp to make HTML files and a HTML help project" @echo " qthelp to make HTML files and a qthelp project" @echo " applehelp to make an Apple Help Book" @echo " devhelp to make HTML files and a Devhelp project" @echo " epub to make an epub" @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter" @echo " latexpdf to make LaTeX files and run them through pdflatex" @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx" @echo " text to make text files" @echo " man to make manual pages" @echo " texinfo to make Texinfo files" @echo " info to make Texinfo files and run them through makeinfo" @echo " gettext to make PO message catalogs" @echo " changes to make an overview of all changed/added/deprecated items" @echo " xml to make Docutils-native XML files" @echo " pseudoxml to make pseudoxml-XML files for display purposes" @echo " linkcheck to check all external links for integrity" @echo " doctest to run all doctests embedded in the documentation (if enabled)" @echo " coverage to run coverage check of the documentation (if enabled)" .PHONY: clean clean: rm -rf $(BUILDDIR)/* .PHONY: html html: $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html @echo @echo "Build finished. The HTML pages are in $(BUILDDIR)/html." .PHONY: dirhtml dirhtml: $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml @echo @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml." .PHONY: singlehtml singlehtml: $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml @echo @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml." .PHONY: pickle pickle: $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle @echo @echo "Build finished; now you can process the pickle files." .PHONY: json json: $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json @echo @echo "Build finished; now you can process the JSON files." .PHONY: htmlhelp htmlhelp: $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp @echo @echo "Build finished; now you can run HTML Help Workshop with the" \ ".hhp project file in $(BUILDDIR)/htmlhelp." .PHONY: qthelp qthelp: $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp @echo @echo "Build finished; now you can run "qcollectiongenerator" with the" \ ".qhcp project file in $(BUILDDIR)/qthelp, like this:" @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/GraphQLAPItutorial.qhcp" @echo "To view the help file:" @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/GraphQLAPItutorial.qhc" .PHONY: applehelp applehelp: $(SPHINXBUILD) -b applehelp $(ALLSPHINXOPTS) $(BUILDDIR)/applehelp @echo @echo "Build finished. The help book is in $(BUILDDIR)/applehelp." @echo "N.B. You won't be able to view it unless you put it in" \ "~/Library/Documentation/Help or install it in your application" \ "bundle." .PHONY: devhelp devhelp: $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp @echo @echo "Build finished." @echo "To view the help file:" @echo "# mkdir -p $$HOME/.local/share/devhelp/GraphQLAPItutorial" @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/GraphQLAPItutorial" @echo "# devhelp" .PHONY: epub epub: $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub @echo @echo "Build finished. The epub file is in $(BUILDDIR)/epub." .PHONY: latex latex: $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex @echo @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." @echo "Run \`make' in that directory to run these through (pdf)latex" \ "(use \`make latexpdf' here to do that automatically)." .PHONY: latexpdf latexpdf: $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex @echo "Running LaTeX files through pdflatex..." $(MAKE) -C $(BUILDDIR)/latex all-pdf @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." .PHONY: latexpdfja latexpdfja: $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex @echo "Running LaTeX files through platex and dvipdfmx..." $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." .PHONY: text text: $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text @echo @echo "Build finished. The text files are in $(BUILDDIR)/text." .PHONY: man man: $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man @echo @echo "Build finished. The manual pages are in $(BUILDDIR)/man." .PHONY: texinfo texinfo: $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo @echo @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo." @echo "Run \`make' in that directory to run these through makeinfo" \ "(use \`make info' here to do that automatically)." .PHONY: info info: $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo @echo "Running Texinfo files through makeinfo..." make -C $(BUILDDIR)/texinfo info @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo." .PHONY: gettext gettext: $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale @echo @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale." .PHONY: changes changes: $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes @echo @echo "The overview file is in $(BUILDDIR)/changes." .PHONY: linkcheck linkcheck: $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck @echo @echo "Link check complete; look for any errors in the above output " \ "or in $(BUILDDIR)/linkcheck/output.txt." .PHONY: doctest doctest: $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest @echo "Testing of doctests in the sources finished, look at the " \ "results in $(BUILDDIR)/doctest/output.txt." .PHONY: coverage coverage: $(SPHINXBUILD) -b coverage $(ALLSPHINXOPTS) $(BUILDDIR)/coverage @echo "Testing of coverage in the sources finished, look at the " \ "results in $(BUILDDIR)/coverage/python.txt." .PHONY: xml xml: $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml @echo @echo "Build finished. The XML files are in $(BUILDDIR)/xml." .PHONY: pseudoxml pseudoxml: $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml @echo @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml." ================================================ FILE: docs/README.md ================================================ # Documentation The docs are written in literal Haskell (`.lhs` ending) and [Sphinx](http://www.sphinx-doc.org/). To build the docs install sphinx and recommonmark. To make sure the tutorial still compiles go to `./source/tutorial` and run `cabal build`. ================================================ FILE: docs/source/conf.py ================================================ # -*- coding: utf-8 -*- # # GraphQL API tutorial documentation build configuration file, created by # sphinx-quickstart on Fri Dec 16 13:29:48 2016. # # This file is execfile()d with the current directory set to its # containing dir. # # Note that not all possible configuration values are present in this # autogenerated file. # # All configuration values have a default; values that are commented out # serve to show the default. import sys import os from recommonmark.parser import CommonMarkParser # If extensions (or modules to document with autodoc) are in another directory, # add these directories to sys.path here. If the directory is relative to the # documentation root, use os.path.abspath to make it absolute, like shown here. #sys.path.insert(0, os.path.abspath('.')) # -- General configuration ------------------------------------------------ # If your documentation needs a minimal Sphinx version, state it here. #needs_sphinx = '1.0' # Add any Sphinx extension module names here, as strings. They can be # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom # ones. extensions = [] # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] # The suffix(es) of source filenames. # You can specify multiple suffix as a list of string: source_suffix = ['.rst', '.md', '.lhs'] # The encoding of source files. #source_encoding = 'utf-8-sig' # The master toctree document. master_doc = 'index' # General information about the project. project = u'GraphQL API tutorial' copyright = u'2016, teh, jml' author = u'teh, jml' # The version info for the project you're documenting, acts as replacement for # |version| and |release|, also used in various other places throughout the # built documents. # # The short X.Y version. version = u'0.1' # The full version, including alpha/beta/rc tags. release = u'0.1' # The language for content autogenerated by Sphinx. Refer to documentation # for a list of supported languages. # # This is also used if you do content translation via gettext catalogs. # Usually you set "language" from the command line for these cases. language = None # There are two options for replacing |today|: either, you set today to some # non-false value, then it is used: #today = '' # Else, today_fmt is used as the format for a strftime call. #today_fmt = '%B %d, %Y' # List of patterns, relative to source directory, that match files and # directories to ignore when looking for source files. exclude_patterns = [] # The reST default role (used for this markup: `text`) to use for all # documents. #default_role = None # If true, '()' will be appended to :func: etc. cross-reference text. #add_function_parentheses = True # If true, the current module name will be prepended to all description # unit titles (such as .. function::). #add_module_names = True # If true, sectionauthor and moduleauthor directives will be shown in the # output. They are ignored by default. #show_authors = False # The name of the Pygments (syntax highlighting) style to use. pygments_style = 'sphinx' # A list of ignored prefixes for module index sorting. #modindex_common_prefix = [] # If true, keep warnings as "system message" paragraphs in the built documents. #keep_warnings = False # If true, `todo` and `todoList` produce output, else they produce nothing. todo_include_todos = False # -- Options for HTML output ---------------------------------------------- # The theme to use for HTML and HTML Help pages. See the documentation for # a list of builtin themes. html_theme = 'classic' # Theme options are theme-specific and customize the look and feel of a theme # further. For a list of options available for each theme, see the # documentation. #html_theme_options = {} # Add any paths that contain custom themes here, relative to this directory. #html_theme_path = [] # The name for this set of Sphinx documents. If None, it defaults to # " v documentation". #html_title = None # A shorter title for the navigation bar. Default is the same as html_title. #html_short_title = None # The name of an image file (relative to this directory) to place at the top # of the sidebar. #html_logo = None # The name of an image file (relative to this directory) to use as a favicon of # the docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 # pixels large. #html_favicon = None # Add any paths that contain custom static files (such as style sheets) here, # relative to this directory. They are copied after the builtin static files, # so a file named "default.css" will overwrite the builtin "default.css". html_static_path = ['_static'] # Add any extra paths that contain custom files (such as robots.txt or # .htaccess) here, relative to this directory. These files are copied # directly to the root of the documentation. #html_extra_path = [] # If not '', a 'Last updated on:' timestamp is inserted at every page bottom, # using the given strftime format. #html_last_updated_fmt = '%b %d, %Y' # If true, SmartyPants will be used to convert quotes and dashes to # typographically correct entities. #html_use_smartypants = True # Custom sidebar templates, maps document names to template names. #html_sidebars = {} # Additional templates that should be rendered to pages, maps page names to # template names. #html_additional_pages = {} # If false, no module index is generated. #html_domain_indices = True # If false, no index is generated. #html_use_index = True # If true, the index is split into individual pages for each letter. #html_split_index = False # If true, links to the reST sources are added to the pages. #html_show_sourcelink = True # If true, "Created using Sphinx" is shown in the HTML footer. Default is True. #html_show_sphinx = True # If true, "(C) Copyright ..." is shown in the HTML footer. Default is True. #html_show_copyright = True # If true, an OpenSearch description file will be output, and all pages will # contain a tag referring to it. The value of this option must be the # base URL from which the finished HTML is served. #html_use_opensearch = '' # This is the file name suffix for HTML files (e.g. ".xhtml"). #html_file_suffix = None # Language to be used for generating the HTML full-text search index. # Sphinx supports the following languages: # 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja' # 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr' #html_search_language = 'en' # A dictionary with options for the search language support, empty by default. # Now only 'ja' uses this config value #html_search_options = {'type': 'default'} # The name of a javascript file (relative to the configuration directory) that # implements a search results scorer. If empty, the default will be used. #html_search_scorer = 'scorer.js' # Output file base name for HTML help builder. htmlhelp_basename = 'GraphQLAPItutorialdoc' # -- Options for LaTeX output --------------------------------------------- latex_elements = { # The paper size ('letterpaper' or 'a4paper'). #'papersize': 'letterpaper', # The font size ('10pt', '11pt' or '12pt'). #'pointsize': '10pt', # Additional stuff for the LaTeX preamble. #'preamble': '', # Latex figure (float) alignment #'figure_align': 'htbp', } # Grouping the document tree into LaTeX files. List of tuples # (source start file, target name, title, # author, documentclass [howto, manual, or own class]). latex_documents = [ (master_doc, 'GraphQLAPItutorial.tex', u'GraphQL API tutorial Documentation', u'teh, jml', 'manual'), ] # The name of an image file (relative to this directory) to place at the top of # the title page. #latex_logo = None # For "manual" documents, if this is true, then toplevel headings are parts, # not chapters. #latex_use_parts = False # If true, show page references after internal links. #latex_show_pagerefs = False # If true, show URL addresses after external links. #latex_show_urls = False # Documents to append as an appendix to all manuals. #latex_appendices = [] # If false, no module index is generated. #latex_domain_indices = True # -- Options for manual page output --------------------------------------- # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). man_pages = [ (master_doc, 'graphqlapitutorial', u'GraphQL API tutorial Documentation', [author], 1) ] # If true, show URL addresses after external links. #man_show_urls = False # -- Options for Texinfo output ------------------------------------------- # Grouping the document tree into Texinfo files. List of tuples # (source start file, target name, title, author, # dir menu entry, description, category) texinfo_documents = [ (master_doc, 'GraphQLAPItutorial', u'GraphQL API tutorial Documentation', author, 'GraphQLAPItutorial', 'One line description of project.', 'Miscellaneous'), ] # Documents to append as an appendix to all manuals. #texinfo_appendices = [] # If false, no module index is generated. #texinfo_domain_indices = True # How to display URL addresses: 'footnote', 'no', or 'inline'. #texinfo_show_urls = 'footnote' # If true, do not generate a @detailmenu in the "Top" node's menu. #texinfo_no_detailmenu = False source_parsers = { '.md': CommonMarkParser, '.lhs': CommonMarkParser, } ================================================ FILE: docs/source/index.rst ================================================ .. GraphQL API tutorial documentation master file, created by sphinx-quickstart on Fri Dec 16 13:29:48 2016. You can adapt this file completely to your liking, but it should at least contain the root `toctree` directive. Welcome to GraphQL API tutorial's documentation! ================================================ Contents: .. toctree:: :maxdepth: 1 tutorial/Introduction.lhs Indices and tables ================== * :ref:`genindex` * :ref:`modindex` * :ref:`search` ================================================ FILE: docs/source/tutorial/Introduction.lhs ================================================ # Defining GraphQL type APIs First some imports: ``` haskell {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Introduction where import Protolude import System.Random import GraphQL import GraphQL.API (Object, Field, Argument, (:>), Union) import GraphQL.Resolver (Handler, (:<>)(..), unionValue, returns, handlerError) ``` ## A simple GraphQL service A [GraphQL](http://graphql.org/) service is made up of two things: 1. A schema that defines the service 2. Some code that implements the service's behavior We're going to build a very simple service that says hello to people. Our GraphQL schema for this looks like: ```graphql type Hello { greeting(who: String!): String! } ``` Which means we have base type, an _object_ called `Hello`, which has a single _field_ `greeting`, which takes a non-nullable `String` called `who` and returns a `String`. Note that all the types here are GraphQL types, not Haskell types. `String` here is a GraphQL `String`, not a Haskell one. And we want to be able to send queries that look like: ```graphql { greeting(who: "world") } ``` And get responses like: ```json { "data": { "greeting": "Hello world!" } } ``` ### Defining the schema Here's how we would define the schema in Haskell: ```haskell type Hello = Object "Hello" '[] '[ Argument "who" Text :> Field "greeting" Text ] ``` Breaking this down, we define a new Haskell type `Hello`, which is a GraphQL object (also named `"Hello"`) that implements no interfaces (hence `'[]`). It has one field, called `"greeting"` which returns some `Text` and takes a single named argument `"who"`, which is also `Text`. Note that the GraphQL `String` from above got translated into a Haskell `Text`. There are some noteworthy differences between this schema and the GraphQL schema: * The GraphQL schema requires a special annotation to say that a value cannot be null, `!`. In Haskell, we instead assume that nothing can be null. * In the GraphQL schema, the argument appears *after* the field name. In Haskell, it appears *before*. * In Haskell, we name the top-level type twice, once on left hand side of the type definition and once on the right. ### Implementing the handlers Once we have the schema, we need to define the corresponding handlers, which are `Handler` values. Here's a `Handler` for `Hello`: ```haskell hello :: Handler IO Hello hello = pure greeting where greeting who = returns ("Hello " <> who <> "!") ``` The type signature, `Handler IO Hello` shows that it's a `Handler` for `Hello`, and that it runs in the `IO` monad. (Note: nothing about this example code requires the `IO` monad, it's just a monad that lots of people has heard of.) The implementation looks slightly weird, but it's weird for good reasons. The first layer of the handler, `pure greeting`, produces the `Hello` object. The `pure` might seem redundant here, but making this step monadic allows us to run actions in the base monad. The second layer of the handler, the implementation of `greeting`, produces the value of the `greeting` field. It is monadic so that it will only be executed when the field was requested. It uses the 'returns' function to return the value for the field in the monad (technically, the Applicative context which is OK because a Monad is Applicative). Each field handler is a separate monadic action so we only perform the side effects for fields present in the query. This handler is in `Identity` because it doesn't do anything particularly monadic. It could be in `IO` or `STM` or `ExceptT Text IO` or whatever you would like. ### Errors in handlers It's possible that a handler will encounter an error as well (for example, the argument might be looked up in a database and the user might specify a non-existent user). To help support GraphQL-compliant errors, a handler can use the `handlerError` function with the error text. Here's a modified `Handler` for `Hello`: ```haskell helloFancy :: Handler IO Hello helloFancy = pure greeting where greeting who = if who == "" then handlerError "I need to know your name!" else returns ("Hello " <> who <> "!") ``` ### Running queries Defining a service isn't much point unless you can query. Here's how: ```haskell queryHello :: IO Response queryHello = interpretAnonymousQuery @Hello hello "{ greeting(who: \"mort\") }" ``` The actual `Response` type is fairly verbose, so we're most likely to turn it into JSON: ``` λ Aeson.encode <$> queryHello "{\"greeting\":\"Hello mort!\"}" ``` ## Combining field handlers with :<> How do we define an object with more than one field? Let's implement a simple calculator that can add and subtract integers. First, the schema: ```graphql type Calculator { add(a: Int!, b: Int!): Int!, sub(a: Int!, b: Int!): Int!, } ``` Here, `Calculator` is an object with two fields: `add` and `sub`. And now the Haskell version: ``` haskell type Calculator = Object "Calculator" '[] '[ Argument "a" Int32 :> Argument "b" Int32 :> Field "add" Int32 , Argument "a" Int32 :> Argument "b" Int32 :> Field "subtract" Int32 ] ``` So far, this is the same as our `Hello` example. And its handler: ```haskell calculator :: Handler IO Calculator calculator = pure (add :<> subtract') where add a b = returns (a + b) subtract' a b = returns (a - b) ``` This handler introduces a new operator, `:<>` (pronounced "birdface"), which is used to compose two existing handlers into a new handler. It's inspired by the operator for monoids, `<>`. Note that we use `returns` for each individual handler. ## Nesting Objects How do we define objects made up other objects? One of the great things in GraphQL is that objects can be used as types for fields. Take this classic GraphQL schema as an example: ```graphql type Query { me: User! } type User { name: Text! } ``` We would query this schema with something like: ```graphql { me { name } } ``` Which would produce output like: ```json { "data": { "me": { "name": "Mort" } } } ``` The Haskell type for this schema looks like: ```haskell type User = Object "User" '[] '[Field "name" Text] type Query = Object "Query" '[] '[Field "me" User] ``` Note that `Query` refers to the type `User` when it defines the field `me`. We write nested handlers the same way we write the top-level handler: ```haskell user :: Handler IO User user = pure name where name = returns "Mort" query :: Handler IO Query query = pure user ``` And that's it. ## Unions GraphQL has [support for union types](http://graphql.org/learn/schema/#union-types). These require special treatment in Haskell. Let's define a union, first in GraphQL: ```graphql union UserOrCalculator = User | Calculator ``` And now in Haskell: ```haskell type UserOrCalculator = Union "UserOrCalculator" '[User, Calculator] ``` And let's define a very simple top-level object that uses `UserOrCalculator`: ```haskell type UnionQuery = Object "UnionQuery" '[] '[Field "union" UserOrCalculator] ``` and a handler that randomly returns either a user or a calculator: ```haskell unionQuery :: Handler IO UnionQuery unionQuery = do returnUser <- randomIO if returnUser then pure (unionValue @User user) else pure (unionValue @Calculator calculator) ``` The important thing here is that we have to wrap the actual objects we return using `unionValue`. Note that while `unionValue` looks a bit like `unsafeCoerce` by forcing one type to become another type, it's actually type-safe because we use a *type-index* to pick the correct type from the union. Using e.g. `unionValue @HelloWorld handler` will not compile because `HelloWorld` is not in the union. ## Where next? We have an [examples](https://github.com/jml/graphql-api/tree/master/tests/Examples) directory showing full code examples. We also have a fair number of [end-to-end tests](https://github.com/jml/graphql-api/tree/master/tests/EndToEndTests.hs) based on an [example schema](https://github.com/jml/graphql-api/tree/master/tests/ExampleSchema.hs) that you might find interesting. If you want to try the examples in this tutorial you can run: ```bash stack repl tutorial ``` ================================================ FILE: docs/source/tutorial/LICENSE ================================================ ================================================ FILE: docs/source/tutorial/package.yaml ================================================ name: tutorial version: 0.0.1 synopsis: GraphQL library tutorial license: Apache license-file: LICENSE maintainer: tehunger@gmail.com, Jonathan M. Lange ghc-options: -Wall -pgmL markdown-unlit default-extensions: - NoImplicitPrelude library: exposed-modules: - Introduction dependencies: - base >= 4.9 && < 5 - protolude - graphql-api - random - markdown-unlit >= 0.4 - aeson ================================================ FILE: docs/source/tutorial/tutorial.cabal ================================================ -- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack -- -- hash: b3da6c729f0fa19c9ad82cb7e45f616850463bcc1654b9cd4797e34f6685ebd8 name: tutorial version: 0.0.1 synopsis: GraphQL library tutorial license: Apache license-file: LICENSE maintainer: tehunger@gmail.com, Jonathan M. Lange build-type: Simple cabal-version: >= 1.10 library default-extensions: NoImplicitPrelude exposed-modules: Introduction other-modules: Paths_tutorial build-depends: aeson , base >=4.9 && <5 , graphql-api , markdown-unlit >=0.4 , protolude , random default-language: Haskell2010 ghc-options: -Wall -pgmL markdown-unlit ================================================ FILE: examples/InputObject.hs ================================================ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeOperators #-} -- | Demonstrate input object usage. module Main (main) where import Protolude hiding (Enum) import qualified Data.Aeson as Aeson import GraphQL import GraphQL.API import GraphQL.Resolver (Handler, returns) import GraphQL.Value (FromValue, toValue) data DogStuff = DogStuff { _toy :: Text, _likesTreats :: Bool } deriving (Show, Generic) instance FromValue DogStuff instance HasAnnotatedInputType DogStuff instance Defaultable DogStuff where -- TODO defaultFor takes a Name which makes sense, but what's the -- name for an input object? defaultFor _ = Just (DogStuff "shoe" False) type Query = Object "Query" '[] '[ Argument "dogStuff" DogStuff :> Field "description" Text ] root :: Handler IO Query root = pure description description :: DogStuff -> Handler IO Text description (DogStuff toy likesTreats) | likesTreats = returns $ "likes treats and their favorite toy is a " <> toy | otherwise = returns $ "their favorite toy is a " <> toy -- | Show input object usage -- -- >>> response <- example "{ description(dogStuff: {toy: \"bone\", likesTreats: true}) }" -- >>> putStrLn $ encode $ toValue response -- {"data":{"description":"likes treats and their favorite toy is a bone"}} -- -- >>> response <- example "{ description }" -- >>> putStrLn $ encode $ toValue response -- {"data":{"description":"their favorite toy is a shoe"}} example :: Text -> IO Response example = interpretAnonymousQuery @Query root main :: IO () main = do response <- example "{ description(dogStuff: {_toy: \"bone\", _likesTreats: true}) }" putStrLn $ Aeson.encode $ toValue response response' <- example "{ description }" putStrLn $ Aeson.encode $ toValue response' ================================================ FILE: examples/UnionExample.hs ================================================ {-# LANGUAGE DataKinds #-} module Main (main) where import Protolude import qualified Data.Aeson as Aeson import GraphQL.API (Field, List, Object, Union) import GraphQL (interpretAnonymousQuery) import GraphQL.Resolver (Handler, (:<>)(..), unionValue, returns) import GraphQL.Value (ToValue(..)) -- Slightly reduced example from the spec type MiniCat = Object "MiniCat" '[] '[Field "name" Text, Field "meowVolume" Int32] type MiniDog = Object "MiniDog" '[] '[Field "barkVolume" Int32] type CatOrDog = Object "Me" '[] '[Field "myPet" (Union "CatOrDog" '[MiniCat, MiniDog])] type CatOrDogList = Object "CatOrDogList" '[] '[Field "pets" (List (Union "CatOrDog" '[MiniCat, MiniDog]))] miniCat :: Text -> Handler IO MiniCat miniCat name = pure (returns name :<> returns 32) miniDog :: Handler IO MiniDog miniDog = pure (returns 100) catOrDog :: Handler IO CatOrDog catOrDog = pure $ do name <- pure "MonadicFelix" -- we can do monadic actions unionValue @MiniCat (miniCat name) catOrDogList :: Handler IO CatOrDogList catOrDogList = pure $ returns [ unionValue @MiniCat (miniCat "Felix") , unionValue @MiniCat (miniCat "Mini") , unionValue @MiniDog miniDog ] main :: IO () main = do response <- interpretAnonymousQuery @CatOrDog catOrDog "{ myPet { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" putStrLn $ Aeson.encode $ toValue response response' <- interpretAnonymousQuery @CatOrDogList catOrDogList "{ pets { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" putStrLn $ Aeson.encode $ toValue response' ================================================ FILE: graphql-api.cabal ================================================ -- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- -- hash: e921bbdc9931b5b0b16603d36a3252522602c736862259ef71abdecf046541e2 name: graphql-api version: 0.3.0 synopsis: GraphQL API description: Implement [GraphQL](http://graphql.org/) servers in Haskell. . Provides a Servant-like type-based API for defining GraphQL schemas and implementing handlers for those schemas. . See [README.md](https://github.com/haskell-graphql/graphql-api#graphql-api) for more details. category: Web stability: unstable homepage: https://github.com/haskell-graphql/graphql-api#readme bug-reports: https://github.com/haskell-graphql/graphql-api/issues author: Jonathan M. Lange, Tom Hunger maintainer: Jonathan M. Lange , Tom Hunger license: Apache license-file: LICENSE.Apache-2.0 build-type: Simple cabal-version: >= 1.10 extra-source-files: CHANGELOG.rst source-repository head type: git location: https://github.com/haskell-graphql/graphql-api library hs-source-dirs: src default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints build-depends: QuickCheck , aeson , attoparsec , base >=4.9 && <5 , containers , exceptions , ghc-prim , protolude >=0.2.1 , scientific , text , transformers exposed-modules: GraphQL GraphQL.API GraphQL.Internal.API GraphQL.Internal.API.Enum GraphQL.Internal.Arbitrary GraphQL.Internal.Execution GraphQL.Internal.Name GraphQL.Internal.OrderedMap GraphQL.Internal.Output GraphQL.Internal.Resolver GraphQL.Internal.Schema GraphQL.Internal.Syntax.AST GraphQL.Internal.Syntax.Encoder GraphQL.Internal.Syntax.Parser GraphQL.Internal.Syntax.Tokens GraphQL.Internal.Validation GraphQL.Internal.Value GraphQL.Internal.Value.FromValue GraphQL.Internal.Value.ToValue GraphQL.Resolver GraphQL.Value other-modules: Paths_graphql_api default-language: Haskell2010 executable input-object-example main-is: InputObject.hs hs-source-dirs: examples default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints build-depends: aeson , attoparsec , base >=4.9 && <5 , exceptions , graphql-api , protolude >=0.2.1 , transformers default-language: Haskell2010 executable union-example main-is: UnionExample.hs hs-source-dirs: examples default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints build-depends: aeson , attoparsec , base >=4.9 && <5 , exceptions , graphql-api , protolude >=0.2.1 , transformers default-language: Haskell2010 test-suite graphql-api-doctests type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: tests/doctests default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints -threaded build-depends: attoparsec , base >=4.9 && <5 , doctest , exceptions , protolude >=0.2.1 , transformers other-modules: Paths_graphql_api default-language: Haskell2010 test-suite graphql-api-tests type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: tests default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints build-depends: QuickCheck , aeson , attoparsec , base >=4.9 && <5 , containers , directory , exceptions , graphql-api , hspec , protolude >=0.2.1 , raw-strings-qq , transformers other-modules: ASTSpec EndToEndSpec EnumTests ExampleSchema OrderedMapSpec ResolverSpec SchemaSpec Spec ValidationSpec ValueSpec Paths_graphql_api default-language: Haskell2010 benchmark criterion type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: benchmarks default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints build-depends: attoparsec , base >=4.9 && <5 , criterion , exceptions , graphql-api , protolude >=0.2.1 , transformers other-modules: Validation Paths_graphql_api default-language: Haskell2010 ================================================ FILE: graphql-wai/graphql-wai.cabal ================================================ -- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack -- -- hash: 12d030d800c1c036c89a9464dd8de8b05f9f6dc28e0faae9d2b105b2b120460e name: graphql-wai version: 0.1.0 synopsis: A simple wai adapter category: Web homepage: https://github.com/jml/graphql-api#readme bug-reports: https://github.com/jml/graphql-api/issues license: Apache build-type: Simple cabal-version: >= 1.10 source-repository head type: git location: https://github.com/jml/graphql-api library hs-source-dirs: src default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints -Werror build-depends: aeson , base >=4.9 && <5 , exceptions , graphql-api , http-types , protolude , wai exposed-modules: GraphQL.Wai other-modules: Paths_graphql_wai default-language: Haskell2010 test-suite wai-tests type: exitcode-stdio-1.0 main-is: Tests.hs hs-source-dirs: tests default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints -Werror build-depends: aeson , base >=4.9 && <5 , exceptions , graphql-api , graphql-wai , http-types , protolude , wai , wai-extra other-modules: Paths_graphql_wai default-language: Haskell2010 ================================================ FILE: graphql-wai/package.yaml ================================================ name: graphql-wai version: 0.1.0 synopsis: A simple wai adapter license: Apache github: jml/graphql-api category: Web # NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099 ghc-options: -Wall -fno-warn-redundant-constraints -Werror default-extensions: - NoImplicitPrelude - OverloadedStrings - RecordWildCards - TypeApplications dependencies: - base >= 4.9 && < 5 - protolude - exceptions - wai - http-types - graphql-api - aeson library: source-dirs: src tests: wai-tests: main: Tests.hs source-dirs: tests dependencies: - wai-extra - graphql-wai ================================================ FILE: graphql-wai/src/GraphQL/Wai.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | Basic WAI handlers for graphql-api module GraphQL.Wai ( toApplication ) where import Protolude import qualified Data.Aeson as Aeson import Network.Wai (Application, queryString, responseLBS) import Network.HTTP.Types.Header (hContentType) import Network.HTTP.Types.Status (status200, status400) import GraphQL (interpretAnonymousQuery) import GraphQL.API (HasObjectDefinition, Object) import GraphQL.Resolver (HasResolver, Handler, OperationResolverConstraint) import GraphQL.Value (toValue) -- | Adapt a GraphQL handler to a WAI application. This is really just -- to illustrate the mechanism, and not production ready at this point -- in time. -- -- If you have a 'Cat' type and a corresponding 'catHandler' then you -- can use "toApplication @Cat catHandler". toApplication :: forall r typeName interfaces fields. ( HasResolver IO r , r ~ Object typeName interfaces fields , OperationResolverConstraint IO fields typeName interfaces , HasObjectDefinition r ) => Handler IO r -> Application toApplication handler = app where app req respond = case queryString req of [("query", Just query)] -> do r <- interpretAnonymousQuery @r handler (toS query) let json = Aeson.encode (toValue r) respond $ responseLBS status200 [(hContentType, "application/json")] json _ -> respond $ responseLBS status400 [] "Must provide excatly one query GET argument." ================================================ FILE: graphql-wai/tests/Tests.hs ================================================ {-# LANGUAGE DataKinds #-} module Main where import Protolude import Network.Wai.Test import GraphQL.API import GraphQL.Wai import GraphQL.Resolver type Cat = Object "Cat" '[] '[Field "name" Text] catHandler :: Handler IO Cat catHandler = pure (returns "Felix") test1 :: Session () test1 = do r <- request $ setPath defaultRequest "/?query={ name }" assertStatus 200 r assertBody "{\"data\":{\"name\":\"Felix\"}}" r main :: IO () main = do void $ runSession test1 (toApplication @Cat catHandler) ================================================ FILE: package.yaml ================================================ name: graphql-api version: 0.3.0 synopsis: GraphQL API description: | Implement [GraphQL](http://graphql.org/) servers in Haskell. Provides a Servant-like type-based API for defining GraphQL schemas and implementing handlers for those schemas. See [README.md](https://github.com/haskell-graphql/graphql-api#graphql-api) for more details. author: Jonathan M. Lange, Tom Hunger maintainer: Jonathan M. Lange , Tom Hunger license: Apache license-file: LICENSE.Apache-2.0 github: haskell-graphql/graphql-api category: Web stability: unstable extra-source-files: - CHANGELOG.rst # NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099 ghc-options: -Wall -fno-warn-redundant-constraints default-extensions: - NoImplicitPrelude - OverloadedStrings - RecordWildCards - TypeApplications dependencies: - base >= 4.9 && < 5 - protolude >= 0.2.1 - exceptions - transformers - attoparsec library: source-dirs: src dependencies: - aeson - containers - ghc-prim - scientific - QuickCheck - text executables: input-object-example: main: InputObject.hs source-dirs: examples other-modules: [] dependencies: - aeson - graphql-api union-example: main: UnionExample.hs source-dirs: examples other-modules: [] dependencies: - aeson - graphql-api tests: graphql-api-tests: main: Main.hs source-dirs: tests dependencies: - aeson - containers - graphql-api - hspec - QuickCheck - raw-strings-qq - directory graphql-api-doctests: main: Main.hs ghc-options: -threaded source-dirs: tests/doctests dependencies: - doctest benchmarks: criterion: main: Main.hs source-dirs: benchmarks dependencies: - criterion - graphql-api ================================================ FILE: scripts/build-image ================================================ #!/usr/bin/env bash image_tag="${1}" image_id=$(stack --docker image container --build | tail -n-1 | awk '{{ print $3 }}') image_name=$(docker images --format '{{ .Repository }}\t{{ .ID }}' | grep "${image_id}" | head -n1 | cut -f1) docker tag "${image_id}" "${image_name}:${image_tag}" echo "${image_name}:${image_tag}" ================================================ FILE: scripts/hpc-ratchet ================================================ #!/usr/bin/python """Ensure our test coverage only increases. Easier than figuring out how to get hpc-coveralls to work with Stack. If this fails, and the coverage went down: add some tests. If this fails, and the coverage went up: edit ``DESIRED_COVERAGE`` to match the new value. If this succeeds, great. If you want to get details of what's covered, run:: $ stack test --coverage And look at the generated HTML. """ from __future__ import division from pprint import pprint import re import subprocess import sys EXPRESSIONS = 'expressions' BOOLEANS = 'booleans' ALTERNATIVES = 'alternatives' LOCAL_DECLS = 'local_decls' TOP_LEVEL_DECLS = 'top_level_decls' """The lack of coverage we are willing to tolerate. In a just world, this would be a separate config file, or command-line arguments. Each item represents the number of "things" we are OK with not being covered. """ COVERAGE_TOLERANCE = { ALTERNATIVES: 151, BOOLEANS: 8, EXPRESSIONS: 1351, LOCAL_DECLS: 10, TOP_LEVEL_DECLS: 670, } def get_report_summary(): """Run ``stack hpc report --all`` and return the output. Assumes that ``stack test --coverage`` has already been run. """ process = subprocess.Popen(["stack", "hpc", "report", "--all"], stderr=subprocess.PIPE) stdout, stderr = process.communicate() return stderr """Parse a line from the summary. Takes a line like: NN% thingy wotsit used (YYYY/ZZZZ) And turns it into: ("thingy wotsit used", "YYYY", "ZZZZ") """ _summary_line_re = re.compile(r'^\d\d% ([a-z -]+) \((\d+)/(\d+)\)$') """Map from the human-readable descriptions to keys in the summary dict.""" _summary_line_entries = { 'expressions used': EXPRESSIONS, 'boolean coverage': BOOLEANS, 'alternatives used': ALTERNATIVES, 'local declarations used': LOCAL_DECLS, 'top-level declarations used': TOP_LEVEL_DECLS, } def parse_summary_line(summary_line): """Parse a line in the summary that indicates coverage we want to ratchet. Turns:: NN% thingy wotsit used (YYYY/ZZZZ) Into:: ('thingy', YYYY, ZZZZ) Returns ``None`` if the line doesn't match the pattern. """ match = _summary_line_re.match(summary_line.strip()) if match is None: return description, covered, total = match.groups() try: key = _summary_line_entries[description] # XXX: Explodes if output changes. except KeyError: return return key, int(covered), int(total) def parse_report_summary(summary): """Parse the output of ``stack hpc report --all``. Turns this:: Getting project config file from STACK_YAML environment Generating combined report 57% expressions used (2172/3801) 47% boolean coverage (9/19) 38% guards (5/13), 4 always True, 4 unevaluated 75% 'if' conditions (3/4), 1 unevaluated 50% qualifiers (1/2), 1 always True 45% alternatives used (156/344) 81% local declarations used (70/86) 33% top-level declarations used (348/1052) The combined report is available at /path/hpc_index.html Into this:: {'expressions': (2172, 3801), 'booleans': (9, 19), 'alternatives': (156, 344), 'local_decls': (70, 86), 'top_level_decls': (348, 1052), } """ report = {} for line in summary.splitlines(): parsed = parse_summary_line(line) if not parsed: continue key, covered, total = parsed report[key] = (covered, total) return report def compare_values((covered, total), tolerance): """Compare measured coverage values with our tolerated lack of coverage. Return -1 if coverage has got worse, 0 if it is the same, 1 if it is better. """ missing = total - covered return cmp(tolerance, missing) def compare_coverage(report, desired): comparison = {} for key, actual in report.items(): tolerance = desired.get(key, 0) if actual: comparison[key] = compare_values(actual, tolerance) else: comparison[key] = None return comparison def format_result(result): if result < 0: return 'WORSE' elif result == 0: return 'OK' else: return 'BETTER' def format_entry(key, result, desired, actual): covered, total = actual formatted_result = format_result(result) # TODO: Align results if result: return '%s: %s (%d missing => %d missing)' % ( key, formatted_result, desired, total - covered, ) else: return '%s: %s' % (key, formatted_result) def main(): report = parse_report_summary(get_report_summary()) comparison = compare_coverage(report, COVERAGE_TOLERANCE) all_same = True for key, value in sorted(comparison.items()): if value != 0: all_same = False print format_entry(key, value, COVERAGE_TOLERANCE.get(key, 0), report[key]) sys.exit(0 if all_same else 2) if __name__ == '__main__': main() ================================================ FILE: scripts/image-tag ================================================ #!/usr/bin/env bash set -o errexit set -o nounset set -o pipefail BRANCH_PREFIX=$(git rev-parse --abbrev-ref HEAD 2>/dev/null || echo "") if [ -z "${BRANCH_PREFIX}" ]; then echo "unversioned" else WORKING_SUFFIX=$(if ! git diff --exit-code --quiet HEAD >&2; \ then echo "-WIP"; \ else echo ""; \ fi) echo "${BRANCH_PREFIX//\//-}-$(git rev-parse --short HEAD)$WORKING_SUFFIX" fi ================================================ FILE: scripts/lint ================================================ #!/bin/sh hlint -XTypeApplications src/ tests/ ================================================ FILE: src/GraphQL/API.hs ================================================ -- | Description: Define a GraphQL schema with Haskell types -- -- Use this to define your GraphQL schema with Haskell types. module GraphQL.API ( Object , Field , Argument , Union , List , Enum , GraphQLEnum(..) , Interface , (:>)(..) , Defaultable(..) , HasObjectDefinition(..) , HasAnnotatedInputType(..) , SchemaError(..) ) where import GraphQL.Internal.API ( Object , Field , Argument , Union , List , Enum , GraphQLEnum(..) , Interface , (:>)(..) , Defaultable(..) , HasObjectDefinition(..) , HasAnnotatedInputType(..) , SchemaError(..) ) ================================================ FILE: src/GraphQL/Internal/API/Enum.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Define GraphQL Enums with Haskell types module GraphQL.Internal.API.Enum ( GraphQLEnum(..) ) where import Protolude hiding (Enum, TypeError) import GHC.Generics (D, (:+:)(..)) import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) import GHC.Types (Type) import GraphQL.Internal.Name (Name, nameFromSymbol, NameError) import GraphQL.Internal.Output (GraphQLError(..)) invalidEnumName :: forall t. NameError -> Either Text t invalidEnumName x = Left ("In Enum: " <> formatError x) -- TODO: Enums have a slightly more restricted set of names than 'Name' -- implies. Especially, they cannot be 'true', 'false', or 'nil'. The parser -- /probably/ guarantees this, so it should export this guarantee by providing -- an 'Enum' type. class GenericEnumValues (f :: Type -> Type) where genericEnumValues :: [Either NameError Name] -- XXX: Why is this 'Text' and not 'NameError'? genericEnumFromValue :: Name -> Either Text (f p) genericEnumToValue :: f p -> Name instance forall conName m p f nt. ( KnownSymbol conName , KnownSymbol m , KnownSymbol p , GenericEnumValues f ) => GenericEnumValues (M1 D ('MetaData conName m p nt) f) where genericEnumValues = genericEnumValues @f genericEnumFromValue name = M1 <$> genericEnumFromValue name genericEnumToValue (M1 gv) = genericEnumToValue gv instance forall left right. ( GenericEnumValues left , GenericEnumValues right ) => GenericEnumValues (left :+: right) where genericEnumValues = genericEnumValues @left <> genericEnumValues @right genericEnumFromValue vname = let left = genericEnumFromValue @left vname right = genericEnumFromValue @right vname in case (left, right) of (x@(Right _), Left _) -> L1 <$> x (Left _, x@(Right _)) -> R1 <$> x (err@(Left _), Left _) -> L1 <$> err _ -> panic "Can't have two successful branches in Haskell" genericEnumToValue (L1 gv) = genericEnumToValue gv genericEnumToValue (R1 gv) = genericEnumToValue gv instance forall conName p b. (KnownSymbol conName) => GenericEnumValues (C1 ('MetaCons conName p b) U1) where genericEnumValues = let name = nameFromSymbol @conName in [name] genericEnumFromValue vname = case nameFromSymbol @conName of Right name -> if name == vname then Right (M1 U1) else Left ("Not a valid choice for enum: " <> show vname) -- XXX: This is impossible to catch during validation, because we cannot -- validate type-level symbols, we can only validate values. We could -- show that the schema is invalid at the type-level and still decide to -- call this anyway. The error should rather say that the schema is -- invalid. -- -- Further, we don't actually have any schema-level validation, so -- "should have been caught during validation" is misleading. Left x -> invalidEnumName x genericEnumToValue (M1 _) = let Right name = nameFromSymbol @conName in name -- TODO(tom): better type errors using `n`. Also type errors for other -- invalid constructors. instance forall conName p b sa sb. ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) , KnownSymbol conName ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb)) where genericEnumValues = nonUnaryConstructorError genericEnumFromValue = nonUnaryConstructorError genericEnumToValue = nonUnaryConstructorError instance forall conName p b sa sb f. ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) , KnownSymbol conName ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb) :+: f) where genericEnumValues = nonUnaryConstructorError genericEnumFromValue = nonUnaryConstructorError genericEnumToValue = nonUnaryConstructorError nonUnaryConstructorError :: a nonUnaryConstructorError = panic "Tried to construct enum with non-unary constructor. Should get a compile-time error instead of this." -- | For each enum type we need 1) a list of all possible values 2) a -- way to serialise and 3) deserialise. -- -- TODO: Update this comment to explain what a GraphQLEnum is, why you might -- want an instance, and any laws that apply to method relations. class GraphQLEnum a where -- TODO: Document each of these methods. enumValues :: [Either NameError Name] default enumValues :: (Generic a, GenericEnumValues (Rep a)) => [Either NameError Name] enumValues = genericEnumValues @(Rep a) enumFromValue :: Name -> Either Text a default enumFromValue :: (Generic a, GenericEnumValues (Rep a)) => Name -> Either Text a enumFromValue v = to <$> genericEnumFromValue v enumToValue :: a -> Name default enumToValue :: (Generic a, GenericEnumValues (Rep a)) => a -> Name enumToValue = genericEnumToValue . from ================================================ FILE: src/GraphQL/Internal/API.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Define a GraphQL schema with Haskell types module GraphQL.Internal.API ( Object , Field , Argument , Union , List , Enum , GraphQLEnum(..) , Interface , (:>)(..) , Defaultable(..) , HasAnnotatedType(..) , HasAnnotatedInputType , HasObjectDefinition(..) , getArgumentDefinition , SchemaError(..) , nameFromSymbol -- | Exported for testing. , getFieldDefinition , getInterfaceDefinition , getAnnotatedInputType ) where import Protolude hiding (Enum, TypeError) import qualified Data.List.NonEmpty as NonEmpty import Data.Semigroup as S ((<>)) import GHC.Generics ((:*:)(..)) import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..)) import GHC.Types (Type) import qualified GraphQL.Internal.Schema as Schema import qualified GraphQL.Internal.Name as Name import GraphQL.Internal.Name (Name, NameError) import GraphQL.Internal.API.Enum (GraphQLEnum(..)) import GraphQL.Internal.Output (GraphQLError(..)) -- $setup -- >>> :set -XDataKinds -XTypeOperators -- | Argument operator. Can only be used with 'Field'. -- -- Say we have a @Company@ object that has a field that shows whether -- someone is an employee, e.g. -- -- @ -- type Company { -- hasEmployee(employeeName: String!): String! -- } -- @ -- -- Then we might represent that as: -- -- >>> type Company = Object "Company" '[] '[Argument "employeeName" Text :> Field "hasEmployee" Bool] -- -- For multiple arguments, simply chain them together with ':>', ending -- finally with 'Field'. e.g. -- -- @ -- Argument "foo" String :> Argument "bar" Int :> Field "qux" Int -- @ data a :> b = a :> b infixr 8 :> data Object (name :: Symbol) (interfaces :: [Type]) (fields :: [Type]) data Enum (name :: Symbol) (values :: Type) data Union (name :: Symbol) (types :: [Type]) data List (elemType :: Type) -- TODO(tom): AFACIT We can't constrain "fields" to e.g. have at least -- one field in it - is this a problem? data Interface (name :: Symbol) (fields :: [Type]) data Field (name :: Symbol) (fieldType :: Type) data Argument (name :: Symbol) (argType :: Type) -- | The type-level schema was somehow invalid. data SchemaError = NameError NameError | EmptyFieldList | EmptyUnion deriving (Eq, Show) instance GraphQLError SchemaError where formatError (NameError err) = formatError err formatError EmptyFieldList = "Empty field list in type definition" formatError EmptyUnion = "Empty object list in union" nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either SchemaError Name nameFromSymbol = first NameError (Name.nameFromSymbol @n) -- | Specify a default value for a type in a GraphQL schema. -- -- GraphQL schema can have default values in certain places. For example, -- arguments to fields can have default values. Because we cannot lift -- arbitrary values to the type level, we need some way of getting at those -- values. This typeclass provides the means. -- -- To specify a default, implement this typeclass. -- -- The default implementation is to say that there *is* no default for this -- type. class Defaultable a where -- | defaultFor returns the value to be used when no value has been given. defaultFor :: Name -> Maybe a defaultFor _ = empty instance Defaultable Int32 instance Defaultable Double instance Defaultable Bool instance Defaultable Text instance Defaultable (Maybe a) where -- | The default for @Maybe a@ is @Nothing@. defaultFor _ = pure Nothing cons :: a -> [a] -> [a] cons = (:) singleton :: a -> NonEmpty a singleton x = x :| [] -- Transform into a Schema definition class HasObjectDefinition a where -- Todo rename to getObjectTypeDefinition getDefinition :: Either SchemaError Schema.ObjectTypeDefinition class HasFieldDefinition a where getFieldDefinition :: Either SchemaError Schema.FieldDefinition -- Fields class HasFieldDefinitions a where getFieldDefinitions :: Either SchemaError (NonEmpty Schema.FieldDefinition) instance forall a as. (HasFieldDefinition a, HasFieldDefinitions as) => HasFieldDefinitions (a:as) where getFieldDefinitions = case getFieldDefinitions @as of Left EmptyFieldList -> singleton <$> getFieldDefinition @a Left err -> Left err Right fields -> NonEmpty.cons <$> getFieldDefinition @a <*> pure fields instance HasFieldDefinitions '[] where getFieldDefinitions = Left EmptyFieldList -- object types from union type lists, e.g. for -- Union "Horse" '[Leg, Head, Tail] -- ^^^^^^^^^^^^^^^^^^ this part class HasUnionTypeObjectTypeDefinitions a where getUnionTypeObjectTypeDefinitions :: Either SchemaError (NonEmpty Schema.ObjectTypeDefinition) instance forall a as. (HasObjectDefinition a, HasUnionTypeObjectTypeDefinitions as) => HasUnionTypeObjectTypeDefinitions (a:as) where getUnionTypeObjectTypeDefinitions = case getUnionTypeObjectTypeDefinitions @as of Left EmptyUnion -> singleton <$> getDefinition @a Left err -> Left err Right objects -> NonEmpty.cons <$> getDefinition @a <*> pure objects instance HasUnionTypeObjectTypeDefinitions '[] where getUnionTypeObjectTypeDefinitions = Left EmptyUnion -- Interfaces class HasInterfaceDefinitions a where getInterfaceDefinitions :: Either SchemaError Schema.Interfaces instance forall a as. (HasInterfaceDefinition a, HasInterfaceDefinitions as) => HasInterfaceDefinitions (a:as) where getInterfaceDefinitions = cons <$> getInterfaceDefinition @a <*> getInterfaceDefinitions @as instance HasInterfaceDefinitions '[] where getInterfaceDefinitions = pure [] class HasInterfaceDefinition a where getInterfaceDefinition :: Either SchemaError Schema.InterfaceTypeDefinition instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where getInterfaceDefinition = let name = nameFromSymbol @ks fields = getFieldDefinitions @fields in Schema.InterfaceTypeDefinition <$> name <*> fields -- Give users some help if they don't terminate Arguments with a Field: -- NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099 instance forall ks t. TypeError ('Text ":> Arguments must end with a Field") => HasFieldDefinition (Argument ks t) where getFieldDefinition = panic ":> Arugments must end with a Field. This should not happen, but rather we'll get a compile-time error instead." instance forall ks is ts. (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions ts) => HasAnnotatedType (Object ks is ts) where getAnnotatedType = let obj = getDefinition @(Object ks is ts) in (Schema.TypeNamed . Schema.DefinedType . Schema.TypeDefinitionObject) <$> obj instance forall t ks. (KnownSymbol ks, HasAnnotatedType t) => HasFieldDefinition (Field ks t) where getFieldDefinition = let name = nameFromSymbol @ks in Schema.FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t class HasArgumentDefinition a where getArgumentDefinition :: Either SchemaError Schema.ArgumentDefinition instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where getArgumentDefinition = Schema.ArgumentDefinition <$> argName <*> argType <*> defaultValue where argName = nameFromSymbol @ks argType = getAnnotatedInputType @t defaultValue = pure Nothing instance forall a b. (HasArgumentDefinition a, HasFieldDefinition b) => HasFieldDefinition (a :> b) where getFieldDefinition = prependArg <$> argument <*> getFieldDefinition @b where prependArg arg (Schema.FieldDefinition name argDefs at) = Schema.FieldDefinition name (arg:argDefs) at argument = getArgumentDefinition @a instance forall ks is fields. (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions fields) => HasObjectDefinition (Object ks is fields) where getDefinition = let name = nameFromSymbol @ks interfaces = getInterfaceDefinitions @is fields = getFieldDefinitions @fields in Schema.ObjectTypeDefinition <$> name <*> interfaces <*> fields -- Builtin output types (annotated types) class HasAnnotatedType a where -- TODO - the fact that we have to return TypeNonNull for normal -- types will amost certainly lead to bugs because people will -- forget this. Maybe we can flip the internal encoding to be -- non-null by default and needing explicit null-encoding (via -- Maybe). getAnnotatedType :: Either SchemaError (Schema.AnnotatedType Schema.GType) -- | Turn a non-null type into the optional version of its own type. dropNonNull :: Schema.AnnotatedType t -> Schema.AnnotatedType t dropNonNull (Schema.TypeNonNull (Schema.NonNullTypeNamed t)) = Schema.TypeNamed t dropNonNull (Schema.TypeNonNull (Schema.NonNullTypeList t)) = Schema.TypeList t dropNonNull x@(Schema.TypeNamed _) = x dropNonNull x@(Schema.TypeList _) = x instance forall a. HasAnnotatedType a => HasAnnotatedType (Maybe a) where -- see TODO in HasAnnotatedType class getAnnotatedType = dropNonNull <$> getAnnotatedType @a builtinType :: Schema.Builtin -> Either SchemaError (Schema.AnnotatedType Schema.GType) builtinType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinType -- TODO(jml): Given that AnnotatedType is parametrised, we can probably reduce -- a great deal of duplication by making HasAnnotatedType a parametrised type -- class. -- TODO(jml): Be smarter and figure out how to say "all integral types" rather -- than listing each individually. instance HasAnnotatedType Int where getAnnotatedType = builtinType Schema.GInt instance HasAnnotatedType Int32 where getAnnotatedType = builtinType Schema.GInt instance HasAnnotatedType Bool where getAnnotatedType = builtinType Schema.GBool instance HasAnnotatedType Text where getAnnotatedType = builtinType Schema.GString instance HasAnnotatedType Double where getAnnotatedType = builtinType Schema.GFloat instance HasAnnotatedType Float where getAnnotatedType = builtinType Schema.GFloat instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where getAnnotatedType = Schema.TypeList . Schema.ListType <$> getAnnotatedType @t instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedType (Enum ks enum) where getAnnotatedType = do let name = nameFromSymbol @ks let enums = sequenceA (enumValues @enum) :: Either NameError [Schema.Name] let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) (first NameError enums) Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedType . Schema.TypeDefinitionEnum <$> et instance forall ks as. (KnownSymbol ks, HasUnionTypeObjectTypeDefinitions as) => HasAnnotatedType (Union ks as) where getAnnotatedType = let name = nameFromSymbol @ks types = getUnionTypeObjectTypeDefinitions @as in (Schema.TypeNamed . Schema.DefinedType . Schema.TypeDefinitionUnion) <$> (Schema.UnionTypeDefinition <$> name <*> types) -- Help users with better type errors instance TypeError ('Text "Cannot encode Integer because it has arbitrary size but the JSON encoding is a number") => HasAnnotatedType Integer where getAnnotatedType = panic "Cannot encode Integer into JSON due to its arbitrary size. Should get a compile-time error instead of this." -- Builtin input types class HasAnnotatedInputType a where -- See TODO comment in "HasAnnotatedType" class for nullability. getAnnotatedInputType :: Either SchemaError (Schema.AnnotatedType Schema.InputType) default getAnnotatedInputType :: (Generic a, GenericAnnotatedInputType (Rep a)) => Either SchemaError (Schema.AnnotatedType Schema.InputType) getAnnotatedInputType = genericGetAnnotatedInputType @(Rep a) instance forall a. HasAnnotatedInputType a => HasAnnotatedInputType (Maybe a) where getAnnotatedInputType = dropNonNull <$> getAnnotatedInputType @a builtinInputType :: Schema.Builtin -> Either SchemaError (Schema.AnnotatedType Schema.InputType) builtinInputType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinInputType instance HasAnnotatedInputType Int where getAnnotatedInputType = builtinInputType Schema.GInt instance HasAnnotatedInputType Int32 where getAnnotatedInputType = builtinInputType Schema.GInt instance HasAnnotatedInputType Bool where getAnnotatedInputType = builtinInputType Schema.GBool instance HasAnnotatedInputType Text where getAnnotatedInputType = builtinInputType Schema.GString instance HasAnnotatedInputType Double where getAnnotatedInputType = builtinInputType Schema.GFloat instance HasAnnotatedInputType Float where getAnnotatedInputType = builtinInputType Schema.GFloat instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where getAnnotatedInputType = Schema.TypeList . Schema.ListType <$> getAnnotatedInputType @t instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedInputType (Enum ks enum) where getAnnotatedInputType = do let name = nameFromSymbol @ks enums = sequenceA (enumValues @enum) :: Either NameError [Schema.Name] let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) (first NameError enums) Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedInputType . Schema.InputTypeDefinitionEnum <$> et -- Generic getAnnotatedInputType function class GenericAnnotatedInputType (f :: Type -> Type) where genericGetAnnotatedInputType :: Either SchemaError (Schema.AnnotatedType Schema.InputType) class GenericInputObjectFieldDefinitions (f :: Type -> Type) where genericGetInputObjectFieldDefinitions :: Either SchemaError (NonEmpty Schema.InputObjectFieldDefinition) instance forall dataName consName records s l p. ( KnownSymbol dataName , KnownSymbol consName , GenericInputObjectFieldDefinitions records ) => GenericAnnotatedInputType (D1 ('MetaData dataName s l 'False) (C1 ('MetaCons consName p 'True) records )) where genericGetAnnotatedInputType = do name <- nameFromSymbol @dataName map ( Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedInputType . Schema.InputTypeDefinitionObject . Schema.InputObjectTypeDefinition name ) (genericGetInputObjectFieldDefinitions @records) instance forall a b. ( GenericInputObjectFieldDefinitions a , GenericInputObjectFieldDefinitions b ) => GenericInputObjectFieldDefinitions (a :*: b) where genericGetInputObjectFieldDefinitions = do l <- genericGetInputObjectFieldDefinitions @a r <- genericGetInputObjectFieldDefinitions @b pure (l S.<> r) instance forall wrappedType fieldName u s l. ( KnownSymbol fieldName , HasAnnotatedInputType wrappedType ) => GenericInputObjectFieldDefinitions (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where genericGetInputObjectFieldDefinitions = do name <- nameFromSymbol @fieldName annotatedInputType <- getAnnotatedInputType @wrappedType let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing pure (l :| []) ================================================ FILE: src/GraphQL/Internal/Arbitrary.hs ================================================ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: QuickCheck instances to help with testing module GraphQL.Internal.Arbitrary ( arbitraryText , arbitraryNonEmpty ) where import Protolude import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) import qualified Data.String import Test.QuickCheck (Gen, Arbitrary(..), arbitrary, listOf1) -- | Generate arbitrary 'Text'. arbitraryText :: Gen Text arbitraryText = toS <$> arbitrary @Data.String.String -- | Generate an arbitrary 'NonEmpty' list. arbitraryNonEmpty :: forall a. Arbitrary a => Gen (NonEmpty a) arbitraryNonEmpty = -- NonEmpty.fromList panics, but that's OK, because listOf1 is guaranteed to -- return a non-empty list, and because a panic in a test is highly -- informative and indicative of a bug. NonEmpty.fromList <$> listOf1 arbitrary ================================================ FILE: src/GraphQL/Internal/Execution.hs ================================================ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Implement the \"Execution\" part of the GraphQL spec. -- -- Actually, most of the execution work takes place in 'GraphQL.Resolver', but -- there's still a fair bit required to glue together the results of -- 'GraphQL.Internal.Validation' and the processing in 'GraphQL.Resolver'. -- This module provides that glue. module GraphQL.Internal.Execution ( VariableValues , ExecutionError(..) , formatError , getOperation , substituteVariables ) where import Protolude import qualified Data.Map as Map import GraphQL.Value ( Name , Value , pattern ValueNull , Value'(..) , List'(..) , Object'(..) ) import GraphQL.Internal.Output (GraphQLError(..)) import GraphQL.Internal.Schema ( AnnotatedType (TypeNonNull) ) import GraphQL.Internal.Validation ( Operation , QueryDocument(..) , VariableDefinition(..) , VariableValue , Variable ) -- | Get an operation from a GraphQL document -- -- -- -- GetOperation(document, operationName): -- -- * If {operationName} is {null}: -- * If {document} contains exactly one operation. -- * Return the Operation contained in the {document}. -- * Otherwise produce a query error requiring {operationName}. -- * Otherwise: -- * Let {operation} be the Operation named {operationName} in {document}. -- * If {operation} was not found, produce a query error. -- * Return {operation}. getOperation :: QueryDocument value -> Maybe Name -> Either ExecutionError (Operation value) getOperation (LoneAnonymousOperation op) Nothing = pure op getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup (pure name) ops) getOperation (MultipleOperations ops) Nothing = case toList ops of [op] -> pure op _ -> throwError NoAnonymousOperation getOperation _ (Just name) = throwError (NoSuchOperation name) -- | Substitute variables in a GraphQL document. -- -- Once this is done, there will be no variables in the document whatsoever. substituteVariables :: Operation VariableValue -> VariableValues -> Either ExecutionError (Operation Value) substituteVariables op vars = traverse (replaceVariable vars) op replaceVariable :: VariableValues -> VariableValue -> Either ExecutionError Value replaceVariable vars value = case value of ValueScalar' (Left defn) -> getValue defn ValueScalar' (Right v) -> pure (ValueScalar' v) ValueList' (List' xs) -> ValueList' . List' <$> traverse (replaceVariable vars) xs ValueObject' (Object' xs) -> ValueObject' . Object' <$> traverse (replaceVariable vars) xs where getValue :: VariableDefinition -> Either ExecutionError Value getValue (VariableDefinition variableName variableType defaultValue) = note (MissingValue variableName) $ Map.lookup variableName vars <|> defaultValue <|> allowNull variableType allowNull (TypeNonNull _) = empty allowNull _ = pure ValueNull -- | An error that occurs while executing a query. Technically, -- 'ResolverError' also falls into the same category, but is separate to help -- our code be a bit better organized. data ExecutionError = MissingValue Variable | NoSuchOperation Name | NoAnonymousOperation deriving (Eq, Show) instance GraphQLError ExecutionError where formatError (MissingValue name) = "Missing value for " <> show name <> " and must be non-null." formatError (NoSuchOperation name) = "Requested operation " <> show name <> " but couldn't find it." formatError NoAnonymousOperation = "No name supplied for opertaion, but no anonymous operation." -- | A map of variables to their values. -- -- In GraphQL the variable values are not part of the query itself, they are -- instead passed in through a separate channel. Create a 'VariableValues' -- from this other channel and pass it to 'substituteVariables'. -- -- GraphQL allows the values of variables to be specified, but doesn't provide -- a way for doing so in the language. type VariableValues = Map Variable Value ================================================ FILE: src/GraphQL/Internal/Name.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Representation of GraphQL names. module GraphQL.Internal.Name ( Name(unName, Name) , NameError(..) , makeName , nameFromSymbol , nameParser -- * Named things , HasName(..) -- * Unsafe functions , unsafeMakeName ) where import Protolude import qualified Data.Aeson as Aeson import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Data.Char (isDigit) import Data.Text as T (Text) import qualified Data.Attoparsec.Text as A import Test.QuickCheck (Arbitrary(..), elements, listOf) import Data.String (IsString(..)) import GraphQL.Internal.Syntax.Tokens (tok) -- * Name -- | A name in GraphQL. -- -- https://facebook.github.io/graphql/#sec-Names newtype Name = Name { unName :: T.Text } deriving (Eq, Ord, Show) -- | Create a 'Name', panicking if the given text is invalid. -- -- Prefer 'makeName' to this in all cases. -- -- >>> unsafeMakeName "foo" -- Name {unName = "foo"} unsafeMakeName :: HasCallStack => Text -> Name unsafeMakeName name = case makeName name of Left e -> panic (show e) Right n -> n -- | Create a 'Name'. -- -- Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does -- not match, return NameError. -- -- >>> makeName "foo" -- Right (Name {unName = "foo"}) -- >>> makeName "9-bar" -- Left (NameError "9-bar") makeName :: Text -> Either NameError Name makeName name = first (const (NameError name)) (A.parseOnly nameParser name) -- | Parser for 'Name'. nameParser :: A.Parser Name nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z <*> A.takeWhile ((||) <$> isDigit <*> isA_z)) where -- `isAlpha` handles many more Unicode Chars isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z'] -- | An invalid name. newtype NameError = NameError Text deriving (Eq, Show) -- | Convert a type-level 'Symbol' into a GraphQL 'Name'. nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either NameError Name nameFromSymbol = makeName (toS (symbolVal @n Proxy)) -- | Types that implement this have values with a single canonical name in a -- GraphQL schema. -- -- e.g. a field @foo(bar: Int32)@ would have the name @\"foo\"@. -- -- If a thing *might* have a name, or has a name that might not be valid, -- don't use this. -- -- If a thing is aliased, then return the *original* name. class HasName a where -- | Get the name of the object. getName :: a -> Name instance IsString Name where fromString = unsafeMakeName . toS instance Aeson.ToJSON Name where toJSON = Aeson.toJSON . unName instance Arbitrary Name where arbitrary = do initial <- elements alpha rest <- listOf (elements (alpha <> numeric)) pure (Name (toS (initial:rest))) where alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_'] numeric = ['0'..'9'] ================================================ FILE: src/GraphQL/Internal/OrderedMap.hs ================================================ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Data structure for mapping keys to values while preserving order of appearance -- -- There are many cases in GraphQL where we want to have a map from names to -- values, where values can easily be lookup up by name and name is unique. -- This would normally be modelled as a 'Map'. However, in many of these -- cases, the order in which the entries appear matters. -- -- That is, -- -- @ -- { -- 'foo': 1, -- 'bar': 2 -- } -- @ -- -- Is different to, -- -- @ -- { -- 'bar': 2, -- 'foo': 1, -- } -- -- Even though they have exactly the same keys, and the keys have exactly the -- same values. -- -- Goal for this module is to provide data structures that are "complete -- enough" for implementing the rest of GraphQL. module GraphQL.Internal.OrderedMap ( OrderedMap -- * Construction , empty , singleton , orderedMap -- * Querying , lookup -- * Filtering , GraphQL.Internal.OrderedMap.catMaybes -- * Combine -- ** Union , unions , unionWith , unionsWith , unionWithM , unionsWithM -- * Conversion , toList , toMap , keys , values -- * Properties , genOrderedMap ) where import Protolude hiding (empty, toList) import qualified Data.Map as Map import Test.QuickCheck (Arbitrary(..), Gen, listOf) data OrderedMap key value = OrderedMap { -- | Get the list of keys from an ordered map, in order of appearance. -- -- This list is guaranteed to have no duplicates. keys :: [key] -- | Convert an ordered map to a regular map, losing insertion order. , toMap :: Map key value } deriving (Eq, Ord, Show) -- | Convert an ordered map to a list of keys and values. The list is -- guaranteed to be the same order as the order of insertion into the map. -- -- /O(n log n)/ toList :: forall key value. Ord key => OrderedMap key value -> [(key, value)] toList (OrderedMap keys entries) = Protolude.catMaybes (foreach keys $ \k -> (,) k <$> Map.lookup k entries) instance Foldable (OrderedMap key) where foldr f z (OrderedMap _ entries) = foldr f z entries instance Traversable (OrderedMap key) where traverse f (OrderedMap keys entries) = OrderedMap keys <$> traverse f entries instance Functor (OrderedMap key) where fmap f (OrderedMap keys entries) = OrderedMap keys (map f entries) instance (Arbitrary key, Arbitrary value, Ord key) => Arbitrary (OrderedMap key value) where arbitrary = genOrderedMap arbitrary arbitrary -- | Generate an ordered map with the given key & value generators. genOrderedMap :: forall key value. Ord key => Gen key -> Gen value -> Gen (OrderedMap key value) genOrderedMap genKey genValue = do entries <- Map.fromList <$> (zip <$> listOf genKey <*> listOf genValue) pure (OrderedMap (Map.keys entries) entries) -- | The empty OrderedMap. /O(1)/ empty :: forall key value. OrderedMap key value empty = OrderedMap [] Map.empty -- | Create an ordered map containing a single entry. /O(1)/ singleton :: forall key value. key -> value -> OrderedMap key value singleton key value = OrderedMap [key] (Map.singleton key value) -- | Find a value in an ordered map. -- -- /O(log n)/ lookup :: forall key value. Ord key => key -> OrderedMap key value -> Maybe value lookup key (OrderedMap _ entries) = Map.lookup key entries -- | Get the values from an ordered map, in order of appearance. /O(n log n)/ values :: forall key value. Ord key => OrderedMap key value -> [value] values = map snd . toList -- | The union of a list of ordered maps. -- -- If any map shares a key with any other map, return 'Nothing'. -- -- Otherwise, return a new map containing all of the keys from all of the -- maps. The keys from the first map will appear first, followed by the -- second, and so forth. -- -- /O(m * n log (m * n))/ where /m/ is the number of maps, and /n/ is the size of -- the largest map. unions :: forall key value. Ord key => [OrderedMap key value] -> Maybe (OrderedMap key value) unions orderedMaps = orderedMap (orderedMaps >>= toList) -- | Append the second ordered map to the first, combining any shared elements -- with the given function. unionWith :: Ord key => (value -> value -> value) -> OrderedMap key value -> OrderedMap key value -> OrderedMap key value unionWith f x y = OrderedMap { toMap = Map.unionWith f (toMap x) (toMap y) , keys = keys x <> [k | k <- keys y, k `Map.notMember` toMap x] } -- | Append together a list of ordered maps, preserving ordering of keys. -- Combine any shared elements with the given function. unionsWith :: Ord key => (value -> value -> value) -> [OrderedMap key value] -> OrderedMap key value unionsWith f = foldl' (unionWith f) empty -- | Take two ordered maps, append the second one to the first. If the second -- contains any keys that also appear in the first, combine the two values -- with the given function. unionWithM :: (Monad m, Ord key) => (value -> value -> m value) -> OrderedMap key value -> OrderedMap key value -> m (OrderedMap key value) unionWithM f x y = sequenceA (unionWith (liftMM f) (map pure x) (map pure y)) -- | Take a list of ordered maps and append them together. Any shared elements -- are combined using the given function. unionsWithM :: (Monad m, Ord key) => (value -> value -> m value) -> [OrderedMap key value] -> m (OrderedMap key value) unionsWithM f xs = sequenceA (unionsWith (liftMM f) (map (map pure) xs)) liftMM :: Monad m => (a -> b -> m c) -> m a -> m b -> m c liftMM f a' b' = do (a, b) <- (,) <$> a' <*> b' f a b -- | Take an ordered map with 'Maybe' values and return the same map with all -- the 'Nothing' values removed. catMaybes :: Ord key => OrderedMap key (Maybe value) -> OrderedMap key value catMaybes xs = OrderedMap { keys = [ k | k <- keys xs, k `Map.member` newMap ] , toMap = newMap } where newMap = Map.mapMaybe identity (toMap xs) -- | Construct an ordered map from a list. -- -- /O(n log n)/. -- -- If the list contains duplicate keys, then return 'Nothing'. Otherwise, -- return an 'OrderedMap', preserving the order. orderedMap :: forall key value. Ord key => [(key, value)] -> Maybe (OrderedMap key value) orderedMap entries | ks == ordNub ks = Just (OrderedMap ks (Map.fromList entries)) | otherwise = Nothing where ks = map fst entries ================================================ FILE: src/GraphQL/Internal/Output.hs ================================================ {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: How we encode GraphQL responses module GraphQL.Internal.Output ( Response(..) , Errors , Error(..) , GraphQLError(..) , singleError ) where import Protolude hiding (Location, Map) import Data.Aeson (ToJSON(..)) import Data.List.NonEmpty (NonEmpty(..)) import GraphQL.Value ( Object , objectFromList , Value , pattern ValueObject , pattern ValueNull , NameError(..) , ToValue(..) ) import GraphQL.Internal.Name (Name) -- | GraphQL response. -- -- A GraphQL response must: -- -- * be a map -- * have a "data" key iff the operation executed -- * have an "errors" key iff the operation encountered errors -- * not include "data" if operation failed before execution (e.g. syntax errors, -- validation errors, missing info) -- * not have keys other than "data", "errors", and "extensions" -- -- Other interesting things: -- -- * Doesn't have to be JSON, but does have to have maps, strings, lists, -- and null -- * Can also support bool, int, enum, and float -- * Value of "extensions" must be a map -- -- "data" must be null if an error was encountered during execution that -- prevented a valid response. -- -- "errors" -- -- * must be a non-empty list -- * each error is a map with "message", optionally "locations" key -- with list of locations -- * locations are maps with 1-indexed "line" and "column" keys. data Response = Success Object | PreExecutionFailure Errors | ExecutionFailure Errors | PartialSuccess Object Errors deriving (Eq, Ord, Show) -- | Construct an object from a list of names and values. -- -- Panic if there are duplicate names. unsafeMakeObject :: HasCallStack => [(Name, Value)] -> Value unsafeMakeObject fields = case objectFromList fields of Nothing -> panic $ "Object has duplicate keys: " <> show fields Just object -> ValueObject object instance ToValue Response where toValue (Success x) = unsafeMakeObject [("data", toValue x)] toValue (PreExecutionFailure e) = unsafeMakeObject [("errors", toValue e)] toValue (ExecutionFailure e) = unsafeMakeObject [("data", ValueNull) ,("errors", toValue e)] toValue (PartialSuccess x e) = unsafeMakeObject [("data", toValue x) ,("errors", toValue e) ] instance ToJSON Response where toJSON = toJSON . toValue type Errors = NonEmpty Error data Error = Error Text [Location] deriving (Eq, Ord, Show) instance ToValue Error where toValue (Error message []) = unsafeMakeObject [("message", toValue message)] toValue (Error message locations) = unsafeMakeObject [("message", toValue message) ,("locations", toValue locations) ] -- | Make a list of errors containing a single error. singleError :: GraphQLError e => e -> Errors singleError e = toError e :| [] data Location = Location Line Column deriving (Eq, Ord, Show) type Line = Int32 -- XXX: 1-indexed natural number type Column = Int32 -- XXX: 1-indexed natural number instance ToValue Location where toValue (Location line column) = unsafeMakeObject [("line" , toValue line) ,("column", toValue column) ] -- | An error that arises while processing a GraphQL query. class GraphQLError e where -- | Represent an error as human-readable text, primarily intended for -- developers of GraphQL clients, and secondarily for developers of GraphQL -- servers. formatError :: e -> Text -- | Represent an error as human-readable text, together with reference to a -- series of locations within a GraphQL query document. Default -- implementation calls 'formatError' and provides no locations. toError :: e -> Error toError e = Error (formatError e) [] -- Defined here to avoid circular dependency. instance GraphQLError NameError where formatError (NameError name) = "Not a valid GraphQL name: " <> show name ================================================ FILE: src/GraphQL/Internal/Resolver.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} -- nicer type errors in some cases {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- for TypeError {-# OPTIONS_HADDOCK not-home #-} -- | Description: Implement handlers for GraphQL schemas module GraphQL.Internal.Resolver ( ResolverError(..) , HasResolver(..) , OperationResolverConstraint , (:<>)(..) , Result(..) , unionValue , resolveOperation , returns , handlerError ) where -- TODO (probably incomplete, the spec is large) -- - input objects - I'm not super clear from the spec on how -- they differ from normal objects. -- - "extend type X" is used in examples in the spec but it's not -- explained anywhere? -- - Directives (https://facebook.github.io/graphql/#sec-Type-System.Directives) -- - Enforce non-empty lists (might only be doable via value-level validation) import Protolude hiding (Enum, TypeError, throwE) import qualified Data.Text as Text import qualified Data.List.NonEmpty as NonEmpty import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..), Symbol, symbolVal) import GHC.Types (Type) import qualified GHC.Exts (Any) import Unsafe.Coerce (unsafeCoerce) import GraphQL.Internal.API ( HasAnnotatedType(..) , HasAnnotatedInputType(..) , (:>) ) import qualified GraphQL.Internal.API as API import qualified GraphQL.Value as GValue import GraphQL.Value ( Value , pattern ValueEnum , FromValue(..) , ToValue(..) ) import GraphQL.Internal.Name (Name, HasName(..)) import qualified GraphQL.Internal.OrderedMap as OrderedMap import GraphQL.Internal.Output (GraphQLError(..)) import GraphQL.Internal.Validation ( SelectionSetByType , SelectionSet(..) , Field , ValidationErrors , getSubSelectionSet , getSelectionSetForType , lookupArgument ) data ResolverError -- | There was a problem in the schema. Server-side problem. = SchemaError API.SchemaError -- | Couldn't find the requested field in the object. A client-side problem. | FieldNotFoundError Name -- | No value provided for name, and no default specified. Client-side problem. | ValueMissing Name -- | Could not translate value into Haskell. Probably a client-side problem. | InvalidValue Name Text -- | Found validation errors when we tried to merge fields. | ValidationError ValidationErrors -- | Tried to get subselection of leaf field. | SubSelectionOnLeaf (SelectionSetByType Value) -- | Tried to treat an object as a leaf. | MissingSelectionSet -- | Error from handler | HandlerError Text deriving (Show, Eq) instance GraphQLError ResolverError where formatError (SchemaError e) = "Schema error: " <> formatError e formatError (FieldNotFoundError field) = "Field not supported by the API: " <> show field formatError (ValueMissing name) = "No value provided for " <> show name <> ", and no default specified." formatError (InvalidValue name text) = "Could not coerce " <> show name <> " to valid value: " <> text formatError (ValidationError errs) = "Validation errors: " <> Text.intercalate ", " (map formatError (NonEmpty.toList errs)) formatError (SubSelectionOnLeaf ss) = "Tried to get values within leaf field: " <> show ss formatError MissingSelectionSet = "Tried to treat object as if it were leaf field." formatError (HandlerError err) = "Handler error: " <> err -- | Object field separation operator. -- -- Use this to provide handlers for fields of an object. -- -- Say you had the following GraphQL type with \"foo\" and \"bar\" fields, -- e.g. -- -- @ -- type MyObject { -- foo: Int! -- bar: String! -- } -- @ -- -- You could provide handlers for it like this: -- -- >>> :m +System.Environment -- >>> let fooHandler = pure 42 -- >>> let barHandler = System.Environment.getProgName -- >>> let myObjectHandler = pure $ fooHandler :<> barHandler :<> () data a :<> b = a :<> b infixr 8 :<> -- Result collects errors and values at the same time unless a handler -- tells us to bail out in which case we stop the processing -- immediately. data Result a = Result [ResolverError] a deriving (Show, Functor, Eq) -- Aggregating results keeps all errors and creates a ValueList -- containing the individual values. aggregateResults :: [Result Value] -> Result Value aggregateResults r = toValue <$> sequenceA r throwE :: Applicative f => ResolverError -> f (Result Value) throwE err = pure (Result [err] GValue.ValueNull) instance Applicative Result where pure v = Result [] v (Result e1 f) <*> (Result e2 x) = Result (e1 <> e2) (f x) ok :: Value -> Result Value ok = pure -- | The result of a handler is either text errors generated by the -- handler or a value. type HandlerResult a = Either Text a -- | `returns` is a convenience function for a Handler that is -- returning the expected value. returns :: Applicative f => a -> f (HandlerResult a) returns = pure . Right -- | `handlerError` is a convenience function for a Handler that has -- encountered an error and is unable to return the expected value. handlerError :: Applicative f => Text -> f (HandlerResult a) handlerError = pure . Left class HasResolver m a where type Handler m a resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value) type OperationResolverConstraint m fields typeName interfaces = ( RunFields m (RunFieldsType m fields) , API.HasObjectDefinition (API.Object typeName interfaces fields) , Monad m ) resolveOperation :: forall m fields typeName interfaces. ( OperationResolverConstraint m fields typeName interfaces ) => Handler m (API.Object typeName interfaces fields) -> SelectionSetByType Value -> m (Result GValue.Object) resolveOperation handler ss = resolveObject @m @fields @typeName @interfaces handler ss -- | Called when the schema expects an input argument @name@ of type @a@ but -- @name@ has not been provided. valueMissing :: API.Defaultable a => Name -> Either ResolverError a valueMissing name = maybe (Left (ValueMissing name)) Right (API.defaultFor name) gotHandlerErr :: Text -> Result Value gotHandlerErr err = Result [HandlerError err] GValue.ValueNull handlerResult :: (Applicative f, ToValue a) => f (HandlerResult a) -> f (Result Value) handlerResult = fmap (either gotHandlerErr (ok . toValue)) instance forall m. (Applicative m) => HasResolver m Int32 where type Handler m Int32 = m (HandlerResult Int32) resolve handler Nothing = handlerResult @m handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m. (Applicative m) => HasResolver m Double where type Handler m Double = m (HandlerResult Double) resolve handler Nothing = handlerResult handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m. (Applicative m) => HasResolver m Text where type Handler m Text = m (HandlerResult Text) resolve handler Nothing = handlerResult handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m. (Applicative m) => HasResolver m Bool where type Handler m Bool = m (HandlerResult Bool) resolve handler Nothing = handlerResult handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver m (API.List hg) where type Handler m (API.List hg) = m (HandlerResult [Handler m hg]) resolve handler selectionSet = do handler >>= \case Right h -> let a = traverse (flip (resolve @m @hg) selectionSet) h in map aggregateResults a Left err -> pure $ gotHandlerErr err instance forall m ksN enum. (Applicative m, API.GraphQLEnum enum) => HasResolver m (API.Enum ksN enum) where type Handler m (API.Enum ksN enum) = m (HandlerResult enum) resolve handler Nothing = either gotHandlerErr (ok . GValue.ValueEnum . API.enumToValue) <$> handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m hg. (HasResolver m hg, Monad m) => HasResolver m (Maybe hg) where type Handler m (Maybe hg) = m (HandlerResult (Maybe (Handler m hg))) resolve handler selectionSet = do result <- handler case result of Right res -> case res of Just x -> resolve @m @hg (x :: Handler m hg) selectionSet Nothing -> (pure . ok) GValue.ValueNull Left err -> pure $ gotHandlerErr err -- TODO: A parametrized `Result` is really not a good way to handle the -- "result" for resolveField, but not sure what to use either. Tom liked the -- tuple we had before more because it didn't imply any other structure or -- meaning. Maybe we can just create a new datatype. jml thinks we should -- extract some helpful generic monad, ala `Validator`. -- type ResolveFieldResult = Result (Maybe GValue.Value) -- Extract field name from an argument type. TODO: ideally we'd run -- this directly on the "a :> b" argument structure, but that requires -- passing in the plain argument structure type into resolveField or -- resolving "name" in the buildFieldResolver. Both options duplicate -- code somwehere else. type family FieldName (a :: Type) = (r :: Symbol) where FieldName (JustHandler (API.Field name t)) = name FieldName (PlainArgument a f) = FieldName f FieldName (EnumArgument a f) = FieldName f FieldName x = TypeError ('Text "Unexpected branch in FieldName type family. Please file a bug!" ':<>: 'ShowType x) resolveField :: forall dispatchType (m :: Type -> Type). (BuildFieldResolver m dispatchType, Monad m, KnownSymbol (FieldName dispatchType)) => FieldHandler m dispatchType -> m ResolveFieldResult -> Field Value -> m ResolveFieldResult resolveField handler nextHandler field = -- check name before case API.nameFromSymbol @(FieldName dispatchType) of Left err -> pure (Result [SchemaError err] (Just GValue.ValueNull)) Right name' | getName field == name' -> case buildFieldResolver @m @dispatchType handler field of Left err -> pure (Result [err] (Just GValue.ValueNull)) Right resolver -> do Result errs value <- resolver pure (Result errs (Just value)) | otherwise -> nextHandler -- We're using our usual trick of rewriting a type in a closed type -- family to emulate a closed typeclass. The following are the -- universe of "allowed" class instances for field types: data JustHandler a data EnumArgument a b data PlainArgument a b -- injective helps with errors sometimes type family FieldResolverDispatchType (a :: Type) = (r :: Type) | r -> a where FieldResolverDispatchType (API.Field ksA t) = JustHandler (API.Field ksA t) FieldResolverDispatchType (API.Argument ksB (API.Enum name t) :> f) = EnumArgument (API.Argument ksB (API.Enum name t)) (FieldResolverDispatchType f) FieldResolverDispatchType (API.Argument ksC t :> f) = PlainArgument (API.Argument ksC t) (FieldResolverDispatchType f) -- | Derive the handler type from the Field/Argument type in a closed -- type family: We don't want anyone else to extend this ever. type family FieldHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where FieldHandler m (JustHandler (API.Field ksD t)) = Handler m t FieldHandler m (PlainArgument (API.Argument ksE t) f) = t -> FieldHandler m f FieldHandler m (EnumArgument (API.Argument ksF (API.Enum name t)) f) = t -> FieldHandler m f class BuildFieldResolver m fieldResolverType where buildFieldResolver :: FieldHandler m fieldResolverType -> Field Value -> Either ResolverError (m (Result Value)) instance forall ksG t m. ( KnownSymbol ksG, HasResolver m t, HasAnnotatedType t, Monad m ) => BuildFieldResolver m (JustHandler (API.Field ksG t)) where buildFieldResolver handler field = do pure (resolve @m @t handler (getSubSelectionSet field)) instance forall ksH t f m. ( KnownSymbol ksH , BuildFieldResolver m f , FromValue t , API.Defaultable t , HasAnnotatedInputType t , Monad m ) => BuildFieldResolver m (PlainArgument (API.Argument ksH t) f) where buildFieldResolver handler field = do argument <- first SchemaError (API.getArgumentDefinition @(API.Argument ksH t)) let argName = getName argument value <- case lookupArgument field argName of Nothing -> valueMissing @t argName Just v -> first (InvalidValue argName) (fromValue @t v) buildFieldResolver @m @f (handler value) field instance forall ksK t f m name. ( KnownSymbol ksK , BuildFieldResolver m f , KnownSymbol name , API.Defaultable t , API.GraphQLEnum t , Monad m ) => BuildFieldResolver m (EnumArgument (API.Argument ksK (API.Enum name t)) f) where buildFieldResolver handler field = do argName <- first SchemaError (API.nameFromSymbol @ksK) value <- case lookupArgument field argName of Nothing -> valueMissing @t argName Just (ValueEnum enum) -> first (InvalidValue argName) (API.enumFromValue @t enum) Just value -> Left (InvalidValue argName (show value <> " not an enum: " <> show (API.enumValues @t))) buildFieldResolver @m @f (handler value) field -- Note that we enumerate all ks variables with capital letters so we -- can figure out error messages like the following that don't come -- with line numbers: -- -- • No instance for (GHC.TypeLits.KnownSymbol ks0) -- arising from a use of ‘interpretAnonymousQuery’ -- We only allow Field and Argument :> Field combinations: type family RunFieldsType (m :: Type -> Type) (a :: [Type]) = (r :: Type) where RunFieldsType m '[API.Field ksI t] = API.Field ksI t RunFieldsType m '[a :> b] = a :> b RunFieldsType m ((API.Field ksJ t) ': rest) = API.Field ksJ t :<> RunFieldsType m rest RunFieldsType m ((a :> b) ': rest) = (a :> b) :<> RunFieldsType m rest RunFieldsType m a = TypeError ( 'Text "All field entries in an Object must be Field or Argument :> Field. Got: " ':<>: 'ShowType a) -- Match the three possible cases for Fields (see also RunFieldsType) type family RunFieldsHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where RunFieldsHandler m (f :<> fs) = FieldHandler m (FieldResolverDispatchType f) :<> RunFieldsHandler m fs RunFieldsHandler m (API.Field ksL t) = FieldHandler m (FieldResolverDispatchType (API.Field ksL t)) RunFieldsHandler m (a :> b) = FieldHandler m (FieldResolverDispatchType (a :> b)) RunFieldsHandler m a = TypeError ( 'Text "Unexpected RunFieldsHandler types: " ':<>: 'ShowType a) class RunFields m a where -- | Run a single 'Selection' over all possible fields (as specified by the -- type @a@), returning exactly one 'GValue.ObjectField' when a field -- matches, or an error otherwise. -- -- Individual implementations are responsible for calling 'runFields' if -- they haven't matched the field and there are still candidate fields -- within the handler. runFields :: RunFieldsHandler m a -> Field Value -> m ResolveFieldResult instance forall f fs m dispatchType. ( BuildFieldResolver m dispatchType , dispatchType ~ FieldResolverDispatchType f , RunFields m fs , KnownSymbol (FieldName dispatchType) , Monad m ) => RunFields m (f :<> fs) where runFields (handler :<> nextHandlers) field = resolveField @dispatchType @m handler nextHandler field where nextHandler = runFields @m @fs nextHandlers field instance forall ksM t m dispatchType. ( BuildFieldResolver m dispatchType , KnownSymbol ksM , dispatchType ~ FieldResolverDispatchType (API.Field ksM t) , Monad m ) => RunFields m (API.Field ksM t) where runFields handler field = resolveField @dispatchType @m handler nextHandler field where nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) instance forall m a b dispatchType. ( BuildFieldResolver m dispatchType , dispatchType ~ FieldResolverDispatchType (a :> b) , KnownSymbol (FieldName dispatchType) , Monad m ) => RunFields m (a :> b) where runFields handler field = resolveField @dispatchType @m handler nextHandler field where nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) resolveObject :: forall m fields typeName interfaces. ( OperationResolverConstraint m fields typeName interfaces ) => Handler m (API.Object typeName interfaces fields) -> SelectionSetByType Value -> m (Result GValue.Object) resolveObject mHandler selectionSet = case getSelectionSet of Left err -> return (Result [err] (GValue.Object' OrderedMap.empty)) Right ss -> do -- Run the handler so the field resolvers have access to the object. -- This (and other places, including field resolvers) is where user -- code can do things like look up something in a database. handler <- mHandler r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss let (Result errs obj) = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r pure (Result errs obj) where getSelectionSet = do defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields) -- Fields of a selection set may be behind "type conditions", due to -- inline fragments or the use of fragment spreads. These type -- conditions are represented in the schema by the name of a type -- (e.g. "Dog"). To determine which type conditions (and thus which -- fields) are relevant for this 1selection set, we need to look up the -- actual types they refer to, as interfaces (say) match objects -- differently than unions. -- -- See for -- more details. (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet pure ss' instance forall typeName interfaces fields m. ( RunFields m (RunFieldsType m fields) , API.HasObjectDefinition (API.Object typeName interfaces fields) , Monad m ) => HasResolver m (API.Object typeName interfaces fields) where type Handler m (API.Object typeName interfaces fields) = m (RunFieldsHandler m (RunFieldsType m fields)) resolve _ Nothing = throwE MissingSelectionSet resolve handler (Just ss) = do result <- resolveObject @m @fields @typeName @interfaces handler ss return $ GValue.ValueObject <$> result -- TODO(tom): we're getting to a point where it might make sense to -- split resolver into submodules (GraphQL.Resolver.Union etc.) -- | For unions we need a way to have type-safe, open sum types based -- on the possible 'API.Object's of a union. The following closed type -- family selects one Object from the union and returns the matching -- 'HasResolver' 'Handler' type. If the object @o@ is not a member of -- 'API.Union' then the user code won't compile. -- -- This type family is an implementation detail but its TypeError -- messages are visible at compile time. type family TypeIndex (m :: Type -> Type) (object :: Type) (union :: Type) = (result :: Type) where TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name interfaces fields:_)) = Handler m (API.Object name interfaces fields) TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name' i' f':objects)) = TypeIndex m (API.Object name interfaces fields) (API.Union uName objects) -- Slightly nicer type errors: TypeIndex _ (API.Object name interfaces fields) (API.Union uName '[]) = TypeError ('Text "Type not found in union definition: " ':<>: 'ShowType (API.Object name interfaces fields)) TypeIndex _ (API.Object name interfaces fields) x = TypeError ('Text "3rd type must be a union but it is: " ':<>: 'ShowType x) TypeIndex _ o _ = TypeError ('Text "Invalid TypeIndex. Must be Object but got: " ':<>: 'ShowType o) -- | The 'Handler' type of a 'API.Union' must be the same for all -- possible Objects, but each Object has a different type. We -- unsafeCoerce the return type into an Any, tagging it with the union -- and the underlying monad for type safety, but we elide the Object -- type itself. This way we can represent all 'Handler' types of the -- Union with a single type and still stay type-safe. type role DynamicUnionValue representational representational data DynamicUnionValue (union :: Type) (m :: Type -> Type) = DynamicUnionValue { _label :: Text, _value :: GHC.Exts.Any } class RunUnion m union objects where runUnion :: DynamicUnionValue union m -> SelectionSetByType Value -> m (Result Value) instance forall m union objects name interfaces fields. ( Monad m , KnownSymbol name , TypeIndex m (API.Object name interfaces fields) union ~ Handler m (API.Object name interfaces fields) , RunFields m (RunFieldsType m fields) , API.HasObjectDefinition (API.Object name interfaces fields) , RunUnion m union objects ) => RunUnion m union (API.Object name interfaces fields:objects) where runUnion duv selectionSet = case extractUnionValue @(API.Object name interfaces fields) @union @m duv of Just handler -> resolve @m @(API.Object name interfaces fields) handler (Just selectionSet) Nothing -> runUnion @m @union @objects duv selectionSet -- AFAICT it should not be possible to ever hit the empty case because -- the compiler doesn't allow constructing a unionValue that's not in -- the Union. If the following code ever gets executed it's almost -- certainly a bug in the union code. -- -- We still need to implement this instance for the compiler because -- it exhaustively checks all cases when deconstructs the Union. instance forall m union. RunUnion m union '[] where runUnion (DynamicUnionValue label _) selection = panic ("Unexpected branch in runUnion, got " <> show selection <> " for label " <> label <> ". Please file a bug.") instance forall m unionName objects. ( Monad m , KnownSymbol unionName , RunUnion m (API.Union unionName objects) objects ) => HasResolver m (API.Union unionName objects) where type Handler m (API.Union unionName objects) = m (DynamicUnionValue (API.Union unionName objects) m) resolve _ Nothing = throwE MissingSelectionSet resolve mHandler (Just selectionSet) = do duv <- mHandler runUnion @m @(API.Union unionName objects) @objects duv selectionSet symbolText :: forall ks. KnownSymbol ks => Text symbolText = toS (symbolVal @ks Proxy) -- | Translate a 'Handler' into a DynamicUnionValue type required by -- 'Union' handlers. This is dynamic, but nevertheless type-safe -- because we can only tag with types that are part of the union. -- -- Use e.g. like "unionValue @Cat" if you have an object like this: -- -- >>> type Cat = API.Object "Cat" '[] '[API.Field "name" Text] -- -- and then use `unionValue @Cat (pure (pure "Felix"))`. See -- `examples/UnionExample.hs` for more code. unionValue :: forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields. (Monad m, API.Object name interfaces fields ~ object, KnownSymbol name) => TypeIndex m object union -> m (DynamicUnionValue union m) unionValue x = -- TODO(tom) - we might want to move to Typeable `cast` for uValue -- instead of doing our own unsafeCoerce because it comes with -- additional safety guarantees: Typerep is unforgeable, while we -- can still into a bad place by matching on name only. We can't -- actually segfault this because right now we walk the list of -- objects in a union left-to-right so in case of duplicate names we -- only every see one type. That doesn't seen like a great thing to -- rely on though! -- Note that unsafeCoerce is safe because we index the type from the -- union with an 'API.Object' whose name we're storing in label. On -- the way out we check that the name is the same, and we know the -- type universe is the same because we annotated DynamicUnionValue -- with the type universe. pure (DynamicUnionValue (symbolText @name) (unsafeCoerce x)) extractUnionValue :: forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields. (API.Object name interfaces fields ~ object, KnownSymbol name) => DynamicUnionValue union m -> Maybe (TypeIndex m object union) extractUnionValue (DynamicUnionValue uName uValue) = if uName == symbolText @name then Just (unsafeCoerce uValue) else Nothing ================================================ FILE: src/GraphQL/Internal/Schema.hs ================================================ {-# OPTIONS_HADDOCK not-home #-} -- | Description: Fully realized GraphQL schema type system at the Haskell value level -- -- Differs from "Data.GraphQL.AST" in the -- [graphql](http://hackage.haskell.org/package/graphql) package in that there -- are no type references. Instead, everything is inlined. -- -- Equivalent representation of GraphQL /values/ is in "GraphQL.Value". module GraphQL.Internal.Schema ( GType(..) -- * Builtin types , Builtin(..) -- * Defining new types , TypeDefinition(..) , Name , ArgumentDefinition(..) , EnumValueDefinition(..) , EnumTypeDefinition(..) , FieldDefinition(..) , Interfaces , InterfaceTypeDefinition(..) , ObjectTypeDefinition(..) , UnionTypeDefinition(..) , ScalarTypeDefinition(..) -- ** Input types , InputType(..) , InputTypeDefinition(..) , InputObjectTypeDefinition(..) , InputObjectFieldDefinition(..) -- * Using existing types , AnnotatedType(..) , ListType(..) , NonNullType(..) , DefinesTypes(..) , doesFragmentTypeApply , getInputTypeDefinition , builtinFromName , astAnnotationToSchemaAnnotation -- * The schema , Schema , makeSchema , emptySchema , lookupType ) where import Protolude import qualified Data.Map as Map import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Value (Value) import GraphQL.Internal.Name (HasName(..), Name) -- | An entire GraphQL schema. -- -- This is very much a work in progress. Currently, the only thing we provide -- is a dictionary mapping type names to their definitions. newtype Schema = Schema (Map Name TypeDefinition) deriving (Eq, Ord, Show) -- | Create a schema from the root object. -- -- This is technically an insufficient API, since not all types in a schema -- need to be reachable from a single root object. However, it's a start. makeSchema :: ObjectTypeDefinition -> Schema makeSchema = Schema . getDefinedTypes -- | Create an empty schema for testing purpose. -- emptySchema :: Schema emptySchema = Schema (Map.empty :: (Map Name TypeDefinition)) -- | Find the type with the given name in the schema. lookupType :: Schema -> Name -> Maybe TypeDefinition lookupType (Schema schema) name = Map.lookup name schema -- | A thing that defines types. Excludes definitions of input types. class DefinesTypes t where -- | Get the types defined by @t@ -- -- TODO: This ignores whether a value can define multiple types with the -- same name, and further admits the possibility that the name embedded in -- the type definition does not match the name in the returned dictionary. -- jml would like to have a schema validation phase that eliminates one or -- both of these possibilities. -- -- Also pretty much works because we've inlined all our type definitions. getDefinedTypes :: t -> Map Name TypeDefinition data AnnotatedType t = TypeNamed t | TypeList (ListType t) | TypeNonNull (NonNullType t) deriving (Eq, Ord, Show) -- | Get the type that is being annotated. getAnnotatedType :: AnnotatedType t -> t getAnnotatedType (TypeNamed t) = t getAnnotatedType (TypeList (ListType t)) = getAnnotatedType t getAnnotatedType (TypeNonNull (NonNullTypeNamed t)) = t getAnnotatedType (TypeNonNull (NonNullTypeList (ListType t))) = getAnnotatedType t instance HasName t => HasName (AnnotatedType t) where getName = getName . getAnnotatedType newtype ListType t = ListType (AnnotatedType t) deriving (Eq, Ord, Show) data NonNullType t = NonNullTypeNamed t | NonNullTypeList (ListType t) deriving (Eq, Ord, Show) data GType = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Ord, Show) instance DefinesTypes GType where getDefinedTypes (BuiltinType _) = mempty getDefinedTypes (DefinedType t) = getDefinedTypes t instance HasName GType where getName (DefinedType x) = getName x getName (BuiltinType x) = getName x data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition | TypeDefinitionInterface InterfaceTypeDefinition | TypeDefinitionUnion UnionTypeDefinition | TypeDefinitionScalar ScalarTypeDefinition | TypeDefinitionEnum EnumTypeDefinition | TypeDefinitionInputObject InputObjectTypeDefinition | TypeDefinitionTypeExtension TypeExtensionDefinition deriving (Eq, Ord, Show) instance HasName TypeDefinition where getName (TypeDefinitionObject x) = getName x getName (TypeDefinitionInterface x) = getName x getName (TypeDefinitionUnion x) = getName x getName (TypeDefinitionScalar x) = getName x getName (TypeDefinitionEnum x) = getName x getName (TypeDefinitionInputObject x) = getName x getName (TypeDefinitionTypeExtension x) = getName x instance DefinesTypes TypeDefinition where getDefinedTypes defn = case defn of TypeDefinitionObject x -> getDefinedTypes x TypeDefinitionInterface x -> getDefinedTypes x TypeDefinitionUnion x -> getDefinedTypes x TypeDefinitionScalar x -> getDefinedTypes x TypeDefinitionEnum x -> getDefinedTypes x TypeDefinitionInputObject _ -> mempty TypeDefinitionTypeExtension _ -> panic "TODO: we should remove the 'extend' behaviour entirely" data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces (NonEmpty FieldDefinition) deriving (Eq, Ord, Show) instance HasName ObjectTypeDefinition where getName (ObjectTypeDefinition name _ _) = name instance DefinesTypes ObjectTypeDefinition where getDefinedTypes obj@(ObjectTypeDefinition name interfaces fields) = Map.singleton name (TypeDefinitionObject obj) <> foldMap getDefinedTypes interfaces <> foldMap getDefinedTypes fields type Interfaces = [InterfaceTypeDefinition] data FieldDefinition = FieldDefinition Name [ArgumentDefinition] (AnnotatedType GType) deriving (Eq, Ord, Show) instance HasName FieldDefinition where getName (FieldDefinition name _ _) = name instance DefinesTypes FieldDefinition where getDefinedTypes (FieldDefinition _ args retVal) = getDefinedTypes (getAnnotatedType retVal) <> foldMap getDefinedTypes args data ArgumentDefinition = ArgumentDefinition Name (AnnotatedType InputType) (Maybe DefaultValue) deriving (Eq, Ord, Show) instance HasName ArgumentDefinition where getName (ArgumentDefinition name _ _) = name instance DefinesTypes ArgumentDefinition where getDefinedTypes (ArgumentDefinition _ annotatedType _) = getDefinedTypes $ getAnnotatedType annotatedType data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmpty FieldDefinition) deriving (Eq, Ord, Show) instance HasName InterfaceTypeDefinition where getName (InterfaceTypeDefinition name _) = name instance DefinesTypes InterfaceTypeDefinition where getDefinedTypes i@(InterfaceTypeDefinition name fields) = Map.singleton name (TypeDefinitionInterface i) <> foldMap getDefinedTypes fields data UnionTypeDefinition = UnionTypeDefinition Name (NonEmpty ObjectTypeDefinition) deriving (Eq, Ord, Show) instance HasName UnionTypeDefinition where getName (UnionTypeDefinition name _) = name instance DefinesTypes UnionTypeDefinition where getDefinedTypes defn@(UnionTypeDefinition name objs) = Map.singleton name (TypeDefinitionUnion defn) <> foldMap getDefinedTypes objs newtype ScalarTypeDefinition = ScalarTypeDefinition Name deriving (Eq, Ord, Show) instance HasName ScalarTypeDefinition where getName (ScalarTypeDefinition name) = name instance DefinesTypes ScalarTypeDefinition where getDefinedTypes defn = Map.singleton (getName defn) (TypeDefinitionScalar defn) -- | Types that are built into GraphQL. -- -- The GraphQL spec refers to these as -- \"[scalars](https://facebook.github.io/graphql/#sec-Scalars)\". data Builtin -- | A signed 32‐bit numeric non‐fractional value = GInt -- | True or false | GBool -- | Textual data represented as UTF-8 character sequences | GString -- | Signed double‐precision fractional values as specified by [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point) | GFloat -- | A unique identifier, often used to refetch an object or as the key for a cache | GID deriving (Eq, Ord, Show) instance HasName Builtin where getName GInt = "Int" getName GBool = "Boolean" getName GString = "String" getName GFloat = "Float" getName GID = "ID" data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition] deriving (Eq, Ord, Show) instance HasName EnumTypeDefinition where getName (EnumTypeDefinition name _) = name instance DefinesTypes EnumTypeDefinition where getDefinedTypes enum = Map.singleton (getName enum) (TypeDefinitionEnum enum) newtype EnumValueDefinition = EnumValueDefinition Name deriving (Eq, Ord, Show) instance HasName EnumValueDefinition where getName (EnumValueDefinition name) = name data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmpty InputObjectFieldDefinition) deriving (Eq, Ord, Show) instance HasName InputObjectTypeDefinition where getName (InputObjectTypeDefinition name _) = name data InputObjectFieldDefinition = InputObjectFieldDefinition Name (AnnotatedType InputType) (Maybe DefaultValue) deriving (Eq, Ord, Show) -- XXX: spec is unclear about default value for input object field definitions instance HasName InputObjectFieldDefinition where getName (InputObjectFieldDefinition name _ _) = name newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition deriving (Eq, Ord, Show) instance HasName TypeExtensionDefinition where getName (TypeExtensionDefinition obj) = getName obj data InputType = DefinedInputType InputTypeDefinition | BuiltinInputType Builtin deriving (Eq, Ord, Show) instance HasName InputType where getName (DefinedInputType x) = getName x getName (BuiltinInputType x) = getName x instance DefinesTypes InputType where getDefinedTypes inputType = case inputType of DefinedInputType typeDefinition -> getDefinedTypes typeDefinition BuiltinInputType _ -> mempty data InputTypeDefinition = InputTypeDefinitionObject InputObjectTypeDefinition | InputTypeDefinitionScalar ScalarTypeDefinition | InputTypeDefinitionEnum EnumTypeDefinition deriving (Eq, Ord, Show) instance HasName InputTypeDefinition where getName (InputTypeDefinitionObject x) = getName x getName (InputTypeDefinitionScalar x) = getName x getName (InputTypeDefinitionEnum x) = getName x instance DefinesTypes InputTypeDefinition where getDefinedTypes inputTypeDefinition = case inputTypeDefinition of InputTypeDefinitionObject typeDefinition -> getDefinedTypes (TypeDefinitionInputObject typeDefinition) InputTypeDefinitionScalar typeDefinition -> getDefinedTypes (TypeDefinitionScalar typeDefinition) InputTypeDefinitionEnum typeDefinition -> getDefinedTypes (TypeDefinitionEnum typeDefinition) -- | A literal value specified as a default as part of a type definition. -- -- Use this type alias when you want to be clear that a definition may include -- some sort of default value. -- -- Arguments (see 'ArgumentDefinition') and fields within input objects (see -- 'InputObjectFieldDefinition') can have default values. These are allowed to -- be any kind of literal. type DefaultValue = Value -- | Does the given object type match the given type condition. -- -- See -- -- @ -- DoesFragmentTypeApply(objectType, fragmentType) -- If fragmentType is an Object Type: -- if objectType and fragmentType are the same type, return true, otherwise return false. -- If fragmentType is an Interface Type: -- if objectType is an implementation of fragmentType, return true otherwise return false. -- If fragmentType is a Union: -- if objectType is a possible type of fragmentType, return true otherwise return false. -- @ doesFragmentTypeApply :: ObjectTypeDefinition -> TypeDefinition -> Bool doesFragmentTypeApply objectType fragmentType = case fragmentType of TypeDefinitionObject obj -> obj == objectType TypeDefinitionInterface interface -> objectType `implements` interface TypeDefinitionUnion union -> objectType `branchOf` union _ -> False where implements (ObjectTypeDefinition _ interfaces _) int = int `elem` interfaces branchOf obj (UnionTypeDefinition _ branches) = obj `elem` branches -- | Convert the given 'TypeDefinition' to an 'InputTypeDefinition' if it's a valid 'InputTypeDefinition' -- (because 'InputTypeDefinition' is a subset of 'TypeDefinition') -- see getInputTypeDefinition :: TypeDefinition -> Maybe InputTypeDefinition getInputTypeDefinition td = case td of TypeDefinitionInputObject itd -> Just (InputTypeDefinitionObject itd) TypeDefinitionScalar itd -> Just (InputTypeDefinitionScalar itd) TypeDefinitionEnum itd -> Just (InputTypeDefinitionEnum itd) _ -> Nothing -- | Create a 'Builtin' type from a 'Name' -- -- Mostly used for the AST validation -- theobat: There's probably a better way to do it but can't find it right now builtinFromName :: Name -> Maybe Builtin builtinFromName typeName | typeName == getName GInt = Just GInt | typeName == getName GBool = Just GBool | typeName == getName GString = Just GString | typeName == getName GFloat = Just GFloat | typeName == getName GID = Just GID | otherwise = Nothing -- | Simple translation between 'AST' annotation types and 'Schema' annotation types -- -- AST type annotations do not need any validation. -- GraphQL annotations are semantic decorations around type names to indicate type composition (list/non null). astAnnotationToSchemaAnnotation :: AST.GType -> a -> AnnotatedType a astAnnotationToSchemaAnnotation gtype schemaTypeName = case gtype of AST.TypeNamed _ -> TypeNamed schemaTypeName AST.TypeList (AST.ListType astTypeName) -> TypeList (ListType $ astAnnotationToSchemaAnnotation astTypeName schemaTypeName) AST.TypeNonNull (AST.NonNullTypeNamed _) -> TypeNonNull (NonNullTypeNamed schemaTypeName) AST.TypeNonNull (AST.NonNullTypeList (AST.ListType astTypeName)) -> TypeNonNull (NonNullTypeList (ListType (astAnnotationToSchemaAnnotation astTypeName schemaTypeName))) ================================================ FILE: src/GraphQL/Internal/Syntax/AST.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: The GraphQL AST module GraphQL.Internal.Syntax.AST ( QueryDocument(..) , SchemaDocument(..) , Definition(..) , OperationDefinition(..) , Node(..) , VariableDefinition(..) , Variable(..) , SelectionSet , Selection(..) , Field(..) , Alias , Argument(..) , FragmentSpread(..) , InlineFragment(..) , FragmentDefinition(..) , TypeCondition , Value(..) , StringValue(..) , ListValue(..) , ObjectValue(..) , ObjectField(..) , DefaultValue , Directive(..) , GType(..) , NamedType(..) , ListType(..) , NonNullType(..) , TypeDefinition(..) , ObjectTypeDefinition(..) , Interfaces , FieldDefinition(..) , ArgumentsDefinition , InputValueDefinition(..) , InterfaceTypeDefinition(..) , UnionTypeDefinition(..) , ScalarTypeDefinition(..) , EnumTypeDefinition(..) , EnumValueDefinition(..) , InputObjectTypeDefinition(..) , TypeExtensionDefinition(..) ) where import Protolude import Test.QuickCheck (Arbitrary(..), listOf, oneof) import GraphQL.Internal.Arbitrary (arbitraryText) import GraphQL.Internal.Name ( Name , HasName(..) ) -- * Documents -- | A 'QueryDocument' is something a user might send us. -- -- https://facebook.github.io/graphql/#sec-Language.Query-Document newtype QueryDocument = QueryDocument { getDefinitions :: [Definition] } deriving (Eq,Show) data Definition = DefinitionOperation OperationDefinition | DefinitionFragment FragmentDefinition deriving (Eq,Show) -- | A 'SchemaDocument' is a document that defines a GraphQL schema. -- -- https://facebook.github.io/graphql/#sec-Type-System newtype SchemaDocument = SchemaDocument [TypeDefinition] deriving (Eq, Show) data OperationDefinition = Query Node | Mutation Node | AnonymousQuery SelectionSet deriving (Eq,Show) data Node = Node (Maybe Name) [VariableDefinition] [Directive] SelectionSet deriving (Eq,Show) data VariableDefinition = VariableDefinition Variable GType (Maybe DefaultValue) deriving (Eq,Show) newtype Variable = Variable Name deriving (Eq, Ord, Show) instance Arbitrary Variable where arbitrary = Variable <$> arbitrary type SelectionSet = [Selection] data Selection = SelectionField Field | SelectionFragmentSpread FragmentSpread | SelectionInlineFragment InlineFragment deriving (Eq,Show) data Field = Field (Maybe Alias) Name [Argument] [Directive] SelectionSet deriving (Eq,Show) type Alias = Name data Argument = Argument Name Value deriving (Eq,Show) -- * Fragments data FragmentSpread = FragmentSpread Name [Directive] deriving (Eq,Show) data InlineFragment = InlineFragment (Maybe TypeCondition) [Directive] SelectionSet deriving (Eq,Show) data FragmentDefinition = FragmentDefinition Name TypeCondition [Directive] SelectionSet deriving (Eq,Show) type TypeCondition = NamedType -- * Values data Value = ValueVariable Variable | ValueInt Int32 -- GraphQL Float is double precison | ValueFloat Double | ValueBoolean Bool | ValueString StringValue | ValueEnum Name | ValueList ListValue | ValueObject ObjectValue | ValueNull deriving (Eq, Show) instance Arbitrary Value where arbitrary = oneof [ ValueVariable <$> arbitrary , ValueInt <$> arbitrary , ValueFloat <$> arbitrary , ValueBoolean <$> arbitrary , ValueString <$> arbitrary , ValueEnum <$> arbitrary , ValueList <$> arbitrary , ValueObject <$> arbitrary , pure ValueNull ] newtype StringValue = StringValue Text deriving (Eq,Show) instance Arbitrary StringValue where arbitrary = StringValue <$> arbitraryText newtype ListValue = ListValue [Value] deriving (Eq,Show) instance Arbitrary ListValue where arbitrary = ListValue <$> listOf arbitrary newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show) instance Arbitrary ObjectValue where arbitrary = ObjectValue <$> listOf arbitrary data ObjectField = ObjectField Name Value deriving (Eq,Show) instance Arbitrary ObjectField where arbitrary = ObjectField <$> arbitrary <*> arbitrary type DefaultValue = Value -- * Directives data Directive = Directive Name [Argument] deriving (Eq,Show) -- * Type Reference data GType = TypeNamed NamedType | TypeList ListType | TypeNonNull NonNullType deriving (Eq, Ord, Show) -- | Get the name of the given 'GType'. instance HasName GType where getName (TypeNamed (NamedType n)) = n getName (TypeList (ListType t)) = getName t getName (TypeNonNull (NonNullTypeNamed (NamedType n))) = n getName (TypeNonNull (NonNullTypeList (ListType l))) = getName l newtype NamedType = NamedType Name deriving (Eq, Ord, Show) newtype ListType = ListType GType deriving (Eq, Ord, Show) data NonNullType = NonNullTypeNamed NamedType | NonNullTypeList ListType deriving (Eq, Ord, Show) -- * Type definition data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition | TypeDefinitionInterface InterfaceTypeDefinition | TypeDefinitionUnion UnionTypeDefinition | TypeDefinitionScalar ScalarTypeDefinition | TypeDefinitionEnum EnumTypeDefinition | TypeDefinitionInputObject InputObjectTypeDefinition | TypeDefinitionTypeExtension TypeExtensionDefinition deriving (Eq,Show) data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition] deriving (Eq,Show) type Interfaces = [NamedType] data FieldDefinition = FieldDefinition Name ArgumentsDefinition GType deriving (Eq,Show) type ArgumentsDefinition = [InputValueDefinition] data InputValueDefinition = InputValueDefinition Name GType (Maybe DefaultValue) deriving (Eq,Show) data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition] deriving (Eq,Show) data UnionTypeDefinition = UnionTypeDefinition Name [NamedType] deriving (Eq,Show) newtype ScalarTypeDefinition = ScalarTypeDefinition Name deriving (Eq,Show) data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition] deriving (Eq,Show) newtype EnumValueDefinition = EnumValueDefinition Name deriving (Eq,Show) data InputObjectTypeDefinition = InputObjectTypeDefinition Name [InputValueDefinition] deriving (Eq,Show) newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition deriving (Eq,Show) ================================================ FILE: src/GraphQL/Internal/Syntax/Encoder.hs ================================================ {-# OPTIONS_HADDOCK not-home #-} -- | Description: Turn GraphQL ASTs into text module GraphQL.Internal.Syntax.Encoder ( queryDocument , schemaDocument , value ) where import Protolude hiding (intercalate) import qualified Data.Aeson as Aeson import Data.Text (Text, cons, intercalate, pack, snoc) import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.Name (unName) -- * Document queryDocument :: AST.QueryDocument -> Text queryDocument (AST.QueryDocument defs) = (`snoc` '\n') . mconcat $ definition <$> defs definition :: AST.Definition -> Text definition (AST.DefinitionOperation x) = operationDefinition x definition (AST.DefinitionFragment x) = fragmentDefinition x schemaDocument :: AST.SchemaDocument -> Text schemaDocument (AST.SchemaDocument defs) = (`snoc` '\n') . mconcat $ typeDefinition <$> defs operationDefinition :: AST.OperationDefinition -> Text operationDefinition (AST.Query n) = "query " <> node n operationDefinition (AST.Mutation n) = "mutation " <> node n operationDefinition (AST.AnonymousQuery ss) = selectionSet ss node :: AST.Node -> Text node (AST.Node (Just name) vds ds ss) = unName name <> optempty variableDefinitions vds <> optempty directives ds <> selectionSet ss node (AST.Node Nothing vds ds ss) = optempty variableDefinitions vds <> optempty directives ds <> selectionSet ss variableDefinitions :: [AST.VariableDefinition] -> Text variableDefinitions = parensCommas variableDefinition variableDefinition :: AST.VariableDefinition -> Text variableDefinition (AST.VariableDefinition var ty dv) = variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv defaultValue :: AST.DefaultValue -> Text defaultValue val = "=" <> value val variable :: AST.Variable -> Text variable (AST.Variable name) = "$" <> unName name selectionSet :: AST.SelectionSet -> Text selectionSet = bracesCommas selection selection :: AST.Selection -> Text selection (AST.SelectionField x) = field x selection (AST.SelectionInlineFragment x) = inlineFragment x selection (AST.SelectionFragmentSpread x) = fragmentSpread x field :: AST.Field -> Text field (AST.Field alias name args ds ss) = optempty (`snoc` ':') (maybe mempty unName alias) <> unName name <> optempty arguments args <> optempty directives ds <> optempty selectionSet ss arguments :: [AST.Argument] -> Text arguments = parensCommas argument argument :: AST.Argument -> Text argument (AST.Argument name v) = unName name <> ":" <> value v -- * Fragments fragmentSpread :: AST.FragmentSpread -> Text fragmentSpread (AST.FragmentSpread name ds) = "..." <> unName name <> optempty directives ds inlineFragment :: AST.InlineFragment -> Text inlineFragment (AST.InlineFragment (Just (AST.NamedType tc)) ds ss) = "... on " <> unName tc <> optempty directives ds <> optempty selectionSet ss inlineFragment (AST.InlineFragment Nothing ds ss) = "... " <> optempty directives ds <> optempty selectionSet ss fragmentDefinition :: AST.FragmentDefinition -> Text fragmentDefinition (AST.FragmentDefinition name (AST.NamedType tc) ds ss) = "fragment " <> unName name <> " on " <> unName tc <> optempty directives ds <> selectionSet ss -- * Values value :: AST.Value -> Text value (AST.ValueVariable x) = variable x -- TODO: This will be replaced with `decimal` Buidler value (AST.ValueInt x) = pack $ show x -- TODO: This will be replaced with `decimal` Buidler value (AST.ValueFloat x) = pack $ show x value (AST.ValueBoolean x) = booleanValue x value (AST.ValueString x) = stringValue x value (AST.ValueEnum x) = unName x value (AST.ValueList x) = listValue x value (AST.ValueObject x) = objectValue x value AST.ValueNull = "null" booleanValue :: Bool -> Text booleanValue True = "true" booleanValue False = "false" -- TODO: Escape characters stringValue :: AST.StringValue -> Text stringValue (AST.StringValue v) = toS $ Aeson.encode v listValue :: AST.ListValue -> Text listValue (AST.ListValue vs) = bracketsCommas value vs objectValue :: AST.ObjectValue -> Text objectValue (AST.ObjectValue ofs) = bracesCommas objectField ofs objectField :: AST.ObjectField -> Text objectField (AST.ObjectField name v) = unName name <> ":" <> value v -- * Directives directives :: [AST.Directive] -> Text directives = spaces directive directive :: AST.Directive -> Text directive (AST.Directive name args) = "@" <> unName name <> optempty arguments args -- * Type Reference type_ :: AST.GType -> Text type_ (AST.TypeNamed (AST.NamedType x)) = unName x type_ (AST.TypeList x) = listType x type_ (AST.TypeNonNull x) = nonNullType x namedType :: AST.NamedType -> Text namedType (AST.NamedType name) = unName name listType :: AST.ListType -> Text listType (AST.ListType ty) = brackets (type_ ty) nonNullType :: AST.NonNullType -> Text nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = unName x <> "!" nonNullType (AST.NonNullTypeList x) = listType x <> "!" typeDefinition :: AST.TypeDefinition -> Text typeDefinition (AST.TypeDefinitionObject x) = objectTypeDefinition x typeDefinition (AST.TypeDefinitionInterface x) = interfaceTypeDefinition x typeDefinition (AST.TypeDefinitionUnion x) = unionTypeDefinition x typeDefinition (AST.TypeDefinitionScalar x) = scalarTypeDefinition x typeDefinition (AST.TypeDefinitionEnum x) = enumTypeDefinition x typeDefinition (AST.TypeDefinitionInputObject x) = inputObjectTypeDefinition x typeDefinition (AST.TypeDefinitionTypeExtension x) = typeExtensionDefinition x objectTypeDefinition :: AST.ObjectTypeDefinition -> Text objectTypeDefinition (AST.ObjectTypeDefinition name ifaces fds) = "type " <> unName name <> optempty (spaced . interfaces) ifaces <> optempty fieldDefinitions fds interfaces :: AST.Interfaces -> Text interfaces = ("implements " <>) . spaces namedType fieldDefinitions :: [AST.FieldDefinition] -> Text fieldDefinitions = bracesCommas fieldDefinition fieldDefinition :: AST.FieldDefinition -> Text fieldDefinition (AST.FieldDefinition name args ty) = unName name <> optempty argumentsDefinition args <> ":" <> type_ ty argumentsDefinition :: AST.ArgumentsDefinition -> Text argumentsDefinition = parensCommas inputValueDefinition interfaceTypeDefinition :: AST.InterfaceTypeDefinition -> Text interfaceTypeDefinition (AST.InterfaceTypeDefinition name fds) = "interface " <> unName name <> fieldDefinitions fds unionTypeDefinition :: AST.UnionTypeDefinition -> Text unionTypeDefinition (AST.UnionTypeDefinition name ums) = "union " <> unName name <> "=" <> unionMembers ums unionMembers :: [AST.NamedType] -> Text unionMembers = intercalate "|" . fmap namedType scalarTypeDefinition :: AST.ScalarTypeDefinition -> Text scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> unName name enumTypeDefinition :: AST.EnumTypeDefinition -> Text enumTypeDefinition (AST.EnumTypeDefinition name evds) = "enum " <> unName name <> bracesCommas enumValueDefinition evds enumValueDefinition :: AST.EnumValueDefinition -> Text enumValueDefinition (AST.EnumValueDefinition name) = unName name inputObjectTypeDefinition :: AST.InputObjectTypeDefinition -> Text inputObjectTypeDefinition (AST.InputObjectTypeDefinition name ivds) = "input " <> unName name <> inputValueDefinitions ivds inputValueDefinitions :: [AST.InputValueDefinition] -> Text inputValueDefinitions = bracesCommas inputValueDefinition inputValueDefinition :: AST.InputValueDefinition -> Text inputValueDefinition (AST.InputValueDefinition name ty dv) = unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv typeExtensionDefinition :: AST.TypeExtensionDefinition -> Text typeExtensionDefinition (AST.TypeExtensionDefinition otd) = "extend " <> objectTypeDefinition otd -- * Internal spaced :: Text -> Text spaced = cons '\SP' between :: Char -> Char -> Text -> Text between open close = cons open . (`snoc` close) parens :: Text -> Text parens = between '(' ')' brackets :: Text -> Text brackets = between '[' ']' braces :: Text -> Text braces = between '{' '}' spaces :: (a -> Text) -> [a] -> Text spaces f = intercalate "\SP" . fmap f parensCommas :: (a -> Text) -> [a] -> Text parensCommas f = parens . intercalate "," . fmap f bracketsCommas :: (a -> Text) -> [a] -> Text bracketsCommas f = brackets . intercalate "," . fmap f bracesCommas :: (a -> Text) -> [a] -> Text bracesCommas f = braces . intercalate "," . fmap f optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b optempty f xs = if xs == mempty then mempty else f xs ================================================ FILE: src/GraphQL/Internal/Syntax/Parser.hs ================================================ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Parse text into GraphQL ASTs module GraphQL.Internal.Syntax.Parser ( queryDocument , schemaDocument , value ) where import Protolude hiding (option) import Control.Applicative ((<|>), empty, many, optional) import Control.Monad (fail) import Data.Aeson.Parser (jstring) import Data.Scientific (floatingOrInteger) import Data.Text (find) import qualified Data.Attoparsec.ByteString as A import Data.Attoparsec.Text ( Parser , () , anyChar , char , match , many1 , option , scan , scientific , sepBy1 ) import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.Syntax.Tokens (tok, whiteSpace) import GraphQL.Internal.Name (nameParser) -- * Document queryDocument :: Parser AST.QueryDocument queryDocument = whiteSpace *> (AST.QueryDocument <$> many1 definition) "query document error!" -- | Parser for a schema document. schemaDocument :: Parser AST.SchemaDocument schemaDocument = whiteSpace *> (AST.SchemaDocument <$> many1 typeDefinition) "type document error" definition :: Parser AST.Definition definition = AST.DefinitionOperation <$> operationDefinition <|> AST.DefinitionFragment <$> fragmentDefinition "definition error!" operationDefinition :: Parser AST.OperationDefinition operationDefinition = AST.Query <$ tok "query" <*> node <|> AST.Mutation <$ tok "mutation" <*> node <|> (AST.AnonymousQuery <$> selectionSet) "operationDefinition error!" node :: Parser AST.Node node = AST.Node <$> optional nameParser <*> optempty variableDefinitions <*> optempty directives <*> selectionSet variableDefinitions :: Parser [AST.VariableDefinition] variableDefinitions = parens (many1 variableDefinition) variableDefinition :: Parser AST.VariableDefinition variableDefinition = AST.VariableDefinition <$> variable <* tok ":" <*> type_ <*> optional defaultValue defaultValue :: Parser AST.DefaultValue defaultValue = tok "=" *> value variable :: Parser AST.Variable variable = AST.Variable <$ tok "$" <*> nameParser selectionSet :: Parser AST.SelectionSet selectionSet = braces $ many1 selection selection :: Parser AST.Selection selection = AST.SelectionField <$> field -- Inline first to catch `on` case <|> AST.SelectionInlineFragment <$> inlineFragment <|> AST.SelectionFragmentSpread <$> fragmentSpread "selection error!" field :: Parser AST.Field field = AST.Field <$> option empty (pure <$> alias) <*> nameParser <*> optempty arguments <*> optempty directives <*> optempty selectionSet alias :: Parser AST.Alias alias = nameParser <* tok ":" arguments :: Parser [AST.Argument] arguments = parens $ many1 argument argument :: Parser AST.Argument argument = AST.Argument <$> nameParser <* tok ":" <*> value -- * Fragments fragmentSpread :: Parser AST.FragmentSpread -- TODO: Make sure it fails when `... on`. -- See https://facebook.github.io/graphql/#FragmentSpread fragmentSpread = AST.FragmentSpread <$ tok "..." <*> nameParser <*> optempty directives -- InlineFragment tried first in order to guard against 'on' keyword inlineFragment :: Parser AST.InlineFragment inlineFragment = AST.InlineFragment <$ tok "..." <*> optional (tok "on" *> typeCondition) <*> optempty directives <*> selectionSet fragmentDefinition :: Parser AST.FragmentDefinition fragmentDefinition = AST.FragmentDefinition <$ tok "fragment" <*> nameParser <* tok "on" <*> typeCondition <*> optempty directives <*> selectionSet typeCondition :: Parser AST.TypeCondition typeCondition = namedType -- * Values -- This will try to pick the first type it can parse. If you are working with -- explicit types use the `typedValue` parser. value :: Parser AST.Value value = tok (AST.ValueVariable <$> (variable "variable") <|> (number "number") <|> AST.ValueNull <$ tok "null" <|> AST.ValueBoolean <$> (booleanValue "booleanValue") <|> AST.ValueString <$> (stringValue "stringValue") -- `true` and `false` have been tried before <|> AST.ValueEnum <$> (nameParser "name") <|> AST.ValueList <$> (listValue "listValue") <|> AST.ValueObject <$> (objectValue "objectValue") "value error!") where number = do (numText, num) <- match (tok scientific) case (Data.Text.find (== '.') numText, floatingOrInteger num) of (Just _, Left r) -> pure (AST.ValueFloat r) (Just _, Right i) -> pure (AST.ValueFloat (fromIntegral i)) -- TODO: Handle maxBound, Int32 in spec. (Nothing, Left r) -> pure (AST.ValueInt (floor r)) (Nothing, Right i) -> pure (AST.ValueInt i) booleanValue :: Parser Bool booleanValue = True <$ tok "true" <|> False <$ tok "false" stringValue :: Parser AST.StringValue stringValue = do parsed <- char '"' *> jstring_ case unescapeText parsed of Left err -> fail err Right escaped -> pure (AST.StringValue escaped) where -- | Parse a string without a leading quote, ignoring any escaped characters. jstring_ :: Parser Text jstring_ = scan startState go <* anyChar startState = False go a c | a = Just False | c == '"' = Nothing | otherwise = let a' = c == backslash in Just a' where backslash = '\\' -- | Unescape a string. -- -- Turns out this is really tricky, so we're going to cheat by -- reconstructing a literal string (by putting quotes around it) and -- delegating all the hard work to Aeson. unescapeText str = A.parseOnly jstring ("\"" <> toS str <> "\"") -- Notice it can be empty listValue :: Parser AST.ListValue listValue = AST.ListValue <$> brackets (many value) -- Notice it can be empty objectValue :: Parser AST.ObjectValue objectValue = AST.ObjectValue <$> braces (many (objectField "objectField")) objectField :: Parser AST.ObjectField objectField = AST.ObjectField <$> nameParser <* tok ":" <*> value -- * Directives directives :: Parser [AST.Directive] directives = many1 directive directive :: Parser AST.Directive directive = AST.Directive <$ tok "@" <*> nameParser <*> optempty arguments -- * Type Reference type_ :: Parser AST.GType type_ = AST.TypeList <$> listType <|> AST.TypeNonNull <$> nonNullType <|> AST.TypeNamed <$> namedType "type_ error!" namedType :: Parser AST.NamedType namedType = AST.NamedType <$> nameParser listType :: Parser AST.ListType listType = AST.ListType <$> brackets type_ nonNullType :: Parser AST.NonNullType nonNullType = AST.NonNullTypeNamed <$> namedType <* tok "!" <|> AST.NonNullTypeList <$> listType <* tok "!" "nonNullType error!" -- * Type Definition typeDefinition :: Parser AST.TypeDefinition typeDefinition = AST.TypeDefinitionObject <$> objectTypeDefinition <|> AST.TypeDefinitionInterface <$> interfaceTypeDefinition <|> AST.TypeDefinitionUnion <$> unionTypeDefinition <|> AST.TypeDefinitionScalar <$> scalarTypeDefinition <|> AST.TypeDefinitionEnum <$> enumTypeDefinition <|> AST.TypeDefinitionInputObject <$> inputObjectTypeDefinition <|> AST.TypeDefinitionTypeExtension <$> typeExtensionDefinition "typeDefinition error!" objectTypeDefinition :: Parser AST.ObjectTypeDefinition objectTypeDefinition = AST.ObjectTypeDefinition <$ tok "type" <*> nameParser <*> optempty interfaces <*> fieldDefinitions interfaces :: Parser AST.Interfaces interfaces = tok "implements" *> many1 namedType fieldDefinitions :: Parser [AST.FieldDefinition] fieldDefinitions = braces $ many1 fieldDefinition fieldDefinition :: Parser AST.FieldDefinition fieldDefinition = AST.FieldDefinition <$> nameParser <*> optempty argumentsDefinition <* tok ":" <*> type_ argumentsDefinition :: Parser AST.ArgumentsDefinition argumentsDefinition = parens $ many1 inputValueDefinition interfaceTypeDefinition :: Parser AST.InterfaceTypeDefinition interfaceTypeDefinition = AST.InterfaceTypeDefinition <$ tok "interface" <*> nameParser <*> fieldDefinitions unionTypeDefinition :: Parser AST.UnionTypeDefinition unionTypeDefinition = AST.UnionTypeDefinition <$ tok "union" <*> nameParser <* tok "=" <*> unionMembers unionMembers :: Parser [AST.NamedType] unionMembers = namedType `sepBy1` tok "|" scalarTypeDefinition :: Parser AST.ScalarTypeDefinition scalarTypeDefinition = AST.ScalarTypeDefinition <$ tok "scalar" <*> nameParser enumTypeDefinition :: Parser AST.EnumTypeDefinition enumTypeDefinition = AST.EnumTypeDefinition <$ tok "enum" <*> nameParser <*> enumValueDefinitions enumValueDefinitions :: Parser [AST.EnumValueDefinition] enumValueDefinitions = braces $ many1 enumValueDefinition enumValueDefinition :: Parser AST.EnumValueDefinition enumValueDefinition = AST.EnumValueDefinition <$> nameParser inputObjectTypeDefinition :: Parser AST.InputObjectTypeDefinition inputObjectTypeDefinition = AST.InputObjectTypeDefinition <$ tok "input" <*> nameParser <*> inputValueDefinitions inputValueDefinitions :: Parser [AST.InputValueDefinition] inputValueDefinitions = braces $ many1 inputValueDefinition inputValueDefinition :: Parser AST.InputValueDefinition inputValueDefinition = AST.InputValueDefinition <$> nameParser <* tok ":" <*> type_ <*> optional defaultValue typeExtensionDefinition :: Parser AST.TypeExtensionDefinition typeExtensionDefinition = AST.TypeExtensionDefinition <$ tok "extend" <*> objectTypeDefinition -- * Internal parens :: Parser a -> Parser a parens = between "(" ")" braces :: Parser a -> Parser a braces = between "{" "}" brackets :: Parser a -> Parser a brackets = between "[" "]" between :: Parser Text -> Parser Text -> Parser a -> Parser a between open close p = tok open *> p <* tok close -- `empty` /= `pure mempty` for `Parser`. optempty :: Monoid a => Parser a -> Parser a optempty = option mempty ================================================ FILE: src/GraphQL/Internal/Syntax/Tokens.hs ================================================ {-# OPTIONS_HADDOCK not-home #-} -- | Description: Basic tokenising used by parser module GraphQL.Internal.Syntax.Tokens ( tok , whiteSpace ) where import Protolude import Data.Attoparsec.Text ( Parser , anyChar , endOfLine , peekChar , manyTill ) import Data.Char (isSpace) tok :: Parser a -> Parser a tok p = p <* whiteSpace whiteSpace :: Parser () whiteSpace = peekChar >>= traverse_ (\c -> if isSpace c || c == ',' then anyChar *> whiteSpace else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace) ================================================ FILE: src/GraphQL/Internal/Validation.hs ================================================ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE KindSignatures #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Transform GraphQL query documents from AST into valid structures -- -- This corresponds roughly to the -- [Validation](https://facebook.github.io/graphql/#sec-Validation) section of -- the specification, except where noted. -- -- One core difference is that this module doesn't attempt to do any -- type-level validation, as we attempt to defer all of that to the Haskell -- type checker. -- -- Deliberately not going to do: -- -- * field selections on compound types -- * leaf field selections -- * argument names -- * argument value type correctness -- * fragment spread type existence -- * fragments on compound types -- * fragment spread is possible -- * directives are defined -- * directives are in valid locations -- * variable default values are correctly typed -- * variables are input types -- * all variable usages are allowed -- -- Because all of the above rely on type checking. module GraphQL.Internal.Validation ( ValidationError(..) , ValidationErrors , QueryDocument(..) , validate , getErrors -- * Operating on validated documents , Operation , getSelectionSet -- * Executing validated documents , VariableDefinition(..) , VariableValue , Variable , AST.GType(..) -- * Resolving queries , SelectionSetByType , SelectionSet(..) , getSelectionSetForType , Field , lookupArgument , getSubSelectionSet , ResponseKey , getResponseKey -- * Exported for testing , findDuplicates , formatErrors ) where import Protolude hiding ((<>), throwE) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import Data.Semigroup ((<>)) import qualified Data.Set as Set import GraphQL.Internal.Name (HasName(..), Name) import qualified GraphQL.Internal.Syntax.AST as AST -- Directly import things from the AST that do not need validation, so that -- @AST.Foo@ in a type signature implies that something hasn't been validated. import GraphQL.Internal.Syntax.AST (Alias, Variable, NamedType(..)) import GraphQL.Internal.OrderedMap (OrderedMap) import qualified GraphQL.Internal.OrderedMap as OrderedMap import GraphQL.Internal.Output (GraphQLError(..)) import GraphQL.Internal.Schema ( TypeDefinition , ObjectTypeDefinition , Schema , doesFragmentTypeApply , lookupType , AnnotatedType(..) , InputType (BuiltinInputType, DefinedInputType) , AnnotatedType , getInputTypeDefinition , builtinFromName , astAnnotationToSchemaAnnotation ) import GraphQL.Value ( Value , Value' , ConstScalar , UnresolvedVariableValue , astToVariableValue ) -- | A valid query document. -- -- Construct this using 'validate' on an 'AST.QueryDocument'. data QueryDocument value -- | The query document contains a single anonymous operation. = LoneAnonymousOperation (Operation value) -- | The query document contains multiple uniquely-named operations. | MultipleOperations (Operations value) deriving (Eq, Show) data OperationType = Mutation | Query deriving (Eq, Show) data Operation value = Operation OperationType VariableDefinitions (Directives value) (SelectionSetByType value) deriving (Eq, Show) instance Functor Operation where fmap f (Operation operationType vars directives selectionSet) = Operation operationType vars (fmap f directives) (fmap f selectionSet) instance Foldable Operation where foldMap f (Operation _ _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet instance Traversable Operation where traverse f (Operation operationType vars directives selectionSet) = Operation operationType vars <$> traverse f directives <*> traverse f selectionSet -- | Get the selection set for an operation. getSelectionSet :: Operation value -> SelectionSetByType value getSelectionSet (Operation _ _ _ ss) = ss -- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'. type OperationBuilder value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value type Operations value = Map (Maybe Name) (Operation value) -- | Turn a parsed document into a known valid one. -- -- The document is known to be syntactically valid, as we've got its AST. -- Here, we confirm that it's semantically valid (modulo types). validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue) validate schema (AST.QueryDocument defns) = runValidator $ do let (operations, fragments) = splitBy splitDefns defns let (anonymous, maybeNamed) = splitBy splitOps operations (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments case (anonymous, maybeNamed) of ([], ops) -> do (validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty assertAllFragmentsUsed frags (visitedFrags <> usedFrags) resolvedOps <- traverse validateOperation validOps pure (MultipleOperations resolvedOps) ([x], []) -> do (ss, usedFrags) <- runStateT (validateSelectionSet schema frags x) mempty assertAllFragmentsUsed frags (visitedFrags <> usedFrags) validValuesSS <- validateValues ss resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS pure (LoneAnonymousOperation (Operation Query emptyVariableDefinitions emptyDirectives resolvedValuesSS)) _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed)) where splitBy :: (a -> Either b c) -> [a] -> ([b], [c]) splitBy f xs = partitionEithers (map f xs) splitDefns (AST.DefinitionOperation op) = Left op splitDefns (AST.DefinitionFragment frag) = Right frag splitOps (AST.AnonymousQuery ss) = Left ss splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Operation Query, node)) splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Operation Mutation, node)) assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation () assertAllFragmentsUsed fragments used = let unused = Set.map pure (Map.keysSet fragments) `Set.difference` used in unless (Set.null unused) (throwE (UnusedFragments unused)) -- * Operations validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationBuilder AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value) validateOperations schema fragments ops = do deduped <- lift (mapErrors DuplicateOperation (makeMap ops)) traverse validateNode deduped where validateNode (operationBuilder, AST.Node _ vars directives ss) = operationBuilder <$> lift (validateVariableDefinitions schema vars) <*> lift (validateDirectives directives) <*> validateSelectionSet schema fragments ss validateOperation :: Operation AST.Value -> Validation (Operation VariableValue) validateOperation (Operation operationType vars directives selectionSet) = do validValues <- Operation operationType vars <$> validateValues directives <*> validateValues selectionSet -- Instead of doing this, we could build up a list of used variables as we -- resolve them. let usedVariables = getVariables validValues let definedVariables = getDefinedVariables vars let unusedVariables = definedVariables `Set.difference` usedVariables unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables) resolveVariables vars validValues -- * Selection sets -- https://facebook.github.io/graphql/#sec-Field-Selection-Merging -- https://facebook.github.io/graphql/#sec-Executing-Selection-Sets -- 1. the selection set is turned into a grouped field set; -- 2. each represented field in the grouped field set produces an entry into -- a response map. -- https://facebook.github.io/graphql/#sec-Field-Collection -- | Resolve all the fragments in a selection set and make sure the names, -- arguments, and directives are all valid. -- -- Runs in 'StateT', collecting a set of names of 'FragmentDefinition' that -- have been used by this selection set. -- -- We do this /before/ validating the values (since that's much easier once -- everything is in a nice structure and away from the AST), which means we -- can't yet evaluate directives. validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set (Maybe Name)) Validation (SelectionSetByType AST.Value) validateSelectionSet schema fragments selections = do unresolved <- lift $ traverse (validateSelection schema) selections resolved <- traverse (resolveSelection fragments) unresolved lift $ groupByResponseKey resolved -- | A selection set, almost fully validated. -- -- Sub-selection sets might not be validated. newtype SelectionSet value = SelectionSet (OrderedMap ResponseKey (Field value)) deriving (Eq, Ord, Show) newtype SelectionSetByType value = SelectionSetByType (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value))) deriving (Eq, Ord, Show, Functor, Foldable, Traversable) -- | A 'ResponseKey' is the key under which a field appears in a response. If -- there's an alias, it's the alias, if not, it's the field name. type ResponseKey = Name -- | A field ready to be resolved. data Field value = Field { name :: Name , arguments :: Arguments value , subSelectionSet :: Maybe (SelectionSetByType value) } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) instance HasName (Field value) where getName = name -- | Get the value of an argument in a field. lookupArgument :: Field value -> Name -> Maybe value lookupArgument (Field _ (Arguments args) _) name = Map.lookup name args -- | Get the selection set within a field. getSubSelectionSet :: Field value -> Maybe (SelectionSetByType value) getSubSelectionSet = subSelectionSet -- | Merge two execution fields. Assumes that they are fields for the same -- response key on the same type (i.e. that they are fields we would actually -- rationally want to merge). mergeFields :: Eq value => Field value -> Field value -> Validation (Field value) mergeFields field1 field2 = do unless (name field1 == name field2) $ throwE (MismatchedNames (name field1) (name field2)) unless (arguments field1 == arguments field2) $ throwE (MismatchedArguments (name field1)) case (subSelectionSet field1, subSelectionSet field2) of (Nothing, Nothing) -> pure Field { name = name field1 , arguments = arguments field1 , subSelectionSet = Nothing } (Just ss1, Just ss2) -> do mergedSet <- mergeSelectionSets ss1 ss2 pure Field { name = name field1 , arguments = arguments field1 , subSelectionSet = Just mergedSet } _ -> throwE (IncompatibleFields (name field1)) where mergeSelectionSets :: Eq value => SelectionSetByType value -> SelectionSetByType value -> Validation (SelectionSetByType value) mergeSelectionSets (SelectionSetByType ss1) (SelectionSetByType ss2) = SelectionSetByType <$> OrderedMap.unionWithM (OrderedMap.unionWithM mergeFields) ss1 ss2 -- | Once we know the GraphQL type of the object that a selection set (i.e. a -- 'SelectionSetByType') is for, we can eliminate all the irrelevant types and -- present a single, flattened map of 'ResponseKey' to 'Field'. getSelectionSetForType :: Eq value => ObjectTypeDefinition -- ^ The type of the object that the selection set is for -> SelectionSetByType value -- ^ A selection set with type conditions, obtained from the validation process -> Either ValidationErrors (SelectionSet value) -- ^ A flattened -- selection set without type conditions. It's possible that some of the -- fields in various types are not mergeable, in which case, we'll return a -- validation error. getSelectionSetForType objectType (SelectionSetByType ss) = runValidator $ SelectionSet . OrderedMap.catMaybes <$> traverse mergeFieldsForType ss where mergeFieldsForType fieldMap = do let matching = filter (satisfiesType . fst) (OrderedMap.toList fieldMap) case map snd matching of [] -> pure Nothing x:xs -> Just <$> foldlM mergeFields x xs satisfiesType = all (doesFragmentTypeApply objectType) . Set.toList -- | Flatten the selection and group it by response key and then type -- conditions. -- -- Doesn't do any validation at all. Just provides a list of "execution -- values" which are the possible things that might be executed, depending on -- the type. -- -- XXX: This is so incredibly complex. No doubt there's a way to simplify, but -- jml can't see it right now. groupByResponseKey :: Eq value => [Selection' FragmentSpread value] -> Validation (SelectionSetByType value) groupByResponseKey selectionSet = SelectionSetByType <$> flattenSelectionSet mempty selectionSet where -- | Given a currently "active" type condition, and a single selection, -- return a map of response keys to validated fields, grouped by types: -- essentially a SelectionSetByType without the wrapping -- constructor. -- -- The "active" type condition is the type condition of the selection set -- that contains the selection. byKey :: Eq value => Set TypeDefinition -> Selection' FragmentSpread value -> Validation (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value))) byKey typeConds (SelectionField field@(Field' _ name arguments _ ss)) = case ss of [] -> pure $ OrderedMap.singleton (getResponseKey field) . OrderedMap.singleton typeConds . Field name arguments $ Nothing _ -> OrderedMap.singleton (getResponseKey field) . OrderedMap.singleton typeConds . Field name arguments . Just <$> groupByResponseKey ss byKey typeConds (SelectionFragmentSpread (FragmentSpread _ _ (FragmentDefinition _ typeCond _ ss))) = flattenSelectionSet (typeConds <> Set.singleton typeCond) ss byKey typeConds (SelectionInlineFragment (InlineFragment (Just typeCond) _ ss)) = flattenSelectionSet (typeConds <> Set.singleton typeCond) ss byKey typeConds (SelectionInlineFragment (InlineFragment Nothing _ ss)) = flattenSelectionSet typeConds ss flattenSelectionSet :: Eq value => Set TypeDefinition -> [Selection' FragmentSpread value] -> Validation (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value))) flattenSelectionSet typeConds ss = do groupedByKey <- traverse (byKey typeConds) ss OrderedMap.unionsWithM (OrderedMap.unionWithM mergeFields) groupedByKey -- * Selections -- $fragmentSpread -- -- The @spread@ type variable is for the type used to "fragment spreads", i.e. -- references to fragments. It's a variable because we do multiple traversals -- of the selection graph. -- -- The first pass (see 'validateSelection') ensures all the arguments and -- directives are valid. This is applied to all selections, including those -- that make up fragment definitions (see 'validateFragmentDefinitions'). At -- this stage, @spread@ will be 'UnresolvedFragmentSpread'. -- -- Once we have a known-good map of fragment definitions, we can do the next -- phase of validation, which checks that references to fragments exist, that -- all fragments are used, and that we don't have circular references. -- -- This is encoded as a type variable because we want to provide evidence that -- references in fragment spreads can be resolved, and what better way to do -- so than including the resolved fragment in the type. Thus, @spread@ will be -- 'FragmentSpread', following this module's convention that unadorned names -- imply that everything is valid. -- | A GraphQL selection. data Selection' (spread :: * -> *) value = SelectionField (Field' spread value) | SelectionFragmentSpread (spread value) | SelectionInlineFragment (InlineFragment spread value) deriving (Eq, Show, Functor, Foldable, Traversable) -- | A field in a selection set, which itself might have children which might -- have fragment spreads. data Field' spread value = Field' (Maybe Alias) Name (Arguments value) (Directives value) [Selection' spread value] deriving (Eq, Show) -- | Get the response key of a field. -- -- \"A field’s response key is its alias if an alias is provided, and it is -- otherwise the field’s name.\" -- -- getResponseKey :: Field' spread value -> ResponseKey getResponseKey (Field' alias name _ _ _) = fromMaybe name alias instance HasName (Field' spread value) where getName (Field' _ name _ _ _) = name instance Functor spread => Functor (Field' spread) where fmap f (Field' alias name arguments directives selectionSet) = Field' alias name (fmap f arguments) (fmap f directives) (map (fmap f) selectionSet) instance Foldable spread => Foldable (Field' spread) where foldMap f (Field' _ _ arguments directives selectionSet) = mconcat [ foldMap f arguments , foldMap f directives , mconcat (map (foldMap f) selectionSet) ] instance Traversable spread => Traversable (Field' spread) where traverse f (Field' alias name arguments directives selectionSet) = Field' alias name <$> traverse f arguments <*> traverse f directives <*> traverse (traverse f) selectionSet -- | A fragment spread that has a valid set of directives, but may or may not -- refer to a fragment that actually exists. data UnresolvedFragmentSpread value = UnresolvedFragmentSpread Name (Directives value) deriving (Eq, Show, Functor) instance Foldable UnresolvedFragmentSpread where foldMap f (UnresolvedFragmentSpread _ directives) = foldMap f directives instance Traversable UnresolvedFragmentSpread where traverse f (UnresolvedFragmentSpread name directives) = UnresolvedFragmentSpread name <$> traverse f directives -- | A fragment spread that refers to fragments which are known to exist. data FragmentSpread value = FragmentSpread Name (Directives value) (FragmentDefinition FragmentSpread value) deriving (Eq, Show) instance Functor FragmentSpread where fmap f (FragmentSpread name directives definition) = FragmentSpread name (fmap f directives) (fmap f definition) instance Foldable FragmentSpread where foldMap f (FragmentSpread _ directives fragment) = foldMap f directives `mappend` foldMap f fragment instance Traversable FragmentSpread where traverse f (FragmentSpread name directives definition) = FragmentSpread name <$> traverse f directives <*> traverse f definition -- | An inline fragment, which itself can contain fragment spreads. data InlineFragment spread value = InlineFragment (Maybe TypeDefinition) (Directives value) [Selection' spread value] deriving (Eq, Show) instance Functor spread => Functor (InlineFragment spread) where fmap f (InlineFragment typeDefn directives selectionSet) = InlineFragment typeDefn (fmap f directives) (map (fmap f) selectionSet) instance Foldable spread => Foldable (InlineFragment spread) where foldMap f (InlineFragment _ directives selectionSet) = foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet) instance Traversable spread => Traversable (InlineFragment spread) where traverse f (InlineFragment typeDefn directives selectionSet) = InlineFragment typeDefn <$> traverse f directives <*> traverse (traverse f) selectionSet -- | Traverse through every fragment spread in a selection. -- -- The given function @f@ is applied to each fragment spread. The rest of the -- selection remains unchanged. -- -- Note that this is essentially a definition of 'Traversable' for -- 'Selection'. However, we probably also want to have other kinds of -- traversals (e.g. for transforming values), so best not to bless one kind -- with a type class. traverseFragmentSpreads :: Applicative f => (a value -> f (b value)) -> Selection' a value -> f (Selection' b value) traverseFragmentSpreads f selection = case selection of SelectionField (Field' alias name args directives ss) -> SelectionField <$> (Field' alias name args directives <$> childSegments ss) SelectionFragmentSpread x -> SelectionFragmentSpread <$> f x SelectionInlineFragment (InlineFragment typeCond directives ss) -> SelectionInlineFragment <$> (InlineFragment typeCond directives <$> childSegments ss) where childSegments = traverse (traverseFragmentSpreads f) -- | Ensure a selection has valid arguments and directives. validateSelection :: Schema -> AST.Selection -> Validation (Selection' UnresolvedFragmentSpread AST.Value) validateSelection schema selection = case selection of AST.SelectionField (AST.Field alias name args directives ss) -> SelectionField <$> (Field' alias name <$> validateArguments args <*> validateDirectives directives <*> childSegments ss) AST.SelectionFragmentSpread (AST.FragmentSpread name directives) -> SelectionFragmentSpread <$> (UnresolvedFragmentSpread name <$> validateDirectives directives) AST.SelectionInlineFragment (AST.InlineFragment typeCond directives ss) -> SelectionInlineFragment <$> (InlineFragment <$> traverse (validateTypeCondition schema) typeCond <*> validateDirectives directives <*> childSegments ss) where childSegments = traverse (validateSelection schema) -- | Resolve the fragment references in a selection, accumulating a set of -- the fragment names that we have resolved. -- -- We're doing a standard depth-first traversal of fragment references, where -- references are by name, so the set of names can be thought of as a record -- of visited references. resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set (Maybe Name)) Validation (Selection' FragmentSpread a) resolveSelection fragments = traverseFragmentSpreads resolveFragmentSpread where resolveFragmentSpread (UnresolvedFragmentSpread name directive) = do case Map.lookup name fragments of Nothing -> lift (throwE (NoSuchFragment name)) Just fragment -> do modify (Set.insert (pure name)) pure (FragmentSpread name directive fragment) -- * Fragment definitions -- | A validated fragment definition. -- -- @spread@ indicates whether references to other fragment definitions have -- been resolved. data FragmentDefinition spread value = FragmentDefinition Name TypeDefinition (Directives value) [Selection' spread value] deriving (Eq, Show) type Fragments value = Map Name (FragmentDefinition FragmentSpread value) instance Functor spread => Functor (FragmentDefinition spread) where fmap f (FragmentDefinition name typeDefn directives selectionSet) = FragmentDefinition name typeDefn (fmap f directives) (map (fmap f) selectionSet) instance Foldable spread => Foldable (FragmentDefinition spread) where foldMap f (FragmentDefinition _ _ directives selectionSet) = foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet) instance Traversable spread => Traversable (FragmentDefinition spread) where traverse f (FragmentDefinition name typeDefn directives selectionSet) = FragmentDefinition name typeDefn <$> traverse f directives <*> traverse (traverse f) selectionSet -- | Ensure fragment definitions are uniquely named, and that their arguments -- and directives are sane. -- -- validateFragmentDefinitions :: Schema -> [AST.FragmentDefinition] -> Validation (Map Name (FragmentDefinition UnresolvedFragmentSpread AST.Value)) validateFragmentDefinitions schema frags = do defns <- traverse validateFragmentDefinition frags mapErrors DuplicateFragmentDefinition (makeMap [(name, value) | value@(FragmentDefinition name _ _ _) <- defns]) where validateFragmentDefinition (AST.FragmentDefinition name typeCond directives ss) = do FragmentDefinition name <$> validateTypeCondition schema typeCond <*> validateDirectives directives <*> traverse (validateSelection schema) ss -- | Validate a type condition that appears in a query. validateTypeCondition :: Schema -> AST.TypeCondition -> Validation TypeDefinition validateTypeCondition schema (NamedType typeCond) = case lookupType schema typeCond of Nothing -> throwE (TypeConditionNotFound typeCond) Just typeDefn -> pure typeDefn -- | Resolve all references to fragments inside fragment definitions. -- -- Guarantees that fragment spreads refer to fragments that have been defined, -- and that there are no circular references. -- -- Returns the resolved fragment definitions and a set of the names of all -- defined fragments that were referred to by other fragments. This is to be -- used to guarantee that all defined fragments are used (c.f. -- ). -- -- -- resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set (Maybe Name)) resolveFragmentDefinitions allFragments = splitResult <$> traverse resolveFragment allFragments where -- The result of our computation is a map from names of fragment -- definitions to the resolved fragment and visited names. We want to -- split out the visited names and combine them so that later we can -- report on the _un_visited names. splitResult mapWithVisited = (map fst mapWithVisited, foldMap snd mapWithVisited) -- | Resolves all references to fragments in a fragment definition, -- returning the resolved fragment and a set of visited names. resolveFragment frag = runStateT (resolveFragment' frag) mempty resolveFragment' (FragmentDefinition name cond directives ss) = FragmentDefinition name cond directives <$> traverse (traverseFragmentSpreads resolveSpread) ss resolveSpread (UnresolvedFragmentSpread name directives) = do visited <- Set.member (pure name) <$> get when visited (lift (throwE (CircularFragmentSpread name))) case Map.lookup name allFragments of Nothing -> lift (throwE (NoSuchFragment name)) Just definition -> do modify (Set.insert (pure name)) FragmentSpread name directives <$> resolveFragment' definition -- * Arguments -- | The set of arguments for a given field, directive, etc. -- -- Note that the 'value' can be a variable. newtype Arguments value = Arguments (Map Name value) deriving (Eq, Ord, Show, Functor, Foldable, Traversable) -- | Turn a set of arguments from the AST into a guaranteed unique set of arguments. -- -- validateArguments :: [AST.Argument] -> Validation (Arguments AST.Value) validateArguments args = Arguments <$> mapErrors DuplicateArgument (makeMap [(name, value) | AST.Argument name value <- args]) -- * Variables -- | Defines a variable within the context of an operation. -- -- See data VariableDefinition = VariableDefinition { variable :: Variable -- ^ The name of the variable , variableType :: AnnotatedType InputType -- ^ The type of the variable , defaultValue :: Maybe Value -- ^ An optional default value for the variable } deriving (Eq, Ord, Show) type VariableDefinitions = Map Variable VariableDefinition getDefinedVariables :: VariableDefinitions -> Set Variable getDefinedVariables = Map.keysSet -- | A GraphQL value which might contain some defined variables. type VariableValue = Value' (Either VariableDefinition ConstScalar) emptyVariableDefinitions :: VariableDefinitions emptyVariableDefinitions = mempty -- | Ensure that a set of variable definitions is valid. validateVariableDefinitions :: Schema -> [AST.VariableDefinition] -> Validation VariableDefinitions validateVariableDefinitions schema vars = do validatedDefns <- traverse (validateVariableDefinition schema) vars let items = [ (variable defn, defn) | defn <- validatedDefns] mapErrors DuplicateVariableDefinition (makeMap items) -- | Ensure that a variable definition is a valid one. validateVariableDefinition :: Schema -> AST.VariableDefinition -> Validation VariableDefinition validateVariableDefinition schema (AST.VariableDefinition var varType value) = VariableDefinition var <$> validateTypeAssertion schema var varType <*> traverse validateDefaultValue value -- | Ensure that a variable has a correct type declaration given a schema. validateTypeAssertion :: Schema -> Variable -> AST.GType -> Validation (AnnotatedType InputType) validateTypeAssertion schema var varTypeAST = astAnnotationToSchemaAnnotation varTypeAST <$> case lookupType schema varTypeNameAST of Nothing -> validateVariableTypeBuiltin var varTypeNameAST Just cleanTypeDef -> validateVariableTypeDefinition var cleanTypeDef where varTypeNameAST = getName varTypeAST -- | Validate a variable type which has a type definition in the schema. validateVariableTypeDefinition :: Variable -> TypeDefinition -> Validation InputType validateVariableTypeDefinition var typeDef = case getInputTypeDefinition typeDef of Nothing -> throwE (VariableTypeIsNotInputType var $ getName typeDef) Just value -> pure (DefinedInputType value) -- | Validate a variable type which has no type definition (either builtin or not in the schema). validateVariableTypeBuiltin :: Variable -> Name -> Validation InputType validateVariableTypeBuiltin var typeName = case builtinFromName typeName of Nothing -> throwE (VariableTypeNotFound var typeName) Just builtin -> pure (BuiltinInputType builtin) -- | Ensure that a default value contains no variables. validateDefaultValue :: AST.DefaultValue -> Validation Value validateDefaultValue defaultValue = case astToVariableValue defaultValue of Nothing -> throwE $ InvalidValue defaultValue Just value -> for value $ \case Left _ -> throwE $ InvalidDefaultValue defaultValue Right constant -> pure constant -- | Get all the variables referred to in a thing what contains variables. getVariables :: Foldable f => f UnresolvedVariableValue -> Set Variable getVariables = foldMap valueToVariable where valueToVariable = foldMap (either Set.singleton (const Set.empty)) -- | Make sure all the values are valid. validateValues :: Traversable f => f AST.Value -> Validation (f UnresolvedVariableValue) validateValues = traverse toVariableValue where toVariableValue astValue = case astToVariableValue astValue of Just value -> pure value Nothing -> throwE (InvalidValue astValue) -- | Make sure each variable has a definition, and each definition a variable. resolveVariables :: Traversable f => VariableDefinitions -> f UnresolvedVariableValue -> Validation (f VariableValue) resolveVariables definitions = traverse resolveVariableValue where resolveVariableValue = traverse resolveVariable resolveVariable (Left variable) = case Map.lookup variable definitions of Nothing -> throwE (UndefinedVariable variable) Just defn -> pure (Left defn) resolveVariable (Right constant) = pure (Right constant) -- * Directives -- | A directive is a way of changing the run-time behaviour newtype Directives value = Directives (Map Name (Arguments value)) deriving (Eq, Ord, Show, Foldable, Functor, Traversable) emptyDirectives :: Directives value emptyDirectives = Directives Map.empty -- | Ensure that the directives in a given place are valid. -- -- Doesn't check to see if directives are defined & doesn't check to see if -- they are in valid locations, because we don't have access to the schema at -- this point. -- -- validateDirectives :: [AST.Directive] -> Validation (Directives AST.Value) validateDirectives directives = do items <- traverse validateDirective directives Directives <$> mapErrors DuplicateDirective (makeMap items) where validateDirective (AST.Directive name args) = (,) name <$> validateArguments args -- TODO: There's a chunk of duplication around "this collection of things has -- unique names". Fix that. -- TODO: Might be nice to have something that goes from a validated document -- back to the AST. This would be especially useful for encoding, so we could -- debug by looking at GraphQL rather than data types. -- * Validation errors -- | Errors arising from validating a document. data ValidationError -- | 'DuplicateOperation' means there was more than one operation defined -- with the given name. -- -- = DuplicateOperation (Maybe Name) -- | 'MixedAnonymousOperations' means there was more than one operation -- defined in a document with an anonymous operation. -- -- | MixedAnonymousOperations Int [Maybe Name] -- | 'DuplicateArgument' means that multiple copies of the same argument was -- given to the same field, directive, etc. | DuplicateArgument Name -- | 'DuplicateFragmentDefinition' means that there were more than one -- fragment defined with the same name. | DuplicateFragmentDefinition Name -- | 'NoSuchFragment' means there was a reference to a fragment in a -- fragment spread but we couldn't find any fragment with that name. | NoSuchFragment Name -- | 'DuplicateDirective' means there were two copies of the same directive -- given in the same place. -- -- | DuplicateDirective Name -- | There were multiple variables defined with the same name. | DuplicateVariableDefinition Variable -- | 'CircularFragmentSpread' means that a fragment definition contains a -- fragment spread that itself is a fragment definition that contains a -- fragment spread referring to the /first/ fragment spread. | CircularFragmentSpread Name -- | 'UnusedFragments' means that fragments were defined that weren't used. -- | UnusedFragments (Set (Maybe Name)) -- | Variables were defined without being used. -- | UnusedVariables (Set Variable) -- | A variable was used without being defined. -- | UndefinedVariable Variable -- | Value in AST wasn't valid. | InvalidValue AST.Value -- | Default value in AST contained variables. | InvalidDefaultValue AST.Value -- | Two different names given for the same response key. | MismatchedNames Name Name -- | Two different sets of arguments given for the same response key. | MismatchedArguments Name -- | Two fields had the same response key, one was a leaf, the other was not. | IncompatibleFields Name -- | There's a type condition that's not present in the schema. | TypeConditionNotFound Name -- | There's a variable type that's not present in the schema. | VariableTypeNotFound Variable Name -- | A variable was defined with a non input type. -- | VariableTypeIsNotInputType Variable Name deriving (Eq, Show) instance GraphQLError ValidationError where formatError (DuplicateOperation maybeName) = "More than one operation named '" <> show maybeName <> "'" formatError (MixedAnonymousOperations n maybeNames) | n > 1 && null maybeNames = "Multiple anonymous operations defined. Found " <> show n | otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show maybeNames <> ")" formatError (DuplicateArgument name) = "More than one argument named '" <> show name <> "'" formatError (DuplicateFragmentDefinition name) = "More than one fragment named '" <> show name <> "'" formatError (NoSuchFragment name) = "No fragment named '" <> show name <> "'" formatError (DuplicateDirective name) = "More than one directive named '" <> show name <> "'" formatError (DuplicateVariableDefinition name) = "More than one variable defined with name '" <> show name <> "'" formatError (CircularFragmentSpread name) = "Fragment '" <> show name <> "' contains a fragment spread that refers back to itself." formatError (UnusedFragments names) = "Fragments defined but not used: " <> show names formatError (UnusedVariables names) = "Variables defined but not used: " <> show names formatError (UndefinedVariable variable) = "No definition for variable: " <> show variable formatError (InvalidValue value) = "Invalid value (maybe an object has duplicate field names?): " <> show value formatError (InvalidDefaultValue value) = "Invalid default value, contains variables: " <> show value formatError (MismatchedNames name1 name2) = "Two different names given for same response key: " <> show name1 <> ", " <> show name2 formatError (MismatchedArguments name) = "Two different sets of arguments given for same response key: " <> show name formatError (IncompatibleFields name) = "Field " <> show name <> " has a leaf in one place and a non-leaf in another." formatError (TypeConditionNotFound name) = "Type condition " <> show name <> " not found in schema." formatError (VariableTypeNotFound var name) = "Type named " <> show name <> " for variable " <> show var <> " is not in the schema." formatError (VariableTypeIsNotInputType var name) = "Type named " <> show name <> " for variable " <> show var <> " is not an input type." type ValidationErrors = NonEmpty ValidationError -- | Type alias for our most common kind of validator. type Validation = Validator ValidationError -- | Identify all of the validation errors in @doc@. -- -- An empty list means no errors. -- -- getErrors :: Schema -> AST.QueryDocument -> [ValidationError] getErrors schema doc = case validate schema doc of Left errors -> NonEmpty.toList errors Right _ -> [] -- * Helper functions -- | Return a list of all the elements with duplicates. The list of duplicates -- itself will not contain duplicates. -- -- prop> \xs -> findDuplicates @Int xs == ordNub (findDuplicates @Int xs) findDuplicates :: Ord a => [a] -> [a] findDuplicates xs = findDups (sort xs) where findDups [] = [] findDups [_] = [] findDups (x:ys@(y:zs)) | x == y = x:findDups (dropWhile (== x) zs) | otherwise = findDups ys -- | Create a map from a list of key-value pairs. -- -- Returns a list of duplicates on 'Left' if there are duplicates. makeMap :: Ord key => [(key, value)] -> Validator key (Map key value) makeMap entries = case NonEmpty.nonEmpty (findDuplicates (map fst entries)) of Nothing -> pure (Map.fromList entries) Just dups -> throwErrors dups -- * Error handling -- | Utility function for tests, format ErrorTypes to their text representation -- returns a list of error messages formatErrors :: [ValidationError] -> [Text] formatErrors errors = formatError <$> errors -- | A 'Validator' is a value that can either be valid or have a non-empty -- list of errors. newtype Validator e a = Validator { runValidator :: Either (NonEmpty e) a } deriving (Eq, Show, Functor, Monad) -- | Throw a single validation error. throwE :: e -> Validator e a throwE e = throwErrors (e :| []) -- | Throw multiple validation errors. There must be at least one. throwErrors :: NonEmpty e -> Validator e a throwErrors = Validator . Left -- | Map over each individual error on a validation. Useful for composing -- validations. -- -- This is /somewhat/ like 'first', but 'Validator' is not, and cannot be, a -- 'Bifunctor', because the left-hand side is specialized to @NonEmpty e@, -- rather than plain @e@. Also, whatever function were passed to 'first' would -- get the whole non-empty list, whereas 'mapErrors' works on one element at a -- time. -- -- >>> mapErrors (+1) (pure "hello") -- Validator {runValidator = Right "hello"} -- >>> mapErrors (+1) (throwE 2) -- Validator {runValidator = Left (3 :| [])} -- >>> mapErrors (+1) (throwErrors (NonEmpty.fromList [3, 5])) -- Validator {runValidator = Left (4 :| [6])} mapErrors :: (e1 -> e2) -> Validator e1 a -> Validator e2 a mapErrors f (Validator (Left es)) = Validator (Left (map f es)) mapErrors _ (Validator (Right x)) = Validator (Right x) -- | The applicative on Validator allows multiple potentially-valid values to -- be composed, and ensures that *all* validation errors bubble up. instance Applicative (Validator e) where pure x = Validator (Right x) Validator (Left e1) <*> (Validator (Left e2)) = Validator (Left (e1 <> e2)) Validator (Left e) <*> _ = Validator (Left e) Validator _ <*> (Validator (Left e)) = Validator (Left e) Validator (Right f) <*> Validator (Right x) = Validator (Right (f x)) ================================================ FILE: src/GraphQL/Internal/Value/FromValue.hs ================================================ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Convert GraphQL values to domain-specific Haskell values module GraphQL.Internal.Value.FromValue ( FromValue(..) , prop_roundtripValue , wrongType ) where import Protolude hiding (TypeError) import qualified Data.List.NonEmpty as NonEmpty import GHC.Generics ((:*:)(..)) import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) import GHC.Types (Type) import GraphQL.Internal.Name (nameFromSymbol) import qualified GraphQL.Internal.OrderedMap as OM import GraphQL.Internal.Value import GraphQL.Internal.Value.ToValue (ToValue(..)) -- * FromValue -- | @a@ can be converted from a GraphQL 'Value' to a Haskell value. -- -- The @FromValue@ instance converts 'AST.Value' to the type expected by the -- handler function. It is the boundary between incoming data and your custom -- application Haskell types. -- -- @FromValue@ has a generic instance for converting input objects to -- records. class FromValue a where -- | Convert an already-parsed value into a Haskell value, generally to be -- passed to a handler. fromValue :: Value' ConstScalar -> Either Text a default fromValue :: (Generic a, GenericFromValue (Rep a)) => Value' ConstScalar -> Either Text a fromValue (ValueObject v) = to <$> genericFromValue v fromValue v = wrongType "genericFromValue only works with objects." v instance FromValue Int32 where fromValue (ValueInt v) = pure v fromValue v = wrongType "Int" v instance FromValue Double where fromValue (ValueFloat v) = pure v fromValue v = wrongType "Double" v instance FromValue Bool where fromValue (ValueBoolean v) = pure v fromValue v = wrongType "Bool" v instance FromValue Text where fromValue (ValueString (String v)) = pure v fromValue v = wrongType "String" v instance forall v. FromValue v => FromValue [v] where fromValue (ValueList' (List' values)) = traverse (fromValue @v) values fromValue v = wrongType "List" v instance forall v. FromValue v => FromValue (NonEmpty v) where fromValue (ValueList' (List' values)) = case NonEmpty.nonEmpty values of Nothing -> Left "Cannot construct NonEmpty from empty list" Just values' -> traverse (fromValue @v) values' fromValue v = wrongType "List" v instance forall v. FromValue v => FromValue (Maybe v) where fromValue ValueNull = pure Nothing fromValue x = Just <$> fromValue @v x -- | Anything that can be converted to a value and from a value should roundtrip. prop_roundtripValue :: forall a. (Eq a, ToValue a, FromValue a) => a -> Bool prop_roundtripValue x = fromValue (toValue x) == Right x -- | Throw an error saying that @value@ does not have the @expected@ type. wrongType :: (MonadError Text m, Show a) => Text -> a -> m b wrongType expected value = throwError ("Wrong type, should be: `" <> expected <> "` but is: `" <> show value <> "`") -- We only allow generic record reading for now because I am not sure -- how we should interpret any other generic things (e.g. tuples). class GenericFromValue (f :: Type -> Type) where genericFromValue :: Object' ConstScalar -> Either Text (f p) instance forall dataName consName records s l p. ( KnownSymbol dataName , KnownSymbol consName , GenericFromValue records ) => GenericFromValue (D1 ('MetaData dataName s l 'False) (C1 ('MetaCons consName p 'True) records )) where genericFromValue o = M1 . M1 <$> genericFromValue @records o instance forall l r. ( GenericFromValue l , GenericFromValue r ) => GenericFromValue (l :*: r) where genericFromValue object = liftA2 (:*:) (genericFromValue @l object) (genericFromValue @r object) -- | Look up a single record field element in the Object. getValue :: forall wrappedType fieldName u s l p. (FromValue wrappedType, KnownSymbol fieldName) => Object' ConstScalar -> Either Text ((S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) p) getValue (Object' fieldMap) = do fieldName <- case nameFromSymbol @fieldName of Left err -> throwError ("invalid field name" <> show err) Right name' -> pure name' -- TODO(tom): How do we deal with optional fields? Maybe sounds -- like the correct type, but how would Maybe be different from -- `null`? Delegating to FromValue not good enough here because of -- the dictionary lookup. case OM.lookup fieldName fieldMap of Nothing -> throwError ("Key not found: " <> show fieldName) Just v -> M1 . K1 <$> fromValue @wrappedType v instance forall wrappedType fieldName u s l. ( KnownSymbol fieldName , FromValue wrappedType ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where genericFromValue = getValue @wrappedType @fieldName instance forall l r m. ( TypeError ('Text "Generic fromValue only works for records with exactly one data constructor.") ) => GenericFromValue (D1 m (l :+: r)) where genericFromValue = panic "genericFromValue cannot be called for records with more than one data constructor. Code that tries will not be compiled." ================================================ FILE: src/GraphQL/Internal/Value/ToValue.hs ================================================ {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Turn domain-specific Haskell values into GraphQL values. module GraphQL.Internal.Value.ToValue ( ToValue(..) ) where import Protolude import GraphQL.Internal.Value -- * ToValue -- | Turn a Haskell value into a GraphQL value. class ToValue a where toValue :: a -> Value' ConstScalar instance ToValue (Value' ConstScalar) where toValue = identity -- XXX: Should this just be for Foldable? instance ToValue a => ToValue [a] where toValue = toValue . List' . map toValue -- TODO - tom still thinks that using Maybe for nullable is maybe not -- the best idea. instance ToValue a => ToValue (Maybe a) where toValue Nothing = ValueNull toValue (Just v) = toValue v instance ToValue a => ToValue (NonEmpty a) where toValue = toValue . makeList instance ToValue Bool where toValue = ValueBoolean instance ToValue Int32 where toValue = ValueInt instance ToValue Double where toValue = ValueFloat instance ToValue String where toValue = ValueString -- XXX: Make more generic: any string-like thing rather than just Text. instance ToValue Text where toValue = toValue . String instance ToValue List where toValue = ValueList' instance ToValue (Object' ConstScalar) where toValue = ValueObject' makeList :: (Functor f, Foldable f, ToValue a) => f a -> List makeList = List' . Protolude.toList . map toValue ================================================ FILE: src/GraphQL/Internal/Value.hs ================================================ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK not-home #-} -- | Description: Literal GraphQL values module GraphQL.Internal.Value ( Value , Value'(..) , ConstScalar , UnresolvedVariableValue , pattern ValueInt , pattern ValueFloat , pattern ValueBoolean , pattern ValueString , pattern ValueEnum , pattern ValueList , pattern ValueObject , pattern ValueNull , toObject , valueToAST , astToVariableValue , variableValueToAST , List , List'(..) , String(..) -- * Names , Name(..) , NameError(..) , makeName -- * Objects , Object , Object'(..) , ObjectField , ObjectField'(ObjectField) -- ** Constructing , makeObject , objectFromList , objectFromOrderedMap -- ** Combining , unionObjects -- ** Querying , objectFields ) where import Protolude import qualified Data.Aeson as Aeson import Data.Aeson (ToJSON(..), (.=), pairs) import qualified Data.Map as Map import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized) import GraphQL.Internal.Arbitrary (arbitraryText) import GraphQL.Internal.Name (Name(..), NameError(..), makeName) import GraphQL.Internal.Syntax.AST (Variable) import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.OrderedMap (OrderedMap) import qualified GraphQL.Internal.OrderedMap as OrderedMap -- * Values -- | A GraphQL value. @scalar@ represents the type of scalar that's contained -- within this value. -- -- Normally, it is one of either 'ConstScalar' (to indicate that there are no -- variables whatsoever) or 'VariableScalar' (to indicate that there might be -- some variables). data Value' scalar = ValueScalar' scalar | ValueList' (List' scalar) | ValueObject' (Object' scalar) deriving (Eq, Ord, Show, Functor) instance Foldable Value' where foldMap f (ValueScalar' scalar) = f scalar foldMap f (ValueList' values) = foldMap f values foldMap f (ValueObject' obj) = foldMap f obj instance Traversable Value' where traverse f (ValueScalar' x) = ValueScalar' <$> f x traverse f (ValueList' xs) = ValueList' <$> traverse f xs traverse f (ValueObject' xs) = ValueObject' <$> traverse f xs instance ToJSON scalar => ToJSON (Value' scalar) where toJSON (ValueScalar' x) = toJSON x toJSON (ValueList' x) = toJSON x toJSON (ValueObject' x) = toJSON x instance Arbitrary scalar => Arbitrary (Value' scalar) where -- | Generate an arbitrary value. Uses the generator's \"size\" property to -- determine maximum object depth. arbitrary = sized genValue -- | Generate an arbitrary value, with objects at most @n@ levels deep. genValue :: Arbitrary scalar => Int -> Gen (Value' scalar) genValue n | n <= 0 = arbitrary | otherwise = oneof [ ValueScalar' <$> arbitrary , ValueObject' <$> genObject (n - 1) , ValueList' . List' <$> listOf (genValue (n - 1)) ] -- | A GraphQL value which contains no variables. type Value = Value' ConstScalar -- TODO: These next two definitions are quite internal. We should move this -- module to Internal and then re-export the bits that end-users will use. -- -- | A GraphQL value which might contain some variables. These variables are -- not yet associated with -- (see also 'GraphQL.Internal.Validation.VariableDefinition'), -- which are provided in a different context. type UnresolvedVariableValue = Value' UnresolvedVariableScalar pattern ValueInt :: Int32 -> Value pattern ValueInt x = ValueScalar' (ConstInt x) pattern ValueFloat :: Double -> Value pattern ValueFloat x = ValueScalar' (ConstFloat x) pattern ValueBoolean :: Bool -> Value pattern ValueBoolean x = ValueScalar' (ConstBoolean x) pattern ValueString :: String -> Value pattern ValueString x = ValueScalar' (ConstString x) pattern ValueEnum :: Name -> Value pattern ValueEnum x = ValueScalar' (ConstEnum x) pattern ValueList :: forall t. List' t -> Value' t pattern ValueList x = ValueList' x pattern ValueObject :: forall t. Object' t -> Value' t pattern ValueObject x = ValueObject' x pattern ValueNull :: Value pattern ValueNull = ValueScalar' ConstNull -- | If a value is an object, return just that. Otherwise @Nothing@. toObject :: Value' scalar -> Maybe (Object' scalar) toObject (ValueObject' o) = pure o toObject _ = empty -- * Scalars -- | A non-variable value which contains no other values. data ConstScalar = ConstInt Int32 | ConstFloat Double | ConstBoolean Bool | ConstString String | ConstEnum Name | ConstNull deriving (Eq, Ord, Show) instance ToJSON ConstScalar where toJSON (ConstInt x) = toJSON x toJSON (ConstFloat x) = toJSON x toJSON (ConstBoolean x) = toJSON x toJSON (ConstString x) = toJSON x toJSON (ConstEnum x) = toJSON x toJSON ConstNull = Aeson.Null -- | A value which contains no other values, and might be a variable that -- might lack a definition. type UnresolvedVariableScalar = Either Variable ConstScalar -- | Generate an arbitrary scalar value. instance Arbitrary ConstScalar where arbitrary = oneof [ ConstInt <$> arbitrary , ConstFloat <$> arbitrary , ConstBoolean <$> arbitrary , ConstString <$> arbitrary , ConstEnum <$> arbitrary , pure ConstNull ] -- | Convert a constant scalar to an AST.Value constScalarToAST :: ConstScalar -> AST.Value constScalarToAST scalar = case scalar of ConstInt x -> AST.ValueInt x ConstFloat x -> AST.ValueFloat x ConstBoolean x -> AST.ValueBoolean x ConstString (String x) -> AST.ValueString (AST.StringValue x) ConstEnum x -> AST.ValueEnum x ConstNull -> AST.ValueNull -- | Convert a variable scalar to an AST.Value variableToAST :: UnresolvedVariableScalar -> AST.Value variableToAST (Left variable) = AST.ValueVariable variable variableToAST (Right constant) = constScalarToAST constant -- | Convert a value from the AST into a variable scalar, presuming it /is/ a -- scalar. astToScalar :: AST.Value -> Maybe UnresolvedVariableScalar astToScalar (AST.ValueInt x) = pure $ Right $ ConstInt x astToScalar (AST.ValueFloat x) = pure $ Right $ ConstFloat x astToScalar (AST.ValueBoolean x) = pure $ Right $ ConstBoolean x astToScalar (AST.ValueString (AST.StringValue x)) = pure $ Right $ ConstString (String x) astToScalar (AST.ValueEnum x) = pure $ Right $ ConstEnum x astToScalar AST.ValueNull = pure $ Right ConstNull astToScalar (AST.ValueVariable x) = pure $ Left x astToScalar _ = empty -- * Strings newtype String = String Text deriving (Eq, Ord, Show) instance Arbitrary String where arbitrary = String <$> arbitraryText instance ToJSON String where toJSON (String x) = toJSON x -- * Lists newtype List' scalar = List' [Value' scalar] deriving (Eq, Ord, Show, Functor) instance Foldable List' where foldMap f (List' values) = mconcat (map (foldMap f) values) instance Traversable List' where traverse f (List' xs) = List' <$> traverse (traverse f) xs -- | A list of values that are known to be constants. -- -- Note that this list might not be valid GraphQL, because GraphQL only allows -- homogeneous lists (i.e. all elements of the same type), and we do no type -- checking at this point. type List = List' ConstScalar instance Arbitrary scalar => Arbitrary (List' scalar) where -- TODO: GraphQL does not allow heterogeneous lists: -- https://facebook.github.io/graphql/#sec-Lists, so this will generate -- invalid lists. arbitrary = List' <$> listOf arbitrary instance ToJSON scalar => ToJSON (List' scalar) where toJSON (List' x) = toJSON x -- * Objects -- | A GraphQL object. -- -- Note that https://facebook.github.io/graphql/#sec-Response calls these -- \"Maps\", but everywhere else in the spec refers to them as objects. newtype Object' scalar = Object' (OrderedMap Name (Value' scalar)) deriving (Eq, Ord, Show, Functor) instance Foldable Object' where foldMap f (Object' fieldMap) = foldMap (foldMap f) fieldMap instance Traversable Object' where traverse f (Object' xs) = Object' <$> traverse (traverse f) xs -- | A GraphQL object that contains only non-variable values. type Object = Object' ConstScalar objectFields :: Object' scalar -> [ObjectField' scalar] objectFields (Object' object) = map (uncurry ObjectField') (OrderedMap.toList object) instance Arbitrary scalar => Arbitrary (Object' scalar) where arbitrary = sized genObject -- | Generate an arbitrary object to the given maximum depth. genObject :: Arbitrary scalar => Int -> Gen (Object' scalar) genObject n = Object' <$> OrderedMap.genOrderedMap arbitrary (genValue n) data ObjectField' scalar = ObjectField' Name (Value' scalar) deriving (Eq, Ord, Show, Functor) -- | A field of an object that has a non-variable value. type ObjectField = ObjectField' ConstScalar pattern ObjectField :: forall t. Name -> Value' t -> ObjectField' t pattern ObjectField name value = ObjectField' name value instance Arbitrary scalar => Arbitrary (ObjectField' scalar) where arbitrary = ObjectField' <$> arbitrary <*> arbitrary -- | Make an object from a list of object fields. makeObject :: [ObjectField' scalar] -> Maybe (Object' scalar) makeObject fields = objectFromList [(name, value) | ObjectField' name value <- fields] -- | Make an object from an ordered map. objectFromOrderedMap :: OrderedMap Name (Value' scalar) -> Object' scalar objectFromOrderedMap = Object' -- | Create an object from a list of (name, value) pairs. objectFromList :: [(Name, Value' scalar)] -> Maybe (Object' scalar) objectFromList xs = Object' <$> OrderedMap.orderedMap xs unionObjects :: [Object' scalar] -> Maybe (Object' scalar) unionObjects objects = Object' <$> OrderedMap.unions [obj | Object' obj <- objects] instance ToJSON scalar => ToJSON (Object' scalar) where -- Direct encoding to preserve order of keys / values toJSON (Object' xs) = toJSON (Map.fromList [(unName k, v) | (k, v) <- OrderedMap.toList xs]) toEncoding (Object' xs) = pairs (foldMap (\(k, v) -> toS (unName k) .= v) (OrderedMap.toList xs)) -- * Conversion to and from AST. -- | Convert an AST value into a literal value. -- -- This is a stop-gap until we have proper conversion of user queries into -- canonical forms. astToValue' :: (AST.Value -> scalar) -> AST.Value -> Maybe (Value' scalar) astToValue' f x@(AST.ValueInt _) = pure (ValueScalar' (f x)) astToValue' f x@(AST.ValueFloat _) = pure (ValueScalar' (f x)) astToValue' f x@(AST.ValueBoolean _) = pure (ValueScalar' (f x)) astToValue' f x@(AST.ValueString (AST.StringValue _)) = pure (ValueScalar' (f x)) astToValue' f x@(AST.ValueEnum _) = pure (ValueScalar' (f x)) astToValue' f AST.ValueNull = pure (ValueScalar' (f AST.ValueNull)) astToValue' f x@(AST.ValueVariable _) = pure (ValueScalar' (f x)) astToValue' f (AST.ValueList (AST.ListValue xs)) = ValueList' . List' <$> traverse (astToValue' f) xs astToValue' f (AST.ValueObject (AST.ObjectValue fields)) = do fields' <- traverse toObjectField fields object <- makeObject fields' pure (ValueObject' object) where toObjectField (AST.ObjectField name value) = ObjectField' name <$> astToValue' f value -- | Convert an AST value to a variable value. -- -- Will fail if the AST value contains duplicate object fields, or is -- otherwise invalid. astToVariableValue :: HasCallStack => AST.Value -> Maybe UnresolvedVariableValue astToVariableValue ast = astToValue' convertScalar ast where convertScalar x = case astToScalar x of Just scalar -> scalar Nothing -> panic ("Non-scalar passed to convertScalar, bug in astToValue': " <> show x) -- | Convert a value to an AST value. valueToAST :: Value -> AST.Value valueToAST = valueToAST' constScalarToAST -- | Convert a variable value to an AST value. variableValueToAST :: UnresolvedVariableValue -> AST.Value variableValueToAST = valueToAST' variableToAST -- | Convert a literal value into an AST value. -- -- Nulls are converted into Nothing. -- -- This function probably isn't particularly useful, but it functions as a -- stop-gap until we have QuickCheck generators for the AST. valueToAST' :: (scalar -> AST.Value) -> Value' scalar -> AST.Value valueToAST' f (ValueScalar' x) = f x valueToAST' f (ValueList' (List' xs)) = AST.ValueList (AST.ListValue (map (valueToAST' f) xs)) valueToAST' f (ValueObject' (Object' fields)) = AST.ValueObject (AST.ObjectValue (map toObjectField (OrderedMap.toList fields))) where toObjectField (name, value) = AST.ObjectField name (valueToAST' f value) ================================================ FILE: src/GraphQL/Resolver.hs ================================================ -- | Description: Implement handlers for GraphQL schemas -- -- Contains everything you need to write handlers for your GraphQL schema. module GraphQL.Resolver ( module Export ) where import GraphQL.Internal.Resolver as Export ( ResolverError(..) , HasResolver(..) , OperationResolverConstraint , (:<>)(..) , Result(..) , unionValue , resolveOperation , returns , handlerError ) ================================================ FILE: src/GraphQL/Value.hs ================================================ -- | Description: Literal GraphQL values {-# LANGUAGE PatternSynonyms #-} module GraphQL.Value ( Value , Value'(..) , ConstScalar , UnresolvedVariableValue , pattern ValueInt , pattern ValueFloat , pattern ValueBoolean , pattern ValueString , pattern ValueEnum , pattern ValueList , pattern ValueObject , pattern ValueNull , toObject , valueToAST , astToVariableValue , variableValueToAST , List , List'(..) , String(..) -- * Names , Name(..) , NameError(..) , makeName -- * Objects , Object , Object'(..) , ObjectField , ObjectField'(ObjectField) -- ** Constructing , makeObject , objectFromList , objectFromOrderedMap -- ** Combining , unionObjects -- ** Querying , objectFields -- * Converting to and from Value , ToValue(..) , FromValue(..) ) where import GraphQL.Internal.Value ( Value , Value'(..) , ConstScalar , UnresolvedVariableValue , pattern ValueInt , pattern ValueFloat , pattern ValueBoolean , pattern ValueString , pattern ValueEnum , pattern ValueList , pattern ValueObject , pattern ValueNull , toObject , valueToAST , astToVariableValue , variableValueToAST , List , List'(..) , String(..) , Name(..) , NameError(..) , makeName , Object , Object'(..) , ObjectField , ObjectField'(ObjectField) , makeObject , objectFromList , objectFromOrderedMap , unionObjects , objectFields ) import GraphQL.Internal.Value.FromValue ( FromValue(..) ) import GraphQL.Internal.Value.ToValue ( ToValue(..) ) ================================================ FILE: src/GraphQL.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | Interface for GraphQL API. -- -- __Note__: This module is highly subject to change. We're still figuring -- where to draw the lines and what to expose. module GraphQL ( -- * Running queries interpretQuery , interpretAnonymousQuery , Response(..) -- * Preparing queries then running them , makeSchema , compileQuery , executeQuery , QueryError , Schema , VariableValues , Value ) where import Protolude import Data.Attoparsec.Text (parseOnly, endOfInput) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import GraphQL.API (HasObjectDefinition(..), Object, SchemaError(..)) import GraphQL.Internal.Execution ( VariableValues , ExecutionError , substituteVariables ) import qualified GraphQL.Internal.Execution as Execution import qualified GraphQL.Internal.Syntax.AST as AST import qualified GraphQL.Internal.Syntax.Parser as Parser import GraphQL.Internal.Validation ( QueryDocument , SelectionSetByType , ValidationErrors , validate , getSelectionSet , VariableValue ) import GraphQL.Internal.Output ( GraphQLError(..) , Response(..) , singleError ) import GraphQL.Internal.Schema (Schema) import qualified GraphQL.Internal.Schema as Schema import GraphQL.Resolver ( HasResolver(..) , OperationResolverConstraint , Result(..) , resolveOperation ) import GraphQL.Value (Name, Value) -- | Errors that can happen while processing a query document. data QueryError -- | Failed to parse. = ParseError Text -- | Parsed, but failed validation. -- -- See for more -- details. | ValidationError ValidationErrors -- | Validated, but failed during execution. | ExecutionError ExecutionError -- | Error in the schema. | SchemaError SchemaError -- | Got a value that wasn't an object. | NonObjectResult Value deriving (Eq, Show) instance GraphQLError QueryError where formatError (ParseError e) = "Couldn't parse query document: " <> e formatError (ValidationError es) = "Validation errors:\n" <> mconcat [" " <> formatError e <> "\n" | e <- NonEmpty.toList es] formatError (ExecutionError e) = "Execution error: " <> show e formatError (SchemaError e) = "Schema error: " <> formatError e formatError (NonObjectResult v) = "Query returned a value that is not an object: " <> show v -- | Execute a GraphQL query. executeQuery :: forall api m fields typeName interfaces. ( Object typeName interfaces fields ~ api , OperationResolverConstraint m fields typeName interfaces ) => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. -> QueryDocument VariableValue -- ^ A validated query document. Build one with 'compileQuery'. -> Maybe Name -- ^ An optional name. If 'Nothing', then executes the only operation in the query. If @Just "something"@, executes the query named @"something". -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'. -> m Response -- ^ The outcome of running the query. executeQuery handler document name variables = case getOperation document name variables of Left e -> pure (ExecutionFailure (singleError e)) Right operation -> toResult <$> resolveOperation @m @fields @typeName @interfaces handler operation where toResult (Result errors object) = case NonEmpty.nonEmpty errors of Nothing -> Success object Just errs -> PartialSuccess object (map toError errs) -- | Create a GraphQL schema. makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema makeSchema = first SchemaError (Schema.makeSchema <$> getDefinition @api) -- | Interpet a GraphQL query. -- -- Compiles then executes a GraphQL query. interpretQuery :: forall api m fields typeName interfaces. ( Object typeName interfaces fields ~ api , OperationResolverConstraint m fields typeName interfaces ) => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. -> Text -- ^ The text of a query document. Will be parsed and then executed. -> Maybe Name -- ^ An optional name for the operation within document to run. If 'Nothing', execute the only operation in the document. If @Just "something"@, execute the query or mutation named @"something"@. -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'. -> m Response -- ^ The outcome of running the query. interpretQuery handler query name variables = case makeSchema @api >>= flip compileQuery query of Left err -> pure (PreExecutionFailure (toError err :| [])) Right document -> executeQuery @api @m handler document name variables -- | Interpret an anonymous GraphQL query. -- -- Anonymous queries have no name and take no variables. interpretAnonymousQuery :: forall api m fields typeName interfaces. ( Object typeName interfaces fields ~ api , OperationResolverConstraint m fields typeName interfaces ) => Handler m api -- ^ Handler for the anonymous query. -> Text -- ^ The text of the anonymous query. Should defined only a single, unnamed query operation. -> m Response -- ^ The result of running the query. interpretAnonymousQuery handler query = interpretQuery @api @m handler query Nothing mempty -- | Turn some text into a valid query document. compileQuery :: Schema -> Text -> Either QueryError (QueryDocument VariableValue) compileQuery schema query = do parsed <- first ParseError (parseQuery query) first ValidationError (validate schema parsed) -- | Parse a query document. parseQuery :: Text -> Either Text AST.QueryDocument parseQuery query = first toS (parseOnly (Parser.queryDocument <* endOfInput) query) -- | Get an operation from a query document ready to be processed. getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (SelectionSetByType Value) getOperation document name vars = first ExecutionError $ do op <- Execution.getOperation document name resolved <- substituteVariables op vars pure (getSelectionSet resolved) ================================================ FILE: stack-8.0.yaml ================================================ # GHC 8.0.2 is the lowest supported compiler version. resolver: lts-9.21 packages: - "." - "./docs/source/tutorial" - "./graphql-wai" extra-deps: - protolude-0.2.1 ================================================ FILE: stack-8.2.yaml ================================================ # LTS 10.4 is the latest LTS that supports GHC 8.2 at the time of writing. resolver: lts-10.4 packages: - "." - "./docs/source/tutorial" - "./graphql-wai" ================================================ FILE: tests/ASTSpec.hs ================================================ {-# LANGUAGE QuasiQuotes #-} -- | Tests for AST, including parser and encoder. module ASTSpec (spec) where import Protolude import Data.Attoparsec.Text (parseOnly) import Text.RawString.QQ (r) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (arbitrary, forAll, resize) import Test.Hspec import GraphQL.Value (String(..)) import GraphQL.Internal.Name (Name) import qualified GraphQL.Internal.Syntax.AST as AST import qualified GraphQL.Internal.Syntax.Parser as Parser import qualified GraphQL.Internal.Syntax.Encoder as Encoder kitchenSink :: Text kitchenSink = "query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:\"value\"})}\n" dog :: Name dog = "dog" someName :: Name someName = "name" spec :: Spec spec = describe "AST" $ do describe "Parser and encoder" $ do it "roundtrips on minified documents" $ do let actual = Encoder.queryDocument <$> parseOnly Parser.queryDocument kitchenSink actual `shouldBe` Right kitchenSink describe "parsing numbers" $ do it "works for some integers" $ do parseOnly Parser.value "1" `shouldBe` Right (AST.ValueInt 1) prop "works for all integers" $ do \x -> parseOnly Parser.value (show x) == Right (AST.ValueInt x) it "works for some floats" $ do parseOnly Parser.value "1.5" `shouldBe` Right (AST.ValueFloat 1.5) it "treats floats as floats even if they end with .0" $ do parseOnly Parser.value "0.0" `shouldBe` Right (AST.ValueFloat 0.0) prop "works for floats" $ do \x -> parseOnly Parser.value (show x) == Right (AST.ValueFloat x) describe "strings" $ do prop "works for all strings" $ do \(String x) -> let input = AST.ValueString (AST.StringValue x) output = Encoder.value input in parseOnly Parser.value output == Right input it "handles unusual strings" $ do let input = AST.ValueString (AST.StringValue "\fh\244") let output = Encoder.value input -- \f is \u000c output `shouldBe` "\"\\u000ch\244\"" parseOnly Parser.value output `shouldBe` Right input describe "parsing values" $ do prop "works for all literal values" $ do forAll (resize 3 arbitrary) $ \x -> parseOnly Parser.value (Encoder.value x) `shouldBe` Right x it "parses ununusual objects" $ do let input = AST.ValueObject (AST.ObjectValue [ AST.ObjectField "s" (AST.ValueString (AST.StringValue "\224\225v^6{FPDk\DC3\a")), AST.ObjectField "Hsr" (AST.ValueInt 0) ]) let output = Encoder.value input parseOnly Parser.value output `shouldBe` Right input it "parses lists of floats" $ do let input = AST.ValueList (AST.ListValue [ AST.ValueFloat 1.5 , AST.ValueFloat 1.5 ]) let output = Encoder.value input output `shouldBe` "[1.5,1.5]" parseOnly Parser.value output `shouldBe` Right input describe "Parser" $ do it "parses shorthand syntax documents" $ do let query = [r|{ dog { name } }|] let Right parsed = parseOnly Parser.queryDocument query let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.AnonymousQuery [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ]) ]) ] parsed `shouldBe` expected it "parses anonymous query documents" $ do let query = [r|query { dog { name } }|] let Right parsed = parseOnly Parser.queryDocument query let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ]) ])) ] parsed `shouldBe` expected it "errors on missing selection set" $ do let query = [r|query { dog { } }|] let Left parsed = parseOnly Parser.queryDocument query -- this is not very explicit parsed `shouldBe` "query document error! > definition error!: string" it "parses invalid documents" $ do let query = [r|{ dog { name } } query getName { dog { owner { name } } }|] let Right parsed = parseOnly Parser.queryDocument query let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.AnonymousQuery [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ]) ]) , AST.DefinitionOperation (AST.Query (AST.Node (pure "getName") [] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "owner" [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ]) ]) ])) ] parsed `shouldBe` expected it "includes variable definitions" $ do let query = [r| query houseTrainedQuery($atOtherHomes: Boolean = true) { dog { isHousetrained(atOtherHomes: $atOtherHomes) } } |] let Right parsed = parseOnly Parser.queryDocument query let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node (pure "houseTrainedQuery") [ AST.VariableDefinition (AST.Variable "atOtherHomes") (AST.TypeNamed (AST.NamedType "Boolean")) (Just (AST.ValueBoolean True)) ] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "isHousetrained" [ AST.Argument "atOtherHomes" (AST.ValueVariable (AST.Variable "atOtherHomes")) ] [] []) ]) ])) ] parsed `shouldBe` expected it "parses anonymous query with variables" $ do let query = [r| query ($atOtherHomes: Boolean = true) { dog { isHousetrained(atOtherHomes: $atOtherHomes) } } |] let Right parsed = parseOnly Parser.queryDocument query let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [ AST.VariableDefinition (AST.Variable "atOtherHomes") (AST.TypeNamed (AST.NamedType "Boolean")) (Just (AST.ValueBoolean True)) ] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "isHousetrained" [ AST.Argument "atOtherHomes" (AST.ValueVariable (AST.Variable "atOtherHomes")) ] [] []) ]) ])) ] parsed `shouldBe` expected it "parses anonymous query with variable annotation" $ do let query = [r| query ($atOtherHomes: [Home!]) { dog { isHousetrained(atOtherHomes: $atOtherHomes) } } |] let Right parsed = parseOnly Parser.queryDocument query let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [ AST.VariableDefinition (AST.Variable "atOtherHomes") (AST.TypeList (AST.ListType (AST.TypeNonNull (AST.NonNullTypeNamed (AST.NamedType "Home")) ) ) ) Nothing ] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "isHousetrained" [ AST.Argument "atOtherHomes" (AST.ValueVariable (AST.Variable "atOtherHomes")) ] [] []) ]) ])) ] parsed `shouldBe` expected it "parses anonymous query with inline argument (List, Object, Enum, String, Number)" $ do -- keys are not quoted for inline objects let query = [r| query { dog { isHousetrained(atOtherHomes: [{testKey: 123, anotherKey: "string"}]) } } |] let Right parsed = parseOnly Parser.queryDocument query let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "isHousetrained" [ AST.Argument "atOtherHomes" (AST.ValueList (AST.ListValue [ (AST.ValueObject (AST.ObjectValue [ (AST.ObjectField "testKey" (AST.ValueInt 123)), (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string"))) ])) ])) ] [] []) ]) ])) ] parsed `shouldBe` expected it "parses anonymous query with fragment" $ do -- keys are not quoted for inline objects let query = [r| fragment dogTest on Dog { name } query { dog { ...dogTest } } |] let Right parsed = parseOnly Parser.queryDocument query let expected = AST.QueryDocument [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest" (AST.NamedType "Dog") [] [ AST.SelectionField (AST.Field Nothing "name" [] [] []) ])), (AST.DefinitionOperation (AST.Query (AST.Node Nothing [] [] [AST.SelectionField (AST.Field Nothing dog [] [] [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" []) ]) ]))) ] parsed `shouldBe` expected ================================================ FILE: tests/EndToEndSpec.hs ================================================ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeOperators #-} -- | Tests that span the entire system. -- -- These tests function both as examples of how to use the API, as well as -- sanity checks on our reasoning. module EndToEndSpec (spec) where import Protolude import Data.Aeson (Value(Null), toJSON, object, (.=)) import qualified Data.Map as Map import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery) import GraphQL.API (Object, Field, List, Argument, (:>), Defaultable(..), HasAnnotatedInputType(..)) import GraphQL.Internal.Syntax.AST (Variable(..)) import GraphQL.Resolver ((:<>)(..), Handler, unionValue, returns) import GraphQL.Value (ToValue(..), FromValue(..), makeName) import Test.Hspec import Text.RawString.QQ (r) import ExampleSchema -- | Example query root. -- -- @ -- type QueryRoot { -- dog: Dog -- describeDog(dog: DEFAULT): String -- } -- @ -- -- Drawn from . type QueryRoot = Object "QueryRoot" '[] '[ Field "dog" Dog , Argument "dog" DogStuff :> Field "describeDog" Text , Field "catOrDog" CatOrDog , Field "catOrDogList" (List CatOrDog) ] -- | An object that is passed as an argument. i.e. an input object. -- -- TODO: Ideally this would be Dog itself, or ServerDog at worst. -- Unfortunately, jml cannot figure out how to do that. data DogStuff = DogStuff { toy :: Text, likesTreats :: Bool } deriving (Show, Generic) instance FromValue DogStuff instance HasAnnotatedInputType DogStuff instance Defaultable DogStuff where defaultFor "dog" = pure DogStuff { toy = "shoe", likesTreats = False } defaultFor _ = empty catOrDog :: Handler IO CatOrDog catOrDog = do name <- pure "MonadicFelix" -- we can do monadic actions unionValue @Cat (catHandler name Nothing 15) catOrDogList :: Handler IO (List CatOrDog) catOrDogList = returns [ unionValue @Cat (catHandler "Felix the Cat" (Just "felix") 42) , unionValue @Cat (catHandler "Henry" Nothing 10) , unionValue @Dog (viewServerDog mortgage) ] catHandler :: Text -> Maybe Text -> Int32 -> Handler IO Cat catHandler name nickName meowVolume = pure $ returns name :<> returns (returns <$> nickName) :<> returns . const False :<> -- doesn't know any commands returns meowVolume -- | Our server's internal representation of a 'Dog'. data ServerDog = ServerDog { name :: Text , nickname :: Maybe Text , barkVolume :: Int32 , knownCommands :: Set DogCommand , houseTrainedAtHome :: Bool , houseTrainedElsewhere :: Bool , owner :: ServerHuman } -- | Whether 'ServerDog' knows the given command. doesKnowCommand :: ServerDog -> DogCommand -> Bool doesKnowCommand dog command = command `elem` knownCommands dog -- | Whether 'ServerDog' is house-trained. isHouseTrained :: ServerDog -> Maybe Bool -> Bool isHouseTrained dog Nothing = houseTrainedAtHome dog || houseTrainedElsewhere dog isHouseTrained dog (Just False) = houseTrainedAtHome dog isHouseTrained dog (Just True) = houseTrainedElsewhere dog -- | Present 'ServerDog' for GraphQL. viewServerDog :: ServerDog -> Handler IO Dog viewServerDog dog@ServerDog{..} = pure $ returns name :<> returns (fmap returns nickname) :<> returns barkVolume :<> returns . doesKnowCommand dog :<> returns . isHouseTrained dog :<> viewServerHuman owner describeDog :: DogStuff -> Handler IO Text describeDog (DogStuff toy likesTreats) | likesTreats = returns $ "likes treats and their favorite toy is a " <> toy | otherwise = returns $ "their favorite toy is a " <> toy rootHandler :: ServerDog -> Handler IO QueryRoot rootHandler dog = pure $ viewServerDog dog :<> describeDog :<> catOrDog :<> catOrDogList -- | jml has a stuffed black dog called "Mortgage". mortgage :: ServerDog mortgage = ServerDog { name = "Mortgage" , nickname = Just "Mort" , barkVolume = 0 -- He's stuffed , knownCommands = mempty -- He's stuffed , houseTrainedAtHome = True -- Never been a problem , houseTrainedElsewhere = True -- Untested in the field , owner = jml } -- | Our server's internal representation of a 'Human'. newtype ServerHuman = ServerHuman Text deriving (Eq, Ord, Show, Generic) -- | Present a 'ServerHuman' as a GraphQL 'Human'. viewServerHuman :: ServerHuman -> Handler IO Human viewServerHuman (ServerHuman name) = pure (returns name) -- | It me. jml :: ServerHuman jml = ServerHuman "jml" spec :: Spec spec = describe "End-to-end tests" $ do describe "interpretAnonymousQuery" $ do it "Handles the simplest possible valid query" $ do let query = [r|{ dog { name } } |] response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) ] ] ] toJSON (toValue response) `shouldBe` expected it "Handles more than one field" $ do let query = [r|{ dog { name barkVolume } } |] response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) , "barkVolume" .= (0 :: Int32) ] ] ] toJSON (toValue response) `shouldBe` expected it "Handles nested queries" $ do let query = [r|{ dog { name owner { name } } } |] response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) , "owner" .= object [ "name" .= ("jml" :: Text) ] ] ] ] toJSON (toValue response) `shouldBe` expected it "It aliases fields" $ do let query = [r|{ dog { name boss: owner { name } } } |] response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) , "boss" .= object [ "name" .= ("jml" :: Text) ] ] ] ] toJSON (toValue response) `shouldBe` expected it "Passes arguments to functions" $ do let query = [r|{ dog { name doesKnowCommand(dogCommand: Sit) } } |] response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) , "doesKnowCommand" .= False ] ] ] toJSON (toValue response) `shouldBe` expected it "Passes arguments that are objects to functions" $ do let query = [r|{ describeDog(dog: {toy: "bone", likesTreats: true}) } |] response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "describeDog" .= ("likes treats and their favorite toy is a bone" :: Text) ] ] toJSON (toValue response) `shouldBe` expected it "Passes default arguments that are objects to functions" $ do let query = [r|{ describeDog } |] response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "describeDog" .= ("their favorite toy is a shoe" :: Text) ] ] toJSON (toValue response) `shouldBe` expected it "Handles fairly complex queries" $ do let query = [r|{ dog { callsign: name ... on Dog { callsign: name me: owner { ... on Sentient { name } ... on Human { name } name } } } } |] response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "dog" .= object [ "callsign" .= ("Mortgage" :: Text) , "me" .= object [ "name" .= ("jml" :: Text) ] ] ] ] toJSON (toValue response) `shouldBe` expected it "Lets you query union types" $ do let query = "{ catOrDog { ... on Cat { name meowVolume } ... on Dog { barkVolume } } }" response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "catOrDog" .= object [ "name" .= ("MonadicFelix" :: Text) , "meowVolume" .= (15 :: Float) ] ] ] toJSON (toValue response) `shouldBe` expected it "Lets you query lists of union types" $ do let query = "{ catOrDogList { ... on Cat { name meowVolume } ... on Dog { barkVolume } } }" response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query let expected = object [ "data" .= object [ "catOrDogList" .= [ object [ "name" .= ("Felix the Cat" :: Text) , "meowVolume" .= (42 :: Float) ] , object [ "name" .= ("Henry" :: Text) , "meowVolume" .= (10 :: Float) ] , object [ "barkVolume" .= (0 :: Float) ] ] ] ] toJSON (toValue response) `shouldBe` expected describe "interpretQuery" $ do it "Handles the simplest named query" $ do let query = [r|query myQuery { dog { name } } |] response <- interpretQuery @QueryRoot (rootHandler mortgage) query Nothing mempty let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) ] ] ] toJSON (toValue response) `shouldBe` expected it "Allows calling query by name" $ do let query = [r|query myQuery { dog { name } } |] let Right name = makeName "myQuery" response <- interpretQuery @QueryRoot (rootHandler mortgage) query (Just name) mempty let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) ] ] ] toJSON (toValue response) `shouldBe` expected describe "Handles variables" $ do let Right schema = makeSchema @Dog let Right query = compileQuery schema [r|query myQuery($whichCommand: DogCommand) { dog { name doesKnowCommand(dogCommand: $whichCommand) } } |] let Right annotatedQuery = compileQuery schema [r|query myQuery($whichCommand: DogCommand!) { dog { name doesKnowCommand(dogCommand: $whichCommand) } } |] let Right badQuery = compileQuery schema [r|query myQuery($whichCommand: String!) { dog { name doesKnowCommand(dogCommand: $whichCommand) } } |] it "Errors when variable and argument types are in conflict" $ do let vars = Map.singleton (Variable "whichCommand") $ toValue @Text "cow" response <- executeQuery @QueryRoot (rootHandler mortgage) badQuery Nothing vars let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) , "doesKnowCommand" .= Null ] ] , "errors" .= [ object -- TODO: This error message is pretty bad. We should define -- a typeclass for client-friendly "Show" (separate from -- actual Show which remains extremely useful for debugging) -- and use that when including values in error messages. [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' (ConstString (String \"cow\")) not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text) ] ] ] toJSON (toValue response) `shouldBe` expected it "Errors when no variables provided" $ do response <- executeQuery @QueryRoot (rootHandler mortgage) query Nothing mempty let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) , "doesKnowCommand" .= Null ] ] , "errors" .= [ object [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' ConstNull not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text) ] ] ] toJSON (toValue response) `shouldBe` expected it "Substitutes variables when they are provided" $ do -- TODO: This is a crummy way to make a variable map. jml doesn't want -- to come up with a new API in this PR, but probably we should have a -- very simple function to turn a JSON value / object into the -- variable map that we desire. Alternatively, we should have APIs -- like Aeson does. -- let Right varName = makeName "whichCommand" let vars = Map.singleton (Variable varName) (toValue Sit) response <- executeQuery @QueryRoot (rootHandler mortgage) query Nothing vars let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) , "doesKnowCommand" .= False ] ] ] toJSON (toValue response) `shouldBe` expected it "Substitutes annotated variables when they are provided" $ do let Right varName = makeName "whichCommand" let vars = Map.singleton (Variable varName) (toValue Sit) response <- executeQuery @QueryRoot (rootHandler mortgage) annotatedQuery Nothing vars let expected = object [ "data" .= object [ "dog" .= object [ "name" .= ("Mortgage" :: Text) , "doesKnowCommand" .= False ] ] ] toJSON (toValue response) `shouldBe` expected it "Errors when non-null variable is not provided" $ do response <- executeQuery @QueryRoot (rootHandler mortgage) annotatedQuery Nothing mempty let expected = object [ "data" .= Null , "errors" .= [ object [ "message" .= ("Execution error: MissingValue (Variable (Name {unName = \"whichCommand\"}))" :: Text) ] ] ] toJSON (toValue response) `shouldBe` expected ================================================ FILE: tests/EnumTests.hs ================================================ {-# LANGUAGE DeriveGeneric #-} module EnumTests ( Mode(Directory, NormalFile, ExecutableFile, Symlink) ) where import Protolude hiding (Enum) import GraphQL.API (GraphQLEnum) -- https://github.com/jml/graphql-api/issues/116 -- Generic enum code is broken data Mode = Directory | NormalFile | ExecutableFile | Symlink deriving (Show, Eq, Generic) instance GraphQLEnum Mode ================================================ FILE: tests/ExampleSchema.hs ================================================ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -- | An example GraphQL schema, used in our end-to-end tests. -- -- Based on the example schema given in the GraphQL spec. See -- . -- -- Here's the full schema: -- -- @ -- enum DogCommand { SIT, DOWN, HEEL } -- -- type Dog implements Pet { -- name: String! -- nickname: String -- barkVolume: Int -- doesKnowCommand(dogCommand: DogCommand!): Boolean! -- isHousetrained(atOtherHomes: Boolean): Boolean! -- owner: Human -- } -- -- interface Sentient { -- name: String! -- } -- -- interface Pet { -- name: String! -- } -- -- type Alien implements Sentient { -- name: String! -- homePlanet: String -- } -- -- type Human implements Sentient { -- name: String! -- } -- -- enum CatCommand { JUMP } -- -- type Cat implements Pet { -- name: String! -- nickname: String -- doesKnowCommand(catCommand: CatCommand!): Boolean! -- meowVolume: Int -- } -- -- union CatOrDog = Cat | Dog -- union DogOrHuman = Dog | Human -- union HumanOrAlien = Human | Alien -- @ -- -- Unlike the spec, we don't define a @QueryRoot@ type here, instead -- encouraging test modules to define their own as appropriate to their needs. -- -- We'll repeat bits of the schema below, explaining how they translate into -- Haskell as we go. module ExampleSchema ( DogCommand(..) , Dog , Sentient , Pet , Alien , Human , CatCommand(..) , Cat , CatOrDog , DogOrHuman , HumanOrAlien ) where import Protolude hiding (Enum) import GraphQL.API ( GraphQLEnum(..) , Enum , Object , Field , Argument , Interface , Union , (:>) , Defaultable(..) ) import GraphQL.Value ( pattern ValueEnum , unName , ToValue(..) ) -- | A command that can be given to a 'Dog'. -- -- @ -- enum DogCommand { SIT, DOWN, HEEL } -- @ -- -- To define this in Haskell we need to do three things: -- -- 1. Define a sum type with nullary constructors to represent the enum -- (here, 'DogCommandEnum') -- 2. Make it an instance of 'GraphQLEnum' -- 3. Wrap the sum type in 'Enum', e.g. @Enum "DogCommand" DogCommandEnum@ -- so it can be placed in a schema. data DogCommand = Sit | Down | Heel deriving (Show, Eq, Ord, Generic) instance Defaultable DogCommand where -- Explicitly want no default for dogCommand defaultFor (unName -> "dogCommand") = Nothing -- DogCommand shouldn't be used elsewhere in schema, but who can say? defaultFor _ = Nothing instance GraphQLEnum DogCommand -- TODO: Probably shouldn't have to do this for enums. instance ToValue DogCommand where toValue = ValueEnum . enumToValue -- | A dog. -- -- This is an example of a GraphQL \"object\". -- -- @ -- type Dog implements Pet { -- name: String! -- nickname: String -- barkVolume: Int -- doesKnowCommand(dogCommand: DogCommand!): Boolean! -- isHousetrained(atOtherHomes: Boolean): Boolean! -- owner: Human -- } -- @ -- -- To define it in Haskell, we use 'Object'. The first argument is the name of -- the object (here, @"Dog"@). The second is a list of interfaces implemented -- by the object (here, only 'Pet'). -- -- The third, final, and most interesting argument is the list of fields the -- object has. Fields can look one of two ways: -- -- @ -- Field "name" Text -- @ -- -- for a field that takes no arguments. This field would be called @name@ and -- is guaranteed to return some text if queried. -- -- A field that takes arguments looks like this: -- -- @ -- Argument "dogCommand" DogCommand :> Field "doesKnowCommand" Bool -- @ -- -- Here, the field is named @doesKnowCommand@ and it takes a single -- argument--a 'DogCommand'--and returns a 'Bool'. Note that this is in -- reverse order to the GraphQL schema, which represents this field as: -- -- @ -- doesKnowCommand(dogCommand: DogCommand!): Boolean! -- @ -- -- Also note that all fields and arguments are "non-null" by default. If you -- want a field to be nullable, give it a 'Maybe' type, e.g. -- -- @ -- nickname: String -- @ -- -- @nickname@ is nullable, so we represent the field in Haskell as: -- -- @ -- Field "nickname" (Maybe Text) -- @ type Dog = Object "Dog" '[Pet] '[ Field "name" Text , Field "nickname" (Maybe Text) , Field "barkVolume" Int32 , Argument "dogCommand" (Enum "DogCommand" DogCommand) :> Field "doesKnowCommand" Bool , Argument "atOtherHomes" (Maybe Bool) :> Field "isHouseTrained" Bool , Field "owner" Human ] -- | Sentient beings have names. -- -- This defines an interface, 'Sentient', that objects can implement. -- -- @ -- interface Sentient { -- name: String! -- } -- @ type Sentient = Interface "Sentient" '[Field "name" Text] -- | Pets have names too. -- -- This defines an interface, 'Pet', that objects can implement. -- -- @ -- interface Pet { -- name: String! -- } -- @ type Pet = Interface "Pet" '[Field "name" Text] -- | An alien. -- -- See 'Dog' for more details on how to define an object type for GraphQL. -- -- @ -- type Alien implements Sentient { -- name: String! -- homePlanet: String -- } -- @ type Alien = Object "Alien" '[Sentient] '[ Field "name" Text , Field "homePlanet" (Maybe Text) ] -- | Humans are sentient. -- -- See 'Dog' for more details on how to define an object type for GraphQL. -- -- @ -- type Human implements Sentient { -- name: String! -- } -- @ type Human = Object "Human" '[Sentient] '[ Field "name" Text ] -- TODO: Extend example to cover unions, interfaces and lists by giving humans -- a list of pets and a list of cats & dogs. -- | Cats can jump. -- -- See 'DogCommandEnum' for more details on defining an enum for GraphQL. -- -- The interesting thing about 'CatCommandEnum' is that it's an enum that has -- only one possible value. -- -- @ -- enum CatCommand { JUMP } -- @ data CatCommand = Jump deriving Generic instance Defaultable CatCommand where defaultFor _ = empty instance GraphQLEnum CatCommand -- | A cat. -- -- See 'Dog' for more details on how to define an object type for GraphQL. -- -- @ -- type Cat implements Pet { -- name: String! -- nickname: String -- doesKnowCommand(catCommand: CatCommand!): Boolean! -- meowVolume: Int -- } -- @ type Cat = Object "Cat" '[Pet] '[ Field "name" Text , Field "nickName" (Maybe Text) , Argument "catCommand" (Enum "CatCommand" CatCommand) :> Field "doesKnowCommand" Bool , Field "meowVolume" Int32 ] -- | Either a cat or a dog. (Pick dog, dogs are awesome). -- -- A 'Union' is used when you want to return one of short list of known -- types. -- -- You define them in GraphQL like so: -- -- @ -- union CatOrDog = Cat | Dog -- @ -- -- To translate this to Haskell, define a new type using 'Union'. The first -- argument is the name of the union, here @"CatOrDog"@, and the second -- argument is the list of possible types of the union. These must be objects, -- defined with 'Object'. type CatOrDog = Union "CatOrDog" '[Cat, Dog] -- | Either a dog or a human. (Pick dog, dogs are awesome). -- -- See 'CatOrDog' for more details on defining a union. -- -- @ -- union DogOrHuman = Dog | Human -- @ type DogOrHuman = Union "DogOrHuman" '[Dog, Human] -- | Either a human or an alien. (Pick dog, dogs are awesome). -- -- See 'CatOrDog' for more details on defining a union. -- -- @ -- union HumanOrAlien = Human | Alien -- @ type HumanOrAlien = Union "HumanOrAlien" '[Human, Alien] ================================================ FILE: tests/Main.hs ================================================ module Main where import Protolude import Test.Hspec import qualified Spec (spec) main :: IO () main = do hspec Spec.spec ================================================ FILE: tests/OrderedMapSpec.hs ================================================ module OrderedMapSpec (spec) where import Protolude import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, arbitrary, forAll) import Test.Hspec import qualified Data.Map as Map import GraphQL.Internal.OrderedMap (OrderedMap) import qualified GraphQL.Internal.OrderedMap as OrderedMap orderedMaps :: Gen (OrderedMap Int Int) orderedMaps = arbitrary spec :: Spec spec = describe "OrderedMap" $ do describe "Integrity" $ do prop "fromList . toList == id" $ do forAll orderedMaps (\x -> OrderedMap.orderedMap (OrderedMap.toList x) == Just x) prop "keys == Map.keys . toMap" $ do forAll orderedMaps (\x -> sort (OrderedMap.keys x) == sort (Map.keys (OrderedMap.toMap x))) prop "keys == map fst . Map.toList" $ do forAll orderedMaps (\x -> OrderedMap.keys x == map fst (OrderedMap.toList x)) prop "has unique keys" $ do forAll orderedMaps (\x -> let ks = OrderedMap.keys x in ks == ordNub ks) prop "all keys can be looked up" $ do forAll orderedMaps (\x -> let keys = OrderedMap.keys x values = OrderedMap.values x in mapMaybe (flip OrderedMap.lookup x) keys == values) it "empty is orderedMap []" $ do Just (OrderedMap.empty @Int @Int) `shouldBe` OrderedMap.orderedMap [] prop "singleton x is orderedMap [x]" $ do \x y -> Just (OrderedMap.singleton @Int @Int x y) == OrderedMap.orderedMap [(x, y)] it "preserves insertion order" $ do let items1 = [("foo", 2), ("bar", 1)] let Just x = OrderedMap.orderedMap items1 OrderedMap.toList @Text @Int x `shouldBe` items1 let items2 = [("bar", 1), ("foo", 2)] let Just y = OrderedMap.orderedMap items2 OrderedMap.toList @Text @Int y `shouldBe` items2 ================================================ FILE: tests/ResolverSpec.hs ================================================ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module ResolverSpec (spec) where import Protolude hiding (Enum) import Test.Hspec import Data.Aeson (encode, toJSON, object, (.=), Value(Null)) import GraphQL ( Response(..) , interpretAnonymousQuery ) import GraphQL.API ( Object , Field , Argument , Enum , List , (:>) ) import GraphQL.Resolver ( Handler , ResolverError(..) , (:<>)(..) , returns , handlerError ) import GraphQL.Internal.Output (singleError) import qualified GraphQL.Value as GValue import EnumTests ( Mode(NormalFile) ) -- Test a custom error monad type TMonad = ExceptT Text IO type T = Object "T" '[] '[ Field "z" Int32 , Argument "x" Int32 :> Field "t" Int32 , Argument "y" Int32 :> Field "q" (Maybe Int32) , Argument "d" Double :> Field "r" Double , Field "l" (List Int32) , Argument "n" Text :> Field "foo" (Maybe Foo) , Field "bar" (Maybe Foo) ] tHandler :: Handler TMonad T tHandler = pure $ returns 10 :<> (\x -> if x == 99 then handlerError "missed 99th value" else returns x) :<> returns . Just . (returns . (*2)) :<> (\dArg -> if dArg == 9.9 then handlerError "bad 9.9 value" else returns dArg) :<> returns ([ returns 0, returns 7, handlerError "no number 9" ]) :<> (\_nArg -> returns $ Just $ return $ returns "fred") :<> returns Nothing -- https://github.com/jml/graphql-api/issues/119 -- Maybe X didn't descend into its argument. Now it does. type Query = Object "Query" '[] '[ Argument "id" Text :> Field "test" (Maybe Foo) ] type Foo = Object "Foo" '[] '[ Field "name" Text ] data ServerFoo = ServerFoo { name :: Text } deriving (Eq, Show) lookupFoo :: Text -> IO (Maybe ServerFoo) lookupFoo _ = pure $ Just (ServerFoo "Mort") viewFoo :: ServerFoo -> Handler IO Foo viewFoo ServerFoo { name=name } = pure $ returns $ name handler :: Handler IO Query handler = pure $ \fooId -> do foo <- lookupFoo fooId returns $ viewFoo <$> foo -- Enum test type EnumQuery = Object "File" '[] '[ Field "mode" (Enum "modeEnumName" Mode) ] enumHandler :: Handler IO EnumQuery enumHandler = pure $ returns NormalFile enumHandler2 :: Handler IO EnumQuery enumHandler2 = pure $ handlerError "I forgot!" -- /Enum test spec :: Spec spec = describe "TypeAPI" $ do describe "tTest" $ do it "works in a simple Int32 case" $ do Right (Success obj) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 12) }") encode obj `shouldBe` "{\"t\":12}" it "works in a simple Double case" $ do r <- runExceptT (interpretAnonymousQuery @T tHandler "{ r(d: 1.2) }") case r of Right (Success obj) -> encode obj `shouldBe` "{\"r\":1.2}" _ -> r `shouldNotBe` r it "works for value and error list elements" $ do r <- runExceptT (interpretAnonymousQuery @T tHandler "{ l }") case r of Right (PartialSuccess obj err) -> do encode obj `shouldBe` "{\"l\":[0,7,null]}" err `shouldBe` (singleError (HandlerError "no number 9")) _ -> r `shouldNotBe` r it "works for Nullable present elements" $ do r <- runExceptT (interpretAnonymousQuery @T tHandler "{ foo(n: \"flintstone\") { name } }") case r of Right (Success obj) -> do encode obj `shouldBe` "{\"foo\":{\"name\":\"fred\"}}" _ -> r `shouldNotBe` r it "works for Nullable null elements" $ do r <- runExceptT (interpretAnonymousQuery @T tHandler "{ bar { name } }") case r of Right (Success obj) -> do encode obj `shouldBe` "{\"bar\":null}" _ -> r `shouldNotBe` r it "complains about a missing field" $ do Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ not_a_field }") errs `shouldBe` singleError (FieldNotFoundError "not_a_field") it "complains about a handler throwing an exception" $ do r <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 99) }") case r of Right (PartialSuccess v errs) -> do -- n.b. this hasn't gone through the final JSON embedding, -- so it's the individual components instead of the final -- response of '{ "data": ..., "errors": ... }' errs `shouldBe` (singleError (HandlerError "missed 99th value")) toJSON (GValue.toValue v) `shouldBe` object [ "t" .= Null ] _ -> r `shouldNotBe` r it "complains about missing argument" $ do Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }") errs `shouldBe` singleError (ValueMissing "x") describe "issue 119" $ do it "Just works" $ do Success obj <- interpretAnonymousQuery @Query handler "{ test(id: \"10\") { name } }" encode obj `shouldBe` "{\"test\":{\"name\":\"Mort\"}}" describe "Parse, validate and execute queries against API" $ do it "API.Enum works" $ do Success obj <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }" encode obj `shouldBe` "{\"mode\":\"NormalFile\"}" it "API.Enum handles errors" $ do r <- interpretAnonymousQuery @EnumQuery enumHandler2 "{ mode }" case r of (PartialSuccess obj errs) -> do encode obj `shouldBe` "{\"mode\":null}" errs `shouldBe` (singleError $ HandlerError "I forgot!") _ -> r `shouldNotBe` r ================================================ FILE: tests/SchemaSpec.hs ================================================ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} module SchemaSpec (spec) where import Protolude hiding (Down, Enum) import Test.Hspec import GraphQL.API ( Field , Enum , List , getAnnotatedInputType , getDefinition ) import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.API ( getAnnotatedType , getFieldDefinition , getInterfaceDefinition ) import GraphQL.Internal.Schema ( EnumTypeDefinition(..) , EnumValueDefinition(..) , FieldDefinition(..) , ObjectTypeDefinition(..) , InterfaceTypeDefinition(..) , AnnotatedType(..) , ListType(..) , UnionTypeDefinition(..) , GType(..) , TypeDefinition(..) , InputTypeDefinition(..) , InputObjectTypeDefinition(..) , InputObjectFieldDefinition(..) , ScalarTypeDefinition(..) , AnnotatedType(..) , NonNullType(..) , Builtin(..) , InputType(..) , getInputTypeDefinition , builtinFromName , astAnnotationToSchemaAnnotation ) import ExampleSchema spec :: Spec spec = describe "Type" $ do describe "Field" $ it "encodes correctly" $ do getFieldDefinition @(Field "hello" Int) `shouldBe` Right (FieldDefinition "hello" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt)))) describe "Interface" $ it "encodes correctly" $ do getInterfaceDefinition @Sentient `shouldBe` Right (InterfaceTypeDefinition "Sentient" (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| [])) describe "full example" $ it "encodes correctly" $ do getDefinition @Human `shouldBe` Right (ObjectTypeDefinition "Human" [ InterfaceTypeDefinition "Sentient" ( FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []) ] (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| [])) describe "output Enum" $ it "encodes correctly" $ do getAnnotatedType @(Enum "DogCommand" DogCommand) `shouldBe` Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition "DogCommand" [ EnumValueDefinition "Sit" , EnumValueDefinition "Down" , EnumValueDefinition "Heel" ]))))) describe "Union type" $ it "encodes correctly" $ do getAnnotatedType @CatOrDog `shouldBe` TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition "CatOrDog" <$> sequence (getDefinition @Cat :| [getDefinition @Dog]) describe "List" $ it "encodes correctly" $ do getAnnotatedType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinType GInt))))) getAnnotatedInputType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinInputType GInt))))) describe "TypeDefinition accepted as InputTypes" $ it "Enum/InputObject/Scalar" $ do getInputTypeDefinition (TypeDefinitionEnum (EnumTypeDefinition "DogCommand" [ EnumValueDefinition "Sit" , EnumValueDefinition "Down" , EnumValueDefinition "Heel" ])) `shouldBe` Just (InputTypeDefinitionEnum (EnumTypeDefinition "DogCommand" [ EnumValueDefinition "Sit" , EnumValueDefinition "Down" , EnumValueDefinition "Heel" ])) getInputTypeDefinition (TypeDefinitionInputObject (InputObjectTypeDefinition "Human" (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| []) )) `shouldBe` Just (InputTypeDefinitionObject (InputObjectTypeDefinition "Human" (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| []) )) getInputTypeDefinition (TypeDefinitionScalar (ScalarTypeDefinition "Human")) `shouldBe` Just (InputTypeDefinitionScalar (ScalarTypeDefinition "Human")) describe "TypeDefinition refused as InputTypes" $ -- todo: add all the others (union type, ..?) it "Object" $ do getInputTypeDefinition (TypeDefinitionObject (ObjectTypeDefinition "Human" [] (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []))) `shouldBe` Nothing describe "Builtin types from name" $ it "Int/Bool/String/Float/ID" $ do builtinFromName "Int" `shouldBe` Just GInt builtinFromName "Boolean" `shouldBe` Just GBool builtinFromName "String" `shouldBe` Just GString builtinFromName "Float" `shouldBe` Just GFloat builtinFromName "ID" `shouldBe` Just GID builtinFromName "RANDOMSTRING" `shouldBe` Nothing describe "Annotations from AST" $ it "annotation like [[ScalarType!]]!" $ do let typeDefinitionScalar = (TypeDefinitionScalar (ScalarTypeDefinition "ScalarType")) astAnnotationToSchemaAnnotation ( AST.TypeNonNull ( AST.NonNullTypeList ( AST.ListType ( AST.TypeList ( AST.ListType ( AST.TypeNonNull ( AST.NonNullTypeNamed (AST.NamedType "ScalarType") ))))))) typeDefinitionScalar `shouldBe` ( TypeNonNull ( NonNullTypeList ( ListType ( TypeList ( ListType ( TypeNonNull ( NonNullTypeNamed typeDefinitionScalar ))))))) ================================================ FILE: tests/Spec.hs ================================================ {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} ================================================ FILE: tests/ValidationSpec.hs ================================================ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} -- | Tests for query validation. module ValidationSpec (spec) where import Protolude import Test.Hspec.QuickCheck (prop) import Test.QuickCheck ((===)) import Test.Hspec import qualified Data.Set as Set import GraphQL.Internal.Name (Name) import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.Schema (emptySchema, Schema) import GraphQL.Internal.Validation ( ValidationError(..) , findDuplicates , getErrors , formatErrors ) me :: Maybe Name me = pure "me" someName :: Name someName = "name" dog :: Name dog = "dog" -- | Schema used for these tests. Since none of them do type-level stuff, we -- don't need to define it. schema :: Schema schema = emptySchema spec :: Spec spec = describe "Validation" $ do describe "getErrors" $ do it "Treats simple queries as valid" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation ( AST.Query ( AST.Node me [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ] ) ) ] getErrors schema doc `shouldBe` [] it "Treats anonymous queries as valid" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ]) ])) ] getErrors schema doc `shouldBe` [] it "Treats anonymous queries with variables as valid" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [ AST.VariableDefinition (AST.Variable "atOtherHomes") (AST.TypeNamed (AST.NamedType "Boolean")) (Just (AST.ValueBoolean True)) ] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "isHousetrained" [ AST.Argument "atOtherHomes" (AST.ValueVariable (AST.Variable "atOtherHomes")) ] [] []) ]) ])) ] getErrors schema doc `shouldBe` [] it "Treats anonymous queries with annotated variables as valid ([[Boolean]]!)" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [ AST.VariableDefinition (AST.Variable "atOtherHomes") (AST.TypeNonNull (AST.NonNullTypeList (AST.ListType (AST.TypeList (AST.ListType (AST.TypeNamed (AST.NamedType "Boolean")))) ))) Nothing ] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "isHousetrained" [ AST.Argument "atOtherHomes" (AST.ValueVariable (AST.Variable "atOtherHomes")) ] [] []) ]) ])) ] getErrors schema doc `shouldBe` [] it "Detects duplicate operation names" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation ( AST.Query ( AST.Node me [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ] ) ) , AST.DefinitionOperation ( AST.Query ( AST.Node me [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ] ) ) ] getErrors schema doc `shouldBe` [DuplicateOperation me] it "Detects duplicate anonymous operations" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation ( AST.AnonymousQuery [ AST.SelectionField (AST.Field Nothing someName [] [] []) ] ) , AST.DefinitionOperation ( AST.AnonymousQuery [ AST.SelectionField (AST.Field Nothing someName [] [] []) ] ) ] let errors = getErrors schema doc errors `shouldBe` [MixedAnonymousOperations 2 []] formatErrors errors `shouldBe` ["Multiple anonymous operations defined. Found 2"] it "Detects mixed operations" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation ( AST.AnonymousQuery [ AST.SelectionField (AST.Field Nothing someName [] [] []) ] ) , AST.DefinitionOperation ( AST.Query (AST.Node (pure "houseTrainedQuery") [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) ] )) ] let errors = getErrors schema doc errors `shouldBe` [MixedAnonymousOperations 1 [Just "houseTrainedQuery"]] formatErrors errors `shouldBe` ["Document contains both anonymous operations (1) and named operations ([Just (Name {unName = \"houseTrainedQuery\"})])"] it "Detects non-existing type in variable definition" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [ AST.VariableDefinition (AST.Variable "atOtherHomes") (AST.TypeNamed (AST.NamedType "MyNonExistingType")) (Just (AST.ValueBoolean True)) ] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "isHousetrained" [ AST.Argument "atOtherHomes" (AST.ValueVariable (AST.Variable "atOtherHomes")) ] [] []) ]) ])) ] getErrors schema doc `shouldBe` [VariableTypeNotFound (AST.Variable "atOtherHomes") "MyNonExistingType"] it "Detects unused variable definition" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [ AST.VariableDefinition (AST.Variable "atOtherHomes") (AST.TypeNamed (AST.NamedType "String")) (Just (AST.ValueBoolean True)) ] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "isHousetrained" [] [] []) ]) ])) ] getErrors schema doc `shouldBe` [UnusedVariables (Set.fromList [AST.Variable "atOtherHomes"])] it "Treats anonymous queries with inline arguments as valid" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation (AST.Query (AST.Node Nothing [] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing "isHousetrained" [ AST.Argument "atOtherHomes" (AST.ValueList (AST.ListValue [ (AST.ValueObject (AST.ObjectValue [ (AST.ObjectField "testKey" (AST.ValueInt 123)), (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string"))) ])) ])) ] [] []) ]) ])) ] getErrors schema doc `shouldBe` [] it "Detects non-existent fragment type" $ do let doc = AST.QueryDocument [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest" (AST.NamedType "Dog") [] [ AST.SelectionField (AST.Field Nothing "name" [] [] []) ])), (AST.DefinitionOperation (AST.Query (AST.Node Nothing [] [] [AST.SelectionField (AST.Field Nothing dog [] [] [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" []) ]) ]))) ] getErrors schema doc `shouldBe` [TypeConditionNotFound "Dog"] describe "findDuplicates" $ do prop "returns empty on unique lists" $ do \xs -> findDuplicates @Int (ordNub xs) === [] prop "finds only duplicates" $ \xs -> do all (>1) (count xs <$> findDuplicates @Int xs) prop "finds all duplicates" $ \xs -> do (sort . findDuplicates @Int) xs === (ordNub . sort . filter ((> 1) . count xs)) xs -- | Count the number of times 'x' occurs in 'xs'. count :: Eq a => [a] -> a -> Int count xs x = (length . filter (== x)) xs ================================================ FILE: tests/ValueSpec.hs ================================================ {-# LANGUAGE DeriveGeneric #-} module ValueSpec (spec) where import Protolude import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (forAll) import Test.Hspec import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.Arbitrary (arbitraryText, arbitraryNonEmpty) import GraphQL.Value ( Object , Value'(ValueObject') , ObjectField'(..) , astToVariableValue , unionObjects , objectFields , objectFromList , toValue ) import GraphQL.Internal.Value.FromValue (FromValue(..), prop_roundtripValue) data Resource = Resource { resText :: Text , resInt :: Int32 , resDouble :: Double , resBool :: Bool } deriving (Generic, Eq, Show) instance FromValue Resource spec :: Spec spec = describe "Value" $ do describe "unionObject" $ do it "returns empty on empty list" $ do unionObjects [] `shouldBe` (objectFromList [] :: Maybe Object) it "merges objects" $ do let (Just foo) = objectFromList [ ("foo", toValue @Int32 1) , ("bar",toValue @Int32 2)] let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") , ("baz",toValue @Int32 3)] let observed = unionObjects [foo, bar] observed `shouldBe` Nothing it "merges objects with unique keys" $ do let (Just foo) = objectFromList [("foo", toValue @Int32 1)] let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") , ("baz",toValue @Int32 3)] let (Just expected) = objectFromList [ ("foo", toValue @Int32 1) , ("bar", toValue @Text "cow") , ("baz", toValue @Int32 3) ] let (Just observed) = unionObjects [foo, bar] observed `shouldBe` expected expected `shouldSatisfy` prop_fieldsUnique describe "Objects" $ do prop "have unique fields" $ do prop_fieldsUnique -- See https://github.com/haskell-graphql/graphql-api/pull/178 for background it "derives fromValue instances for objects with more than three fields" $ do let Just value = objectFromList [ ("resText", toValue @Text "text") , ("resBool", toValue @Bool False) , ("resDouble", toValue @Double 1.2) , ("resInt", toValue @Int32 32) ] let Right observed = fromValue $ ValueObject' value let expected = Resource { resText = "text" , resInt = 32 , resDouble = 1.2 , resBool = False } observed `shouldBe` expected describe "ToValue / FromValue instances" $ do prop "Bool" $ prop_roundtripValue @Bool prop "Int32" $ prop_roundtripValue @Int32 prop "Double" $ prop_roundtripValue @Double prop "Text" $ forAll arbitraryText prop_roundtripValue prop "Lists" $ prop_roundtripValue @[Int32] prop "Non-empty lists" $ forAll (arbitraryNonEmpty @Int32) prop_roundtripValue describe "AST" $ do it "Objects converted from AST have unique fields" $ do let input = AST.ObjectValue [ AST.ObjectField "foo" (AST.ValueString (AST.StringValue "bar")) , AST.ObjectField "foo" (AST.ValueString (AST.StringValue "qux")) ] astToVariableValue (AST.ValueObject input) `shouldBe` Nothing -- | All of the fields in an object should have unique names. prop_fieldsUnique :: Object -> Bool prop_fieldsUnique object = fieldNames == ordNub fieldNames where fieldNames = [name | ObjectField name _ <- objectFields object] ================================================ FILE: tests/doctests/Main.hs ================================================ module Main (main) where import Protolude import Test.DocTest main :: IO () main = doctest $ ["-isrc"] <> options <> files where options = map ("-X" <>) extensions -- These must match the extensions in package.yaml. extensions = [ "NoImplicitPrelude" , "OverloadedStrings" , "RecordWildCards" , "TypeApplications" , "DataKinds" ] -- library code files = [ "src/" ]