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